[Social List] Some funs to inherit groups

src/Gargantext/Core/Text/Group.hs

@@ -20,10 +20,9 @@ import Data.Map (Map)
 import Data.Text (Text)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text (size)
-import Gargantext.Core.Types (ListType(..))
+import Gargantext.Core.Types (ListType(..)) -- (MasterCorpusId, UserCorpusId)
 import Gargantext.Database.Admin.Types.Node (NodeId)
-import Gargantext.Core.Text.List.Learn (Model(..))
-import Gargantext.Core.Types (MasterCorpusId, UserCorpusId)
+-- import Gargantext.Core.Text.List.Learn (Model(..))
 import Gargantext.Core.Text.Terms.Mono.Stem (stem)
 import Gargantext.Prelude
 import qualified Data.Set  as Set
@@ -31,7 +30,7 @@ import qualified Data.Map  as Map
 import qualified Data.List as List
 import qualified Data.Text as Text
 
-
+{-
 data NgramsListBuilder = BuilderStepO { stemSize :: !Int
                                       , stemX    :: !Int
                                       , stopSize :: !StopSize
@@ -45,6 +44,7 @@ data NgramsListBuilder = BuilderStepO { stemSize :: !Int
                                , nlb_userCorpusId   :: !UserCorpusId
                                , nlb_masterCorpusId :: !MasterCorpusId
                                }
+-}
 
 data StopSize = StopSize {unStopSize :: !Int}
 
@@ -52,13 +52,12 @@ data StopSize = StopSize {unStopSize :: !Int}
 -- discussed. Main purpose of this is offering
 -- a first grouping option to user and get some
 -- enriched data to better learn and improve that algo
-
 data GroupParams = GroupParams { unGroupParams_lang  :: !Lang
                                , unGroupParams_len   :: !Int
                                , unGroupParams_limit :: !Int
                                , unGroupParams_stopSize :: !StopSize
                                }
-                   | GroupIdentity
+                 | GroupIdentity
 
 ngramsGroup :: GroupParams
             -> Text
@@ -72,7 +71,7 @@ ngramsGroup (GroupParams l _m _n _) = Text.intercalate " "
                   . Text.splitOn " "
                   . Text.replace "-" " "
 
-------------------------------------------------------------------------------
+------------------------------------------------------------------------
 toGroupedText :: Ord b
               => (Text -> Text)
               -> (a -> b)
@@ -108,7 +107,7 @@ groupStems' = Map.fromListWith grouping
           gr    = Set.union group1 group2
           nodes = Set.union nodes1 nodes2
 
-------------------------------------------------------------------------------
+------------------------------------------------------------------------
 type Group = Lang -> Int -> Int -> Text -> Text
 type Stem  = Text
 type Label = Text
@@ -137,18 +136,15 @@ instance (Eq a, Ord a) => Ord (GroupedText a) where
 -- Lenses Instances
 makeLenses 'GroupedText
 
-------------------------------------------------------------------------------
+------------------------------------------------------------------------
 addListType :: Map Text ListType -> GroupedText a -> GroupedText a
 addListType m g = set gt_listType (hasListType m g) g
   where
     hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
     hasListType m' (GroupedText _ label _ g' _ _ _) =
