diff --git a/src/Gargantext/Core/Text/List.hs b/src/Gargantext/Core/Text/List.hs
index f87fdd7a3e4e1d31ac88012550110a757678fe1f..31a1f6e7088424f49a267b8881b6dd1b379a0f6b 100644
--- a/src/Gargantext/Core/Text/List.hs
+++ b/src/Gargantext/Core/Text/List.hs
@@ -144,7 +144,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
socialLists' :: FlowCont Text FlowListScores
<- flowSocialList' MySelfFirst user nt ( FlowCont Map.empty
$ Map.fromList
- $ List.zip (Map.keys allTerms)
+ $ List.zip (Map.keys allTerms)
(List.cycle [mempty])
)
let groupedWithList = toGroupedTree groupParams socialLists' allTerms
@@ -183,9 +183,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
let
groupedTreeScores_SetNodeId :: Map Text (GroupedTreeScores (Set NodeId))
- groupedTreeScores_SetNodeId = undefined
- -- setScoresWith (\_ _ -> mempty) (groupedMonoHead <> groupedMultHead)
- -- groupedTreeScores_SetNodeId = setScoresWith ((fromMaybe mempty) . ((flip Map.lookup) mapTextDocIds)) (groupedMonoHead <> groupedMultHead)
+ groupedTreeScores_SetNodeId = setScoresWithMap mapTextDocIds (groupedMonoHead <> groupedMultHead)
-- | Coocurrences computation
--, t1 >= t2 -- permute byAxis diag -- since matrix symmetric
@@ -207,16 +205,13 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
$ scored' mapCooc
let
- groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Double))
- groupedTreeScores_SpeGen = undefined
- -- setScoresWith (\k v -> set gts'_score (Scored "" 0 0) v) (groupedMonoHead <> groupedMultHead)
- -- groupedTreeScores_SpeGen = setScoresWith (\k v -> set gts'_score (fromMaybe (Scored "" 0 0) $ Map.lookup k (mapScores identity)) v) (groupedMonoHead <> groupedMultHead)
+ groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Text))
+ groupedTreeScores_SpeGen = setScoresWithMap (mapScores identity) (groupedMonoHead <> groupedMultHead)
let
-- sort / partition / split
-- filter mono/multi again
(monoScored, multScored) = Map.partitionWithKey (\t _v -> size t < 2) groupedTreeScores_SpeGen
- -- (monoScored, multScored) = List.partition (\g -> _gt_size g < 2) groupsWithScores
-- filter with max score
partitionWithMaxScore = Map.partition (\g -> (view scored_genInc $ view gts'_score g)
@@ -236,6 +231,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
splitAt' n' = (both (Map.fromList)) . (List.splitAt (round $ n' * listSizeLocal))
sortOn f = (List.sortOn (Down . (view (gts'_score . f)) . snd)) . Map.toList
+
monoInc_size = splitAt' $ monoSize * inclSize / 2
(monoScoredInclHead, monoScoredInclTail) = monoInc_size $ (sortOn scored_genInc) monoScoredIncl
(monoScoredExclHead, monoScoredExclTail) = monoInc_size $ (sortOn scored_speExc) monoScoredExcl
@@ -244,20 +240,23 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
(multScoredInclHead, multScoredInclTail) = multExc_size $ (sortOn scored_genInc) multScoredIncl
(multScoredExclHead, multScoredExclTail) = multExc_size $ (sortOn scored_speExc) multScoredExcl
+
+------------------------------------------------------------
+
-- Final Step building the Typed list
termListHead = maps <> cands
where
maps = setListType (Just MapTerm)
- $ monoScoredInclHead
- <> monoScoredExclHead
- <> multScoredInclHead
- <> multScoredExclHead
+ $ monoScoredInclHead
+ <> monoScoredExclHead
+ <> multScoredInclHead
+ <> multScoredExclHead
cands = setListType (Just CandidateTerm)
- $ monoScoredInclTail
- <> monoScoredExclTail
- <> multScoredInclTail
- <> multScoredExclTail
+ $ monoScoredInclTail
+ <> monoScoredExclTail
+ <> multScoredInclTail
+ <> multScoredExclTail
termListTail = (setListType (Just CandidateTerm)) (groupedMonoTail <> groupedMultTail)
diff --git a/src/Gargantext/Core/Text/List/Group.hs b/src/Gargantext/Core/Text/List/Group.hs
index aaca870400cbf3f239b05983ead55cb2fb57b96d..728c33f1f9a4f099c05f6a00ac27f5bb087fd663 100644
--- a/src/Gargantext/Core/Text/List/Group.hs
+++ b/src/Gargantext/Core/Text/List/Group.hs
@@ -53,25 +53,32 @@ toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
False -> groupWithStem' groupParams flow1
+
+------------------------------------------------------------------------
+setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
+ -> Map Text (GroupedTreeScores a)
+ -> Map Text (GroupedTreeScores b)
+setScoresWithMap m = setScoresWith (score m)
+ where
+ score m t = case Map.lookup t m of
+ Nothing -> mempty
+ Just r -> r
+
setScoresWith :: (Ord a, Ord b)
- => (Text -> (GroupedTreeScores a) -> (GroupedTreeScores b))
+ => (Text -> b)
-> Map Text (GroupedTreeScores a)
-> Map Text (GroupedTreeScores b)
-setScoresWith = Map.mapWithKey
-
{-
-gts :: (Text -> b) -> Text -> GroupedTreeScores a -> GroupedTreeScores b
-gts f t g = over gts'_children set gts'_score (f t) g
+-- | This Type level lenses solution does not work
+setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
+ $ set gts'_score (f k) v
+ )
-}
+setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score = f k
+ , _gts'_children = setScoresWith f
+ $ view gts'_children v
+ }
+ )
-{-
-Map.foldlWithKey (\k v ->
- {- over gts'_children (setScoresWith fun)
- $ over gts'_score (fun k)
- -}
- set gts'_score Set.empty -- (fun k)
- v
- ) mempty m
--}
------------------------------------------------------------------------
diff --git a/src/Gargantext/Core/Text/Metrics.hs b/src/Gargantext/Core/Text/Metrics.hs
index b9200cd4dbd83b7feee400c47cbf0f815c6b6f12..868c46897941e859f6236d4d1ddfb5e45815f936 100644
--- a/src/Gargantext/Core/Text/Metrics.hs
+++ b/src/Gargantext/Core/Text/Metrics.hs
@@ -20,6 +20,8 @@ module Gargantext.Core.Text.Metrics
--import Math.KMeans (kmeans, euclidSq, elements)
import Control.Lens (makeLenses)
import Data.Map (Map)
+import Data.Semigroup (Semigroup, (<>))
+import Data.Monoid (Monoid, mempty)
import Gargantext.Prelude
import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
import Gargantext.Core.Viz.Graph.Index
@@ -49,6 +51,15 @@ data Scored ts = Scored
, _scored_speExc :: !SpecificityExclusion
} deriving (Show, Eq, Ord)
+instance Monoid a => Monoid (Scored a) where
+ mempty = Scored mempty mempty mempty
+
+instance Semigroup a => Semigroup (Scored a) where
+ (<>) (Scored a b c )
+ (Scored _a' b' c')
+ = Scored (a {-<> a'-})
+ (b <> b')
+ (c <> c')
localMetrics' :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double)
localMetrics' m = Map.fromList $ zipWith (\(_,t) (inc,spe) -> (t, Vec.fromList [inc,spe]))
diff --git a/src/Gargantext/Prelude.hs b/src/Gargantext/Prelude.hs
index d58fa26ab75134fb1204c41b4b592e908a367c3c..408e6e30b38a5884e1d2a8fa692e1a180489a3c8 100644
--- a/src/Gargantext/Prelude.hs
+++ b/src/Gargantext/Prelude.hs
@@ -316,10 +316,23 @@ foldM' f z (x:xs) = do
z' `seq` foldM' f z' xs
-----------------------------------------------------------------------
-
+-- | Instance for basic numerals
+-- See the difference between Double and (Int Or Integer)
instance Monoid Double where
- mempty = 0
+ mempty = 1
instance Semigroup Double where
(<>) a b = a * b
+-----------
+instance Monoid Int where
+ mempty = 0
+
+instance Semigroup Int where
+ (<>) a b = a + b
+----
+instance Monoid Integer where
+ mempty = 0
+
+instance Semigroup Integer where
+ (<>) a b = a + b