[FIX] SocialList working for others than Ngrams with Hierarchical groups

src/Gargantext/Core/Text/List.hs

@@ -16,12 +16,13 @@ module Gargantext.Core.Text.List
   where
 
 
-import Control.Lens ((^.), set, view, over)
+import Control.Lens ((^.), set, over)
 import Data.Map (Map)
 import Data.Maybe (catMaybes)
 import Data.Ord (Down(..))
 import Data.Set (Set)
 import Data.Text (Text)
+import Data.Tuple.Extra (both)
 import Gargantext.API.Ngrams.Types (NgramsElement)
 import Gargantext.API.Ngrams.Types (RepoCmdM)
 import Gargantext.Core.Text.List.Group
@@ -97,7 +98,7 @@ buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
 
   let
     groupParams     = GroupedTextParams groupIt (Set.size . snd) fst snd {-(size . fst)-}
-    groupedWithList = toGroupedText groupParams (view flc_scores socialLists') ngs'
+    groupedWithList = toGroupedTreeText groupParams socialLists' ngs'
 
 {-
   printDebug "groupedWithList"
@@ -111,9 +112,10 @@ buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
     (mapTerms, tailTerms') = Map.partition ((== Just MapTerm)  . viewListType) tailTerms
 
     listSize = mapListSize - (List.length mapTerms)
-    (mapTerms', candiTerms) = List.splitAt listSize
-                            $ List.sortOn (Down . viewScore)
-                            $ Map.elems tailTerms'
+    (mapTerms', candiTerms) = both Map.fromList
+                            $ List.splitAt listSize
+                            $ List.sortOn (Down . viewScore . snd)
+                            $ Map.toList tailTerms'
 
   pure $ Map.fromList [( nt,  (toNgramsElement stopTerms)
                            <> (toNgramsElement mapTerms )

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

@@ -18,13 +18,14 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Group
   where
 
-import Control.Lens (set)
+import Control.Lens (set, view)
 import Data.Set (Set)
 import Data.Map (Map)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Gargantext.Core.Types (ListType(..))
 import Gargantext.Database.Admin.Types.Node (NodeId)
-import Gargantext.Core.Text.List.Social.Prelude (FlowListScores(..))
+import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Core.Text.List.Group.Prelude
 import Gargantext.Core.Text.List.Group.WithStem
 import Gargantext.Core.Text.List.Group.WithScores
@@ -41,6 +42,28 @@ toGroupedText :: GroupedTextParams a b
 toGroupedText groupParams scores =
   (groupWithStem groupParams) . (groupWithScores scores)
 
+-- | TODO add group with stemming
+toGroupedTreeText :: GroupedTextParams a b
+              -> FlowCont Text FlowListScores
+              -> Map Text (Set NodeId)
+              -> Map Text (GroupedTreeScores (Set NodeId))
+toGroupedTreeText _groupParams flc scores = view flc_scores flow1
+    where
+      flow1 = groupWithScores' flc scoring
+      scoring t = fromMaybe Set.empty $ Map.lookup t scores
+
+{-
+      flow2 = case flc_cont flow1 == Set.empty of
+        True  -> view flc_scores flow1
+        False -> groupWithStem' groupParams flow1
+
+
+      groupWithStem' :: GroupedTextParams a b
+                     -> FlowCont Text (GroupedTreeScores (Set NodeId))
+                     -> FlowCont Text (GroupedTreeScores (Set NodeId))
+      groupWithStem' _groupParams = identity
+-}
+
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | TODO To be removed

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

@@ -31,11 +31,11 @@ import Gargantext.Prelude
 import qualified Data.Set  as Set
 import qualified Data.Map  as Map
 import qualified Data.List as List
+
 ------------------------------------------------------------------------
 -- | Group With Scores Main Types
 -- Tree of GroupedTextScores
 -- Target : type FlowCont Text GroupedTextScores'
-
 data GroupedTreeScores score =
   GroupedTreeScores { _gts'_listType :: !(Maybe ListType)
                     , _gts'_children :: !(Map Text (GroupedTreeScores score))
@@ -55,7 +55,7 @@ instance (Ord score, Monoid score)
 
 makeLenses 'GroupedTreeScores
 
----------------------------------------------
+------------------------------------------------------------------------
 class ViewListType a where
   viewListType :: a -> Maybe ListType
 
@@ -68,21 +68,52 @@ class Ord b => ViewScore a b | a -> b where
 class ToNgramsElement a where
   toNgramsElement :: a -> [NgramsElement]
 
----------------------------------------------
+------------------------------------------------------------------------
 instance ViewListType (GroupedTreeScores a) where
   viewListType = view gts'_listType
 
 instance SetListType (GroupedTreeScores a) where
   setListType = set gts'_listType
 
+instance SetListType (Map Text (GroupedTreeScores a)) where
+  setListType lt = Map.map (set gts'_listType lt)
+
 instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
   viewScore = Set.size . (view gts'_score)
 
-instance ToNgramsElement (Map Text (GroupedTreeScores (Set NodeId))) where
-  toNgramsElement = undefined
-
-
+instance ToNgramsElement (Map Text (GroupedTreeScores a)) where
+  toNgramsElement = List.concat . (map toNgramsElement) . Map.toList
 
+instance ToNgramsElement (Text, GroupedTreeScores a) where
+  toNgramsElement (t, gts) = parent : children
+    where
+      parent = mkNgramsElement (NgramsTerm t)
+                               (fromMaybe CandidateTerm $ viewListType gts)
+                               Nothing
+                               (mSetFromList $ map NgramsTerm
+                                             $ Map.keys
+                                             $ view gts'_children gts
+                               )
+      children = List.concat
+               $ map (childrenWith (NgramsTerm t) (NgramsTerm t) )
+               $ Map.toList
+               $ view gts'_children gts
+
+      childrenWith root parent' (t', gts') = parent'' : children'
+        where
+          parent''   = mkNgramsElement (NgramsTerm t')
+                                      (fromMaybe CandidateTerm $ viewListType gts')
+                                      (Just $ RootParent root parent')
+                                      (mSetFromList $ map NgramsTerm
+                                                    $ Map.keys
+                                                    $ view gts'_children gts'
+                                      )
+
+
+          children' = List.concat
+                    $ map (childrenWith root (NgramsTerm t') )
+                    $ Map.toList
+                    $ view gts'_children gts'