-      List.foldl' (<>) Nothing
+        List.foldl' (<>) Nothing
       $ map (\t -> Map.lookup t m')
       $ Set.toList
       $ Set.insert label g'
 
 
-
-
-

src/Gargantext/Core/Text/List/Social.hs

@@ -35,6 +35,7 @@ import qualified Data.List  as List
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
+------------------------------------------------------------------------
 flowSocialList :: ( RepoCmdM env err m
                   , CmdM     env err m
                   , HasNodeError err
@@ -108,7 +109,7 @@ flowSocialListByMode mode user nt ngrams' = do
       -- printDebug "flowSocialListByMode r" r
       pure r
 
----------------------------------------------------------------------------
+------------------------------------------------------------------------
 -- TODO: maybe use social groups too
 toSocialList :: Map Text (Map ListType Int)
              -> Set Text
@@ -141,7 +142,7 @@ toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
                      , (StopTerm     , 3)
                      ]
 
----------------------------------------------------------------------------
+------------------------------------------------------------------------
 -- | [ListId] does not merge the lists (it is for Master and User lists
 -- here we need UserList only
 countFilterList :: RepoCmdM env err m
@@ -161,14 +162,60 @@ countFilterList' st nt ls input = do
   -- printDebug "countFilterList'" ml
   pure $ Set.foldl' (\m t -> countList t ml m) input st
 
----------------------------------------------------------------------------
+------------------------------------------------------------------------
 -- FIXME children have to herit the ListType of the parent
 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 toMapTextListType m = Map.fromListWith (<>)
-                    $  List.concat
-                    $ (map (toList m))
-                    $  Map.toList m
+                    $ List.concat
+                    $ map (toList m)
+                    $ Map.toList m
+
+----------------------
+type Parent = Text
+
+hasParent :: Text
+          -> Map Text (Map Parent Int)
+          -> Maybe Parent
+hasParent t m = case Map.lookup t m of
+  Nothing  -> Nothing
+  Just  m' -> (fst . fst) <$> Map.maxViewWithKey m'
+
+
+toMapTextParent :: Set Text
+                ->  Map Text (Map Parent Int)
+                -> [Map Text NgramsRepoElement]
+                -> Map Text (Map Parent Int)
+toMapTextParent ts = foldl' (toMapTextParent' ts)
+  where
+
+    toMapTextParent' :: Set Text
+                    -> Map Text (Map Parent Int)
+                    -> Map Text NgramsRepoElement
+                    -> Map Text (Map Parent Int)
+    toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' from) to ts'
+
+
+    toMapTextParent'' :: Map Text NgramsRepoElement
+                      -> Map Text (Map Parent Int)
+                      -> Text
+                      -> Map Text (Map Parent Int)
+    toMapTextParent'' from to t = case Map.lookup t from of
+      Nothing  -> to
+      Just nre -> case _nre_parent nre of
+        Just (NgramsTerm p')  -> Map.alter (addParent p') t to
+          where
+            addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
+            addParent p'' (Just ps) = Just $ addCountParent p'' ps
+        _ -> to
+
+addCountParent :: Parent -> Map Parent Int -> Map Parent Int
+addCountParent p m = Map.alter addCount p m
+  where
+    addCount Nothing  = Just 1
+    addCount (Just n) = Just $ n + 1
+
 
+------------------------------------------------------------------------
 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
      List.zip terms (List.cycle [lt'])
@@ -184,9 +231,10 @@ listOf m ng = case _nre_parent ng of
   Nothing -> _nre_list ng
   Just  p -> case Map.lookup (unNgramsTerm p) m of
     Just ng' -> listOf m ng'
-    Nothing  -> panic "CandidateTerm -- Should Not happen"
+    Nothing  -> CandidateTerm
+    -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
 
----------------------------------------------------------------------------
+------------------------------------------------------------------------
 countList :: Text
           -> Map Text ListType
           -> Map Text (Map ListType Int)
@@ -195,11 +243,11 @@ countList t m input = case Map.lookup t m of
   Nothing -> input
   Just l  -> Map.alter addList t input
     where
-      addList Nothing   = Just $ addCount l Map.empty
-      addList (Just lm) = Just $ addCount l lm
+      addList Nothing   = Just $ addCountList l Map.empty
+      addList (Just lm) = Just $ addCountList l lm
 
-addCount :: ListType -> Map ListType Int -> Map ListType Int
-addCount l m = Map.alter (plus l) l  m
+addCountList :: ListType -> Map ListType Int -> Map ListType Int
+addCountList l m = Map.alter (plus l) l  m
   where
     plus CandidateTerm Nothing  = Just 1
     plus CandidateTerm (Just x) = Just $ x + 1
@@ -228,5 +276,3 @@ findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
 commonNodes:: [NodeType]
 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 
-
-