diff --git a/src/Gargantext/Core/Viz/Phylo/PhyloExample.hs b/src/Gargantext/Core/Viz/Phylo/PhyloExample.hs index 9ba633d4e52eb8076559fd543dad5b72f5e27287..850e1624a6798bb86051ddcf85ebaaf769faa008 100644 --- a/src/Gargantext/Core/Viz/Phylo/PhyloExample.hs +++ b/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 diff --git a/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs b/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs index 0f183003da28823e2ff62d617760afc0b45527d8..85bdac7733a60f72df0e62b9ddfb0d34dfc24c01 100644 --- a/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs +++ b/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 β = " diff --git a/src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs b/src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs index 1a2044737d324b5d27000c96a282276491efd2f6..73488c342088c02af0a5fa974ad27e0e3bd71bfd 100644 --- a/src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs +++ b/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 diff --git a/src/Gargantext/Core/Viz/Phylo/PhyloTools.hs b/src/Gargantext/Core/Viz/Phylo/PhyloTools.hs index b701f15488786cb9cee5e9a381867f765f6e4b03..383921455d78dd36ca236388c526629a4d70918d 100644 --- a/src/Gargantext/Core/Viz/Phylo/PhyloTools.hs +++ b/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 diff --git a/src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs b/src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs index c1818db3b467b7cb96acf084cb310c13237774af..c025359494873ef09e0d828fddb8a68b2eaa7e62 100644 --- a/src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs +++ b/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