horizon & ancestor ok

src/Gargantext/Viz/AdaptativePhylo.hs

@@ -354,6 +354,16 @@ data PhyloClique = PhyloClique
   } deriving (Generic,NFData,Show,Eq)
 
 
+------------------------
+-- | Phylo Ancestor | --
+------------------------
+
+data PhyloAncestor = PhyloAncestor
+  { _phyloAncestor_id   :: Int
+  , _phyloAncestor_ngrams :: [Int]
+  , _phyloAncestor_groups :: [PhyloGroupId]
+  } deriving (Generic,NFData,Show,Eq)
+
 ----------------
 -- | Export | --
 ----------------
@@ -396,6 +406,7 @@ data PhyloExport =
       PhyloExport
       { _export_groups    :: [PhyloGroup]
       , _export_branches  :: [PhyloBranch]
+      , _export_ancestors :: [PhyloAncestor]
       } deriving (Generic, Show)
 
 ----------------

src/Gargantext/Viz/Phylo/PhyloExport.hs

@@ -35,6 +35,7 @@ import Data.Text.Lazy (fromStrict, pack, unpack)
 import System.FilePath
 import Debug.Trace (trace)
 
+import qualified Data.Map as Map
 import qualified Data.Text as Text
 import qualified Data.Vector as Vector
 import qualified Data.Text.Lazy as Lazy
@@ -476,6 +477,27 @@ processDynamics groups =
                                             $ (g ^. phylo_groupNgrams))) [] groups
 
 
+-----------------
+-- | horizon | --
+-----------------
+
+horizonToAncestors :: Double -> Phylo -> [PhyloAncestor]
+horizonToAncestors delta phylo = 
+  let horizon = Map.toList $ Map.filter (\v -> v > delta) $ phylo ^. phylo_horizon
+      ct0 = fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevelPeriods 1 (take 1 (getPeriodIds phylo)) phylo
+      aDelta = toRelatedComponents
+                  (elems ct0)
+                  (map (\((g,g'),v) -> ((ct0 ! g,ct0 ! g'),v)) horizon)
+   in map (\(id,groups) -> toAncestor id groups) $ zip [1..] aDelta
+  where 
+    -- | note : possible bug if we sync clus more than once
+    -- | horizon is calculated at level 1, ancestors have to be related to the last level
+    toAncestor :: Int -> [PhyloGroup] -> PhyloAncestor
+    toAncestor id groups = PhyloAncestor id 
+                              (foldl' (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups) 
+                              (concat $ map (\g -> map fst (g ^. phylo_groupLevelParents)) groups) 
+
+
 ---------------------
 -- | phyloExport | --
 ---------------------   
@@ -488,7 +510,7 @@ toPhyloExport phylo = exportToDot phylo
                     $ processMetrics  export           
     where
         export :: PhyloExport
-        export = PhyloExport groups branches      
+        export = PhyloExport groups branches (horizonToAncestors 0 phylo)     
         --------------------------------------
         branches :: [PhyloBranch]
         branches = map (\g -> 

src/Gargantext/Viz/Phylo/PhyloTools.hs

@@ -398,6 +398,12 @@ relatedComponents graph = foldl' (\acc groups ->
         let acc' = partition (\groups' -> disjoint (Set.fromList groups') (Set.fromList groups)) acc
          in (fst acc') ++ [nub $ concat $ (snd acc') ++ [groups]]) [] graph
 
+toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
+toRelatedComponents nodes edges = 
+  let ref = fromList $ map (\g -> (getGroupId g, g)) nodes
+      clusters = relatedComponents $ ((map (\((g,g'),_) -> [getGroupId g, getGroupId g']) edges) ++ (map (\g -> [getGroupId g]) nodes)) 
+   in map (\cluster -> map (\gId -> ref ! gId) cluster) clusters 
+
 
 traceSynchronyEnd :: Phylo -> Phylo
 traceSynchronyEnd phylo = 

src/Gargantext/Viz/Phylo/SynchronicClustering.hs

@@ -22,7 +22,7 @@ import Gargantext.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago,
 import Gargantext.Viz.Phylo.PhyloExport (processDynamics)
 
 import Data.List ((++), null, intersect, nub, concat, sort, sortOn, all, groupBy, group, maximum)
-import Data.Map  (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member,keys)
+import Data.Map  (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
 import Data.Text (Text)
 
 import Control.Lens hiding (Level)
@@ -177,14 +177,6 @@ groupsToEdges prox sync nbDocs diago groups =
                                                                   (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
                 _ -> undefined  
 
-
-
-toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
-toRelatedComponents nodes edges = 
-  let ref = fromList $ map (\g -> (getGroupId g, g)) nodes
-      clusters = relatedComponents $ ((map (\((g,g'),_) -> [getGroupId g, getGroupId g']) edges) ++ (map (\g -> [getGroupId g]) nodes)) 
-   in map (\cluster -> map (\gId -> ref ! gId) cluster) clusters 
-
 toParentId :: PhyloGroup -> PhyloGroupId
 toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupLevel + 1), child ^. phylo_groupIndex) 
 
@@ -234,20 +226,6 @@ synchronicClustering phylo =
      in toNextLevel' phylo $ concat newBranches'
 
 
------------------
--- | horizon | --
------------------
-
-horizonToAncestors :: Double -> Phylo -> Map [PhyloGroupId] [Int]
-horizonToAncestors thr phylo = 
-  let horizon = Map.filter (\v -> v >= thr) $ phylo ^. phylo_horizon
-      groups = fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevelPeriods 1 (take 1 (getPeriodIds phylo)) phylo
-      graph = toRelatedComponents 
-                    (elems groups)
-                    (map (\((k,k'),v) -> ((groups ! k, groups ! k'),v)) $ Map.toList horizon)
-   -- in fromList $ map (\ancestors -> (map getGroupId ancestors, unionWith (++) $ map _phylo_groupNgrams ancestors)) graph
-   in undefined
-
 -- synchronicDistance :: Phylo -> Level -> String
 -- synchronicDistance phylo lvl = 
 --     foldl' (\acc branch ->