[REFACT] SocialList (WIP)

src/Gargantext/Core/Text/List.hs

@@ -82,6 +82,7 @@ buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
 
   ngs  <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt
 
+
   let 
     grouped = toGroupedText groupIt (Set.size . snd) fst snd
               (Map.toList $ Map.mapWithKey (\k (a,b) -> (Set.delete k a, b)) $ ngs)
@@ -132,10 +133,10 @@ buildNgramsTermsList user uCid mCid groupParams = do
     _socialMap  = fromMaybe Set.empty $ Map.lookup MapTerm       socialLists
     _socialCand = fromMaybe Set.empty $ Map.lookup CandidateTerm socialLists
     -- stopTerms ignored for now (need to be tagged already)
-    (stopTerms, candidateTerms) = List.partition ((\t -> Set.member t socialStop) . fst) allTerms
+    -- (stopTerms, candidateTerms) = List.partition ((\t -> Set.member t socialStop) . fst) allTerms
     -- (mapTerms,  candidateTerms) = List.partition ((\t -> Set.member t socialMap ) . fst) allTerms
 
-  printDebug "stopTerms" stopTerms
+  -- printDebug "stopTerms" stopTerms
 
   -- Grouping the ngrams and keeping the maximum score for label
   let grouped = toGroupedText (ngramsGroup groupParams) identity (const Set.empty) (const Set.empty) allTerms

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

@@ -31,6 +31,9 @@ import Gargantext.API.Ngrams.Tools -- (getListNgrams)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Main
 import Gargantext.Database.Schema.Ngrams
+import Gargantext.Core.Text.List.Social.Find
+import Gargantext.Core.Text.List.Social.Group
+import Gargantext.Core.Text.List.Social.ListType
 import qualified Data.List  as List
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
@@ -81,14 +84,6 @@ unions_test = unions [m1, m2]
                       ]
 
 ------------------------------------------------------------------------
-termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
-termsByList CandidateTerm m = Set.unions
-                          $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
-                          [ Nothing, Just CandidateTerm ]
-termsByList l m =
-  fromMaybe Set.empty $ Map.lookup (Just l) m
-
-
 flowSocialListByMode :: ( RepoCmdM env err m
                         , CmdM     env err m
                         , HasNodeError err
@@ -140,160 +135,3 @@ 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
-        => Set Text -> NgramsType -> [ListId]
-        -> Map Text (Map ListType Int)
-        -> m (Map Text (Map ListType Int))
-countFilterList st nt ls input =
-  foldM' (\m l -> countFilterList' st nt [l] m) input ls
-
-
-countFilterList' :: RepoCmdM env err m
-        => Set Text -> NgramsType -> [ListId]
-        -> Map Text (Map ListType Int)
-        -> m (Map Text (Map ListType Int))
-countFilterList' st nt ls input = do
-  ml <- toMapTextListType <$> getListNgrams ls nt
-  -- 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
-
-----------------------
--- | Tools to inherit groupings
-----------------------
-type Parent = Text
-
-parentUnionsMerge :: (Ord a, Ord b, Num c) 
-                   => [Map a (Map b c)]
-                   ->  Map a (Map b c)
-parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
-
--- This Parent union is specific
--- [Private, Shared, Public]
--- means the following preferences:
--- Private > Shared > Public
--- if data have not been tagged privately, then use others tags
--- This unions behavior takes first key only and ignore others
-parentUnionsExcl :: Ord a
-                 => [Map a b]
-                 -> Map a b
-parentUnionsExcl = Map.unions
-
-
-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'' ts' from) to ts'
-
-
-    toMapTextParent'' :: Set Text
-                      -> Map Text NgramsRepoElement
-                      -> Map Text (Map Parent Int)
-                      -> Text
-                      -> Map Text (Map Parent Int)
-    toMapTextParent'' ss from to t = case Map.lookup t from of
-      Nothing  -> to
-      Just nre -> case _nre_parent nre of
-        Just (NgramsTerm p')  -> if Set.member p' ss
-                                    then Map.alter (addParent p') t to
-                                    else to
-          where
-            addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
-            addParent p'' (Just ps) = Just $ addCountParent p'' ps
-
-            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
-
-        _ -> to
-
-
-------------------------------------------------------------------------
-toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
-toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
-     List.zip terms (List.cycle [lt'])
-      where
-        terms =  [t]
-              -- <> maybe [] (\n -> [unNgramsTerm n]) root
-              -- <> maybe [] (\n -> [unNgramsTerm n]) parent
-              <> (map unNgramsTerm $ Map.keys children)
-        lt'   = listOf m nre
-
-listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
-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  -> CandidateTerm
-    -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
-
-------------------------------------------------------------------------
-countList :: Text
-          -> Map Text ListType
-          -> Map Text (Map ListType Int)
-          -> Map Text (Map ListType Int)
-countList t m input = case Map.lookup t m of
-  Nothing -> input
-  Just l  -> Map.alter addList t input
-    where
-      addList Nothing   = Just $ addCountList l Map.empty
-      addList (Just lm) = Just $ addCountList l lm
-
-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
-
-    plus _ Nothing              = Just 3
-    plus _ (Just x)             = Just $ x + 3
-
-------------------------------------------------------------------------
-findListsId :: (HasNodeError err, HasTreeError err)
-            => NodeMode -> User -> Cmd err [NodeId]
-findListsId mode u = do
-  r <- getRootId u
-  ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
-                       <$> findNodes' mode r
-  -- printDebug "findListsIds" ns
-  pure ns
-
-
-findNodes' :: HasTreeError err
-          => NodeMode -> RootId
-          -> Cmd err [DbTreeNode]
-findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
-findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
-findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
-
-commonNodes:: [NodeType]
-commonNodes = [NodeFolder, NodeCorpus, NodeList]
-

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

+{-|
+Module      : Gargantext.Core.Text.List.Social.Find
+Description :
+Copyright   : (c) CNRS, 2018-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Gargantext.Core.Text.List.Social.Find
+  where
+
+-- findList imports
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Tree
+import Gargantext.Database.Query.Tree.Root (getRootId)
+import Gargantext.Prelude
+
+-- filterList imports
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Semigroup (Semigroup(..))
+import Data.Text (Text)
+import Gargantext.API.Ngrams.Tools -- (getListNgrams)
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Database.Schema.Ngrams
+import qualified Data.List  as List
+import qualified Data.Map   as Map
+import qualified Data.Set   as Set
+
+------------------------------------------------------------------------
+findListsId :: (HasNodeError err, HasTreeError err)
+            => NodeMode -> User -> Cmd err [NodeId]
+findListsId mode u = do
+  r <- getRootId u
+  ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
+                       <$> findNodes' mode r
+  -- printDebug "findListsIds" ns
+  pure ns
+
+
+findNodes' :: HasTreeError err
+          => NodeMode -> RootId
+          -> Cmd err [DbTreeNode]
+findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
+findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
+findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
+
+commonNodes:: [NodeType]
+commonNodes = [NodeFolder, NodeCorpus, NodeList]

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

+{-|
+Module      : Gargantext.Core.Text.List.Social.Group
+Description :
+Copyright   : (c) CNRS, 2018-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Gargantext.Core.Text.List.Social.Group
+  where
+
+-- findList imports
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Tree
+import Gargantext.Database.Query.Tree.Root (getRootId)
+import Gargantext.Prelude
+
+-- filterList imports
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Semigroup (Semigroup(..))
+import Data.Text (Text)
+import Gargantext.API.Ngrams.Tools -- (getListNgrams)
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Database.Schema.Ngrams
+import qualified Data.List  as List
+import qualified Data.Map   as Map
+import qualified Data.Set   as Set
+
+----------------------
+-- | Tools to inherit groupings
+----------------------
+type Parent = Text
+
+parentUnionsMerge :: (Ord a, Ord b, Num c)
+                   => [Map a (Map b c)]
+                   ->  Map a (Map b c)
+parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
+
+-- This Parent union is specific
+-- [Private, Shared, Public]
+-- means the following preferences:
+-- Private > Shared > Public
+-- if data have not been tagged privately, then use others tags
+-- This unions behavior takes first key only and ignore others
+parentUnionsExcl :: Ord a
+                 => [Map a b]
+                 ->  Map a b
+parentUnionsExcl = Map.unions
+
+
+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'' ts' from) to ts'
+
+
+    toMapTextParent'' :: Set Text
+                      -> Map Text NgramsRepoElement
+                      -> Map Text (Map Parent Int)
+                      -> Text
+                      -> Map Text (Map Parent Int)
+    toMapTextParent'' ss from to t = case Map.lookup t from of
+      Nothing  -> to
+      Just nre -> case _nre_parent nre of
+        Just (NgramsTerm p')  -> if Set.member p' ss
+                                    then Map.alter (addParent p') t to
+                                    else to
+          where
+            addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
+            addParent p'' (Just ps) = Just $ addCountParent p'' ps
+
+            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
+
+        _ -> to
+
+
+------------------------------------------------------------------------
+toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
+toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
+     List.zip terms (List.cycle [lt'])
+      where
+        terms =  [t]
+              -- <> maybe [] (\n -> [unNgramsTerm n]) root
+              -- <> maybe [] (\n -> [unNgramsTerm n]) parent
+              <> (map unNgramsTerm $ Map.keys children)
+        lt'   = listOf m nre
+
+listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
+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  -> CandidateTerm
+    -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
+
+------------------------------------------------------------------------
+countList :: Text
+          -> Map Text ListType
+          -> Map Text (Map ListType Int)
+          -> Map Text (Map ListType Int)
+countList t m input = case Map.lookup t m of
+  Nothing -> input
+  Just l  -> Map.alter addList t input
+    where
+      addList Nothing   = Just $ addCountList l Map.empty
+      addList (Just lm) = Just $ addCountList l lm
+
+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
+
+    plus _ Nothing              = Just 3
+    plus _ (Just x)             = Just $ x + 3

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

+{-|
+Module      : Gargantext.Core.Text.List.Social.ListType
+Description :
+Copyright   : (c) CNRS, 2018-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Gargantext.Core.Text.List.Social.ListType
+  where
+
+-- findList imports
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Tree
+import Gargantext.Database.Query.Tree.Root (getRootId)
+import Gargantext.Prelude
+
+-- filterList imports
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Semigroup (Semigroup(..))
+import Data.Text (Text)
+import Gargantext.API.Ngrams.Tools -- (getListNgrams)
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Database.Schema.Ngrams
+import qualified Data.List  as List
+import qualified Data.Map   as Map
+import qualified Data.Set   as Set
+
+------------------------------------------------------------------------
+termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
+termsByList CandidateTerm m = Set.unions
+                          $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
+                          [ Nothing, Just CandidateTerm ]
+termsByList l m =
+  fromMaybe Set.empty $ Map.lookup (Just l) m
+
+
+------------------------------------------------------------------------
+-- | [ListId] does not merge the lists (it is for Master and User lists
+-- here we need UserList only
+countFilterList :: RepoCmdM env err m
+        => Set Text -> NgramsType -> [ListId]
+        -> Map Text (Map ListType Int)
+        -> m (Map Text (Map ListType Int))
+countFilterList st nt ls input =
+  foldM' (\m l -> countFilterList' st nt [l] m) input ls
+
+
+countFilterList' :: RepoCmdM env err m
+        => Set Text -> NgramsType -> [ListId]
+        -> Map Text (Map ListType Int)
+        -> m (Map Text (Map ListType Int))
+countFilterList' st nt ls input = do
+  ml <- toMapTextListType <$> getListNgrams ls nt
+  -- 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
+
+----------------------
+-- | Tools to inherit groupings
+----------------------
+type Parent = Text
+
+parentUnionsMerge :: (Ord a, Ord b, Num c)
+                   => [Map a (Map b c)]
+                   ->  Map a (Map b c)
+parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
+
+-- This Parent union is specific
+-- [Private, Shared, Public]
+-- means the following preferences:
+-- Private > Shared > Public
+-- if data have not been tagged privately, then use others tags
+-- This unions behavior takes first key only and ignore others
+parentUnionsExcl :: Ord a
+                 => [Map a b]
+                 ->  Map a b
+parentUnionsExcl = Map.unions
+
+
+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'' ts' from) to ts'
+
+
+    toMapTextParent'' :: Set Text
+                      -> Map Text NgramsRepoElement
+                      -> Map Text (Map Parent Int)
+                      -> Text
+                      -> Map Text (Map Parent Int)
+    toMapTextParent'' ss from to t = case Map.lookup t from of
+      Nothing  -> to
+      Just nre -> case _nre_parent nre of
+        Just (NgramsTerm p')  -> if Set.member p' ss
+                                    then Map.alter (addParent p') t to
+                                    else to
+          where
+            addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
+            addParent p'' (Just ps) = Just $ addCountParent p'' ps
+
+            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
+
+        _ -> to
+
+
+------------------------------------------------------------------------
+toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
+toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
+     List.zip terms (List.cycle [lt'])
+      where
+        terms =  [t]
+              -- <> maybe [] (\n -> [unNgramsTerm n]) root
+              -- <> maybe [] (\n -> [unNgramsTerm n]) parent
+              <> (map unNgramsTerm $ Map.keys children)
+        lt'   = listOf m nre
+
+listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
+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  -> CandidateTerm
+    -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
+
+------------------------------------------------------------------------
+countList :: Text
+          -> Map Text ListType
+          -> Map Text (Map ListType Int)
+          -> Map Text (Map ListType Int)
+countList t m input = case Map.lookup t m of
+  Nothing -> input
+  Just l  -> Map.alter addList t input
+    where
+      addList Nothing   = Just $ addCountList l Map.empty
+      addList (Just lm) = Just $ addCountList l lm
+
+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
+
+    plus _ Nothing              = Just 3
+    plus _ (Just x)             = Just $ x + 3