[FIX] Social List computations

src/Gargantext/Core/Text/List.hs

@@ -96,27 +96,26 @@ buildNgramsOthersList :: (--  RepoCmdM env err m
                       -> (Text -> Text)
                       -> NgramsType
                       -> Cmd err (Map NgramsType [NgramsElement])
-buildNgramsOthersList user uCid groupIt nt = do
+buildNgramsOthersList _user uCid groupIt nt = do
   ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt
 
   let
     listSize = 9
-    all'     = List.reverse
-             $ List.sortOn (Set.size . snd . snd)
+    all'     = List.sortOn (Down . Set.size . snd . snd)
              $ Map.toList ngs
 
-    graphTerms = List.take listSize all'
-    candiTerms = List.drop listSize all'
+    (graphTerms, candiTerms) = List.splitAt listSize all'
 
-  pure $ Map.unionsWith (<>) [ toElements MapTerm     graphTerms
-                             , toElements CandidateTerm candiTerms
+  pure $ Map.unionsWith (<>) [ toElements nt MapTerm       graphTerms
+                             , toElements nt CandidateTerm candiTerms
                              ]
-    where
-      toElements nType x =
-        Map.fromList [(nt, [ mkNgramsElement (NgramsTerm t) nType Nothing (mSetFromList [])
-                           | (t, _ns) <- x
-                           ]
-                     )]
+
+toElements :: Ord k => k -> ListType -> [(Text, b)] -> Map k [NgramsElement]
+toElements nType lType x =
+  Map.fromList [(nType, [ mkNgramsElement (NgramsTerm t) lType Nothing (mSetFromList [])
+                        | (t, _ns) <- x
+                        ]
+               )]
 
 -- TODO use ListIds
 buildNgramsTermsList :: ( HasNodeError err
@@ -132,7 +131,7 @@ buildNgramsTermsList :: ( HasNodeError err
                         -> UserCorpusId
                         -> MasterCorpusId
                         -> m (Map NgramsType [NgramsElement])
-buildNgramsTermsList user l n m s uCid mCid = do
+buildNgramsTermsList user l n m _s uCid mCid = do
 
 -- Computing global speGen score
   allTerms <- Map.toList <$> getTficf uCid mCid NgramsTerms
@@ -141,11 +140,18 @@ buildNgramsTermsList user l n m s uCid mCid = do
   -- printDebug "tail candidates" (List.take 10 $ List.reverse $ allTerms)
 
   -- First remove stops terms
-  mapSocialList <- flowSocialList user NgramsTerms (Set.fromList $ map fst allTerms)
+  socialLists <- flowSocialList user NgramsTerms (Set.fromList $ map fst allTerms)
+
+  printDebug "\n * socialLists * \n" socialLists
 
   let
+    _socialMap  = fromMaybe Set.empty $ Map.lookup MapTerm       socialLists
+    _socialCand = fromMaybe Set.empty $ Map.lookup CandidateTerm socialLists
+    socialStop  = fromMaybe Set.empty $ Map.lookup StopTerm      socialLists
     -- stopTerms ignored for now (need to be tagged already)
-    (_stopTerms, candidateTerms) = List.partition ((isStopTerm s) . fst) allTerms
+    (stopTerms, candidateTerms) = List.partition ((\t -> Set.member t socialStop) . fst) allTerms
+
+  printDebug "stopTerms" stopTerms
 
   -- Grouping the ngrams and keeping the maximum score for label
   let grouped = groupStems'
@@ -258,7 +264,7 @@ buildNgramsTermsList user l n m s uCid mCid = do
 
     -- Final Step building the Typed list
     -- (map (toGargList $ Just StopTerm) stopTerms) -- Removing stops (needs social score)
-    termListHead = 
+    termListHead =
              (map (\g -> g { _gt_listType = Just MapTerm} )  (  monoScoredInclHead
                                                  <> monoScoredExclHead
                                                  <> multScoredInclHead
@@ -280,12 +286,13 @@ buildNgramsTermsList user l n m s uCid mCid = do
   printDebug "multScoredInclHead" multScoredInclHead
   printDebug "multScoredExclTail" multScoredExclTail
 
-
-
-  pure $ Map.fromList [(NgramsTerms, (List.concat $ map toNgramsElement $ termListHead)
+  pure $ Map.unionsWith (<>)
+       [ Map.fromList [(
+                        NgramsTerms, (List.concat $ map toNgramsElement $ termListHead)
                                   <> (List.concat $ map toNgramsElement $ termListTail)
-                       )
-                      ]
+                      )]
+       , toElements NgramsTerms StopTerm stopTerms
+       ]
 
 groupStems :: [(Stem, GroupedText Double)] -> [GroupedText Double]
 groupStems = Map.elems . groupStems'

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

@@ -43,32 +43,31 @@ flowSocialList :: ( RepoCmdM env err m
                   => User -> NgramsType -> Set Text
                   -> m (Map ListType (Set Text))
 flowSocialList user nt ngrams' = do
-  privateMapList <- flowSocialListByMode Private user nt ngrams'
-  sharedMapList  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateMapList)
+  privateLists <- flowSocialListByMode Private user nt ngrams'
+  printDebug "* privateLists *: \n" privateLists
+  sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
+  printDebug "* socialLists *: \n" sharedLists
    -- TODO publicMapList
 
-  pure $ Map.fromList [ (MapTerm,  termsByList MapTerm privateMapList
-                                     <> termsByList MapTerm sharedMapList
+  pure $ Map.fromList [ (MapTerm, termsByList MapTerm privateLists
+                               <> termsByList MapTerm sharedLists
                         )
-                      , (StopTerm, termsByList StopTerm privateMapList
-                                     <> termsByList StopTerm sharedMapList
+                      , (StopTerm, termsByList StopTerm privateLists
+                                <> termsByList StopTerm sharedLists
                         )
-                      , (CandidateTerm, termsByList CandidateTerm sharedMapList)
+                      , (CandidateTerm, termsByList CandidateTerm sharedLists)
                       ]
 
 
 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
-termsByList CandidateTerm m =
-  fromMaybe Set.empty
-          $ (<>) <$> Map.lookup Nothing              m
-                 <*> Map.lookup (Just CandidateTerm) m
+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
@@ -78,8 +77,12 @@ flowSocialListByMode :: ( RepoCmdM env err m
                      -> m (Map (Maybe ListType) (Set Text))
 flowSocialListByMode mode user nt ngrams' = do
   listIds <- findListsId mode user
-  counts  <- countFilterList ngrams' nt listIds Map.empty
-  pure $ toSocialList counts ngrams'
+  case listIds of
+    [] -> pure $ Map.fromList [(Nothing, ngrams')]
+    _  -> do
+      counts  <- countFilterList ngrams' nt listIds Map.empty
+      printDebug "flowSocialListByMode counts" counts
+      pure     $ toSocialList counts ngrams'
 
 ---------------------------------------------------------------------------
 -- TODO: maybe use social groups too
@@ -121,23 +124,33 @@ countFilterList' :: RepoCmdM env err m
         -> 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 = Map.fromListWith (<>)
-              . List.concat
-              . (map toList)
-              . Map.toList
-
-toList :: (Text, NgramsRepoElement) -> [(Text, ListType)]
-toList (t, NgramsRepoElement _ lt root parent (MSet children)) =
-     List.zip terms (List.cycle [lt])
+toMapTextListType m = Map.fromListWith (<>)
+              $ List.concat
+              $ (map (toList m))
+              $ Map.toList m
+
+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
+    Nothing  -> CandidateTerm -- Should Not happen
+    Just ng' -> listOf m ng'
+
+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
+              -- <> maybe [] (\n -> [unNgramsTerm n]) root
+              -- <> maybe [] (\n -> [unNgramsTerm n]) parent
               <> (map unNgramsTerm $ Map.keys children)
+        lt'   = listOf m nre
 
 ---------------------------------------------------------------------------
 countList :: Text
@@ -162,12 +175,17 @@ findListsId :: (HasNodeError err, HasTreeError err)
             => NodeMode -> User -> Cmd err [NodeId]
 findListsId mode u = do
   r <- getRootId u
-  map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
-                 <$> findNodes' mode r
+  ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
+                       <$> findNodes' mode r
+  printDebug "findListsIds" ns
+  pure ns
+
+commonNodes:: [NodeType]
+commonNodes = [NodeFolder, NodeCorpus, NodeList]
 
 findNodes' :: HasTreeError err
           => NodeMode -> RootId
           -> Cmd err [DbTreeNode]
-findNodes' Private r = findNodes Private r [NodeFolderPrivate, NodeCorpus, NodeList]
-findNodes' Shared  r = findNodes Shared  r [NodeFolderShared , NodeCorpus, NodeList]
-findNodes' Public  r = findNodes Public  r [NodeFolderPublic , NodeCorpus, NodeList]
+findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
+findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
+findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes