[FEAT] Backend NLP French tested
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / SynchronicClustering.hs
index c503e0cca729aaceeff9e066c2ce7f4f5a4ae329..4b51572f04861d71cf49464c2e812a07bd7dbeeb 100644 (file)
@@ -11,19 +11,17 @@ Portability : POSIX
 
 module Gargantext.Core.Viz.Phylo.SynchronicClustering where
 
-import Gargantext.Prelude
-import Gargantext.Core.Viz.AdaptativePhylo
-import Gargantext.Core.Viz.Phylo.PhyloTools
-import Gargantext.Core.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
-import Gargantext.Core.Viz.Phylo.PhyloExport (processDynamics)
-
-import Data.List ((++), null, intersect, nub, concat, sort, sortOn, groupBy)
-import Data.Map  (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
-
+-- import Debug.Trace (trace)
 import Control.Lens hiding (Level)
+import Control.Monad (sequence)
 import Control.Parallel.Strategies (parList, rdeepseq, using)
--- import Debug.Trace (trace)
-
+import Data.List ((++), null, intersect, nub, concat, sort, sortOn, groupBy)
+import Data.Map  (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
+import Gargantext.Core.Viz.Phylo
+import Gargantext.Core.Viz.Phylo.PhyloExport (processDynamics)
+import Gargantext.Core.Viz.Phylo.PhyloTools
+import Gargantext.Core.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
+import Gargantext.Prelude
 import qualified Data.Map as Map
 
 
@@ -31,18 +29,24 @@ import qualified Data.Map as Map
 -- | New Level Maker | --
 -------------------------
 
-
 mergeGroups :: [Cooc] -> PhyloGroupId -> Map PhyloGroupId PhyloGroupId -> [PhyloGroup] -> PhyloGroup
 mergeGroups coocs id mapIds childs = 
     let ngrams = (sort . nub . concat) $ map _phylo_groupNgrams childs
-    in PhyloGroup (fst $ fst id) (snd $ fst id) (snd id)  ""
-                  (sum $ map _phylo_groupSupport childs)  ngrams
+    in PhyloGroup (fst $ fst id) (_phylo_groupPeriod' $ head' "mergeGroups" childs)
+                  (snd $ fst id) (snd id) ""
+                  (sum $ map _phylo_groupSupport childs) 
+                  (fmap sum $ sequence 
+                            $ map _phylo_groupWeight childs)
+                  (concat $ map _phylo_groupSources childs) 
+                  ngrams
                   (ngramsToCooc ngrams coocs) 
                   ((snd $ fst id),bId)
                   (mergeMeta bId childs) [] (map (\g -> (getGroupId g, 1)) childs)
                   (updatePointers $ concat $ map _phylo_groupPeriodParents childs)
                   (updatePointers $ concat $ map _phylo_groupPeriodChilds  childs)
                   (mergeAncestors $ concat $ map _phylo_groupAncestors childs)
+                  (updatePointers' $ concat $ map _phylo_groupPeriodMemoryParents childs)
+                  (updatePointers' $ concat $ map _phylo_groupPeriodMemoryChilds  childs)
     where
         --------------------
         bId :: [Int]
@@ -50,16 +54,18 @@ mergeGroups coocs id mapIds childs =
         --------------------
         updatePointers :: [Pointer] -> [Pointer]
         updatePointers pointers = map (\(pId,w) -> (mapIds ! pId,w)) pointers
+        updatePointers' :: [Pointer'] -> [Pointer']
+        updatePointers' pointers = map (\(pId,(t,w)) -> (mapIds ! pId,(t,w))) pointers
         --------------------
         mergeAncestors :: [Pointer] -> [Pointer]
         mergeAncestors pointers = Map.toList $ fromListWith max pointers
 
-
 addPhyloLevel :: Level -> Phylo -> Phylo
 addPhyloLevel lvl phylo = 
   over ( phylo_periods .  traverse ) 
        (\phyloPrd -> phyloPrd & phylo_periodLevels 
-                        %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) (PhyloLevel (phyloPrd ^. phylo_periodPeriod) lvl empty))) phylo
+                        %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) 
+                                   (PhyloLevel (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriod') lvl empty))) phylo
 
 
 toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
@@ -135,8 +141,12 @@ groupsToEdges prox sync nbDocs diago groups =
         toEdges sens edges = 
             case prox of
                 WeightedLogJaccard _ -> map (\(g,g') -> 
+                                                     ((g,g'), weightedLogJaccard' (sens) nbDocs diago
+                                                                  (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
+                WeightedLogSim _ -> map (\(g,g') -> 
                                                      ((g,g'), weightedLogJaccard' (1 / sens) nbDocs diago
                                                                   (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
+                
                 _ -> undefined  
 
 toParentId :: PhyloGroup -> PhyloGroupId