[REFACT] WIP compiling, needs setGroupedTreeWith specific scores.

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

@@ -22,7 +22,7 @@ import Control.Lens (set, view)
 import Data.Set (Set)
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
-import Data.Monoid (mempty)
+import Data.Monoid (Monoid, mempty)
 import Data.Text (Text)
 import Gargantext.Core.Types (ListType(..))
 import Gargantext.Database.Admin.Types.Node (NodeId)
@@ -37,44 +37,26 @@ import qualified Data.List as List
 
 ------------------------------------------------------------------------
 -- | TODO add group with stemming
+toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
+              => GroupParams
+              -> FlowCont Text FlowListScores
+              -> Map Text a
+             -- -> Map Text (GroupedTreeScores (Set NodeId))
+              -> FlowCont Text (GroupedTreeScores a)
+toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
+    where
+      flow1     = groupWithScores' flc scoring
+      scoring t = fromMaybe mempty $ Map.lookup t scores
 
-class ToGroupedTree a b | a -> b where
-  toGroupedTree :: GroupParams
-                -> FlowCont Text FlowListScores
-                -> a
-                -> FlowCont Text (GroupedTreeScores b)
+      flow2 = case (view flc_cont flow1) == Map.empty of
+        True  -> flow1
+        False -> groupWithStem' groupParams flow1
 
-instance ToGroupedTree (Map Text (Set NodeId)) (Set NodeId)
-  where
-    toGroupedTree :: GroupParams
-                  -> FlowCont Text FlowListScores
-                  -> Map Text (Set NodeId)
-                 -- -> Map Text (GroupedTreeScores (Set NodeId))
-                  -> FlowCont Text (GroupedTreeScores (Set NodeId))
-    toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
-        where
-          flow1     = groupWithScores' flc scoring
-          scoring t = fromMaybe Set.empty $ Map.lookup t scores
-
-          flow2 = case (view flc_cont flow1) == Map.empty of
-            True  -> flow1
-            False -> groupWithStem' groupParams flow1
-
-instance ToGroupedTree (Map Text Double) Double
-  where
-    toGroupedTree :: GroupParams
-                  -> FlowCont Text FlowListScores
-                  -> Map Text Double
-                 -- -> Map Text (GroupedTreeScores (Set NodeId))
-                  -> FlowCont Text (GroupedTreeScores Double)
-    toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
-        where
-          flow1     = groupWithScores' flc scoring
-          scoring t = fromMaybe mempty $ Map.lookup t scores
+setScoresWith :: Map Text a
+              -> Map Text (GroupedTreeScores b)
+              -> Map Text (GroupedTreeScores a)
+setScoresWith = undefined
 
-          flow2 = case (view flc_cont flow1) == Map.empty of
-            True  -> flow1
-            False -> groupWithStem' groupParams flow1
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------

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

@@ -16,7 +16,7 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Group.Prelude
   where
 
-import Control.Lens (makeLenses, view, set)
+import Control.Lens (makeLenses, view, set, over)
 import Data.Monoid
 import Data.Semigroup
 import Data.Set (Set)
@@ -25,6 +25,7 @@ import Data.Maybe (fromMaybe)
 import Data.Map (Map)
 import Gargantext.Core.Types (ListType(..))
 import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_genInc, normalizeGlobal, normalizeLocal)
 import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
 import Gargantext.Prelude
 import qualified Data.Set  as Set
@@ -41,7 +42,7 @@ data GroupedTreeScores score =
                     , _gts'_score    :: !score
                     } deriving (Show, Ord, Eq)
 
-instance (Semigroup a, Ord a) => Semigroup (GroupedTreeScores a) where
+instance (Semigroup a) => Semigroup (GroupedTreeScores a) where
   (<>) (GroupedTreeScores  l1 s1 c1)
        (GroupedTreeScores  l2 s2 c2)
       = GroupedTreeScores (l1 <> l2)
@@ -62,12 +63,14 @@ class ViewListType a where
 class SetListType a where
   setListType :: Maybe ListType -> a -> a
 
+------
 class Ord b => ViewScore a b | a -> b where
   viewScore :: a -> b
 
 class ViewScores a b | a -> b where
   viewScores :: a -> b
 
+--------
 class ToNgramsElement a where
   toNgramsElement :: a -> [NgramsElement]
 
@@ -80,12 +83,24 @@ instance ViewListType (GroupedTreeScores a) where
   viewListType = view gts'_listType
 
 instance SetListType (GroupedTreeScores a) where
-  setListType = set gts'_listType
+  setListType lt g = over gts'_children (setListType lt)
+                $ set gts'_listType lt g
 
 instance SetListType (Map Text (GroupedTreeScores a)) where
   setListType lt = Map.map (set gts'_listType lt)
 
                             ------
+
+instance ViewScore (GroupedTreeScores Double) Double where
+  viewScore = viewScores
+
+instance ViewScores (GroupedTreeScores Double) Double where
+  viewScores g = sum $ parent : children
+    where
+      parent   = view gts'_score g
+      children = map viewScores $ Map.elems $ view gts'_children g
+
+
 instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
   viewScore = Set.size . viewScores
 
@@ -95,6 +110,10 @@ instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where
       parent   = view gts'_score g
       children = map viewScores $ Map.elems $ view gts'_children g
 
+
+instance ViewScore (GroupedTreeScores (Scored Text)) Double where
+  viewScore = view (gts'_score . scored_genInc)
+
                             ------
 instance HasTerms (Map Text (GroupedTreeScores a)) where
   hasTerms = Set.unions . (map hasTerms) . Map.toList
@@ -112,6 +131,7 @@ instance HasTerms (Text, GroupedTreeScores a) where
 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

src/Gargantext/Core/Text/Metrics.hs

@@ -11,13 +11,14 @@ Mainly reexport functions in @Data.Text.Metrics@
 
 -}
 
-{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.Text.Metrics
   where
 
 --import Data.Array.Accelerate ((:.)(..), Z(..))
 --import Math.KMeans (kmeans, euclidSq, elements)
+import Control.Lens (makeLenses)
 import Data.Map (Map)
 import Gargantext.Prelude
 import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
@@ -46,7 +47,7 @@ data Scored ts = Scored
   { _scored_terms  :: !ts
   , _scored_genInc :: !GenericityInclusion
   , _scored_speExc :: !SpecificityExclusion
-  } deriving (Show)
+  } deriving (Show, Eq, Ord)
 
 
 localMetrics' :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double)
@@ -96,5 +97,5 @@ normalizeLocal (Scored t s1 s2) = Scored t (log' 5 s1) (log' 2 s2)
 
 
 
-
-
+-- | Type Instances
+makeLenses 'Scored