[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,7 +69,7 @@ flowSocialListByMode :: ( RepoCmdM env err m
                        )
                     => [NodeId]-> NgramsType -> Set Text
                     -> m (Map (Maybe ListType) (Set Text))
-flowSocialListByMode      [] nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
+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'

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'
 
+------------------------------------------------------------------------
+
+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)
+makeLenses ''FlowListScores
+
+------------------------------------------------------------------------
+-- | toFlowListScores which generate Score from list of Map Text NgramsRepoElement
+
+toFlowListScores :: Set Text
+                -> Map Text FlowListScores
                 -> [Map Text NgramsRepoElement]
-                -> Map Text (Map Parent Int)
-toMapTextParent ts = foldl' (toMapTextParent' ts)
+                -> Map Text FlowListScores
+toFlowListScores ts = foldl' (toFlowListScores' ts)
   where
-
-    toMapTextParent' :: Set Text
-                    -> Map Text (Map Parent Int)
+    toFlowListScores' :: Set Text
+                     -> Map Text FlowListScores
                      -> Map Text NgramsRepoElement
-                    -> Map Text (Map Parent Int)
-    toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' ts' from) to ts'
-
+                     -> Map Text FlowListScores
+    toFlowListScores' ts' to' ngramsRepo =
+      Set.foldl' (toFlowListScores'' ts' ngramsRepo) to' ts'
 
-    toMapTextParent'' :: Set Text
+    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
+                      -> 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
-            addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
-            addParent p'' (Just ps) = Just $ addCountParent p'' ps
+      mapList' = addList' l mapList
+
 
-            addCountParent :: Parent -> Map Parent Int -> Map Parent Int
-            addCountParent p m = Map.alter addCount p m
+addList' :: ListType -> Map ListType Int -> Map ListType Int
+addList' l m = Map.alter (plus l) l  m
   where
-                addCount Nothing  = Just 1
-                addCount (Just n) = Just $ n + 1
+    plus CandidateTerm Nothing  = Just 1
+    plus CandidateTerm (Just x) = Just $ x + 1
 
-        _ -> to
+    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

@@ -60,10 +60,9 @@ toMapTextListType m = Map.fromListWith (<>)
                     $ List.concat
                     $ map (toList m)
                     $ Map.toList m
-
-------------------------------------------------------------------------
-toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
-toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
+  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]
@@ -72,8 +71,8 @@ toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
                   <> (map unNgramsTerm $ Map.keys children)
             lt'   = listOf m nre
 
-listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
-listOf m ng = case _nre_parent ng of
+            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'
@@ -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
+      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
+