process the ancestors before the synchronic clustering

src/Gargantext/Core/Viz/Phylo/PhyloExample.hs

@@ -49,7 +49,7 @@ phyloDot = toPhyloExport phylo2
 --------------------------------------------------
 
 phylo2 :: Phylo
-phylo2 = synchronicClustering phylo1
+phylo2 = synchronicClustering $ toHorizon phylo1
 
 -----------------------------------------------
 -- | STEP 3 | -- Build the Level 1 of the Phylo

src/Gargantext/Core/Viz/Phylo/PhyloExport.hs

@@ -661,8 +661,8 @@ toPhyloExport phylo = exportToDot phylo
         groups = traceExportGroups
                $ processDynamics
                $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
-               $ tracePhyloInfo 
-               $ toHorizon phylo
+               $ tracePhyloInfo phylo
+               -- $ toHorizon phylo
 
 
 traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
@@ -670,9 +670,7 @@ traceExportBranches branches = trace ("\n"
   <> "-- | Export " <> show(length branches) <> " branches") branches
 
 tracePhyloAncestors :: [[PhyloGroup]] -> [[PhyloGroup]]
-tracePhyloAncestors groups = trace ("\n" 
-  <> "-- | Found " <> show(length $ concat $ map _phylo_groupAncestors $ concat groups) <> " ancestors"
-  ) groups
+tracePhyloAncestors groups = trace ( "-- | Found " <> show(length $ concat $ map _phylo_groupAncestors $ concat groups) <> " ancestors") groups
 
 tracePhyloInfo :: Phylo -> Phylo
 tracePhyloInfo phylo = trace ("\n"  <> "##########################" <> "\n\n" <> "-- | Phylo with β = "

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -24,6 +24,7 @@ import Gargantext.Core.Text.Context (TermList)
 import Gargantext.Core.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
 import Gargantext.Core.Viz.Graph.MaxClique (getMaxCliques)
 import Gargantext.Core.Viz.Graph.Distances (Distance(Conditional))
+import Gargantext.Core.Viz.Phylo.PhyloExport (toHorizon)
 
 import Control.DeepSeq (NFData)
 import Control.Parallel.Strategies (parList, rdeepseq, using)
@@ -53,9 +54,12 @@ toPhylo :: [Document] -> TermList -> Config -> Phylo
 toPhylo docs lst conf = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1))
                       $ traceToPhylo (phyloLevel conf) $
     if (phyloLevel conf) > 1
-      then foldl' (\phylo' _ -> synchronicClustering phylo') phylo1 [2..(phyloLevel conf)]
+      then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloLevel conf)]
       else phylo1 
     where
+        --------------------------------------
+        phyloAncestors :: Phylo
+        phyloAncestors = toHorizon phylo1
         --------------------------------------
         phylo1 :: Phylo
         phylo1 = toPhylo1 docs phyloBase

src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

@@ -464,7 +464,7 @@ toRelatedComponents nodes edges =
 
 traceSynchronyEnd :: Phylo -> Phylo
 traceSynchronyEnd phylo = 
-    trace ( "\n" <> "-- | End synchronic clustering at level " <> show (getLastLevel phylo) 
+    trace ( "-- | End synchronic clustering at level " <> show (getLastLevel phylo) 
                  <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
                  <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
                  <> "\n" ) phylo

src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs

@@ -42,7 +42,7 @@ mergeGroups coocs id mapIds childs =
                   (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)
     where
         --------------------
         bId :: [Int]
@@ -50,6 +50,9 @@ mergeGroups coocs id mapIds childs =
         --------------------
         updatePointers :: [Pointer] -> [Pointer]
         updatePointers pointers = map (\(pId,w) -> (mapIds ! pId,w)) pointers
+        --------------------
+        mergeAncestors :: [Pointer] -> [Pointer]
+        mergeAncestors pointers = Map.toList $ fromListWith max pointers
 
 
 addPhyloLevel :: Level -> Phylo -> Phylo
@@ -169,6 +172,17 @@ adjustClustering sync branches = case sync of
   ByProximityDistribution _ _ -> branches
 
 
+levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
+levelUpAncestors groups =
+  -- 1) create an associative map of (old,new) ids
+  let ids' = fromList $ map (\g -> (getGroupId g, fst $ head' "levelUpAncestors" ( g ^. phylo_groupLevelParents))) groups 
+   in map (\g -> 
+        let id' = ids' ! (getGroupId g)
+            ancestors  = g ^. phylo_groupAncestors
+            -- 2) level up the ancestors ids and filter the ones that will be merged
+            ancestors' = filter (\(id,_) -> id /= id') $ map (\(id,w) -> (ids' ! id,w)) ancestors 
+         in g & phylo_groupAncestors .~ ancestors'
+      ) groups
 
 synchronicClustering :: Phylo -> Phylo
 synchronicClustering phylo =
@@ -176,7 +190,7 @@ synchronicClustering phylo =
         sync = phyloSynchrony $ getConfig phylo
         docs = phylo ^. phylo_timeDocs
         diagos = map coocToDiago $ phylo ^. phylo_timeCooc
-        newBranches  = map (\branch -> reduceGroups prox sync docs diagos branch) 
+        newBranches  = map (\branch -> levelUpAncestors $ reduceGroups prox sync docs diagos branch) 
                      $ map processDynamics
                      $ adjustClustering sync
                      $ phyloToLastBranches