[REFACT] SocialLists: merging scores

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

@@ -11,30 +11,23 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social
   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.Maybe (fromMaybe)
 import Data.Semigroup (Semigroup(..))
+import Data.Set (Set)
 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 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 Gargantext.Core.Types.Individu
+import Gargantext.Core.Types.Main
+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.Schema.Ngrams
+import Gargantext.Prelude
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
@@ -76,8 +69,8 @@ flowSocialListByMode :: ( RepoCmdM env err m
                        )
                     => [NodeId]-> NgramsType -> Set Text
                     -> m (Map (Maybe ListType) (Set Text))
-flowSocialListByMode      [] nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
-flowSocialListByMode listIds nt ngrams' = do
+flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
+flowSocialListByMode listIds  nt ngrams' = do
     counts  <- countFilterList ngrams' nt listIds Map.empty
     let r = toSocialList counts ngrams'
     pure r

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

@@ -8,38 +8,39 @@ Stability   : experimental
 Portability : POSIX
 -}
 
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+
 module Gargantext.Core.Text.List.Social.Group
   where
 
--- findList imports
+import Control.Lens
+import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import Data.Semigroup (Semigroup(..))
+import Data.Set (Set)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types.Main
 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
+------------------------------------------------------------------------
 
+-- | Tools
 parentUnionsMerge :: (Ord a, Ord b, Num c)
                    => [Map a (Map b c)]
                    ->  Map a (Map b c)
@@ -56,6 +57,9 @@ parentUnionsExcl :: Ord a
                  ->  Map a b
 parentUnionsExcl = Map.unions
 
+------------------------------------------------------------------------
+
+type Parent = Text
 
 hasParent :: Text
           -> Map Text (Map Parent Int)
@@ -64,43 +68,100 @@ 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
+data FlowListScores =
+  FlowListScores { _flc_parents :: Map Parent   Int
+                 , _flc_lists   :: Map ListType Int
+                -- You can add any score by incrementing this type
+                -- , _flc_score   :: Map Score Int
+                 }
+    deriving (Generic)
 
-    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'
+makeLenses ''FlowListScores
 
+------------------------------------------------------------------------
+-- | toFlowListScores which generate Score from list of Map Text NgramsRepoElement
 
-    toMapTextParent'' :: Set Text
+toFlowListScores :: Set Text
+                -> Map Text FlowListScores
+                -> [Map Text NgramsRepoElement]
+                -> Map Text FlowListScores
+toFlowListScores ts = foldl' (toFlowListScores' ts)
+  where
+    toFlowListScores' :: Set Text
+                     -> Map Text FlowListScores
+                     -> Map Text NgramsRepoElement
+                     -> Map Text FlowListScores
+    toFlowListScores' ts' to' ngramsRepo =
+      Set.foldl' (toFlowListScores'' ts' ngramsRepo) to' ts'
+
+    toFlowListScores'' :: Set Text
                       -> Map Text NgramsRepoElement
-                      -> Map Text (Map Parent Int)
+                      -> Map Text FlowListScores
                       -> 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
+                      -> Map Text FlowListScores
+    toFlowListScores'' ss ngramsRepo to'' t =
+      case Map.lookup t ngramsRepo of
+        Nothing  -> to''
+        Just nre -> Map.alter (addParent nre ss)        t
+                  $ Map.alter (addList $ _nre_list nre) t to''
+
+------------------------------------------------------------------------
+-- | Main addFunctions to FlowListScores
+------------------------------------------------------------------------
+
+-- | Very unseful but nice comment:
+-- "this function looks like an ASCII bird"
+addList :: ListType
+        -> Maybe FlowListScores
+        -> Maybe FlowListScores
+addList l Nothing =
+  Just $ FlowListScores Map.empty (addList' l Map.empty)
+
+addList l (Just (FlowListScores mapParent mapList)) =
+  Just $ FlowListScores mapParent mapList'
+    where
+      mapList' = addList' l mapList
+
 
+addList' :: ListType -> Map ListType Int -> Map ListType Int
+addList' 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
+
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+addParent :: NgramsRepoElement -> Set Text
+          -> Maybe FlowListScores
+          -> Maybe FlowListScores
+
+addParent nre ss Nothing  =
+  Just $ FlowListScores mapParent Map.empty
+    where
+      mapParent = addParent' (_nre_parent nre) ss Map.empty
+
+addParent nre ss (Just (FlowListScores mapParent mapList)) =
+  Just $ FlowListScores mapParent' mapList
+    where
+      mapParent' = addParent' (_nre_parent nre) ss mapParent
+
+addParent' :: Num a
+           => Maybe NgramsTerm
+           -> Set Text
+           -> Map Text a
+           -> Map Text a
+addParent' Nothing               _ss mapParent = mapParent
+addParent' (Just (NgramsTerm p')) ss mapParent =
+  if not (Set.member p' ss)
+    then mapParent
+    else Map.alter addCount p' mapParent
+      where
+        addCount Nothing  = Just 1
+        addCount (Just n) = Just $ n + 1
 
 ------------------------------------------------------------------------

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

@@ -40,14 +40,14 @@ import qualified Data.Set   as Set
 -- here we need UserList only
 countFilterList :: RepoCmdM env err m
         => Set Text -> NgramsType -> [ListId]
-        -> Map Text (Map ListType Int)
+        ->    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
     where
       countFilterList' :: RepoCmdM env err m
               => Set Text -> NgramsType -> [ListId]
-              -> Map Text (Map ListType Int)
+              ->    Map Text (Map ListType Int)
               -> m (Map Text (Map ListType Int))
       countFilterList' st nt ls input = do
         ml <- toMapTextListType <$> getListNgrams ls nt
@@ -60,25 +60,24 @@ toMapTextListType m = Map.fromListWith (<>)
                     $ List.concat
                     $ map (toList m)
                     $ Map.toList m
+  where
+    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
 
-------------------------------------------------------------------------
-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"
+            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
@@ -89,14 +88,16 @@ 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
+      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
 
-    plus _ Nothing              = Just 3
-    plus _ (Just x)             = Just $ x + 3