add a recursive way to transpose links from level 1 to level 2

src/Gargantext/Viz/Phylo.hs

@@ -80,8 +80,8 @@ data Phylo =
            , _phylo_foundations :: PhyloFoundations
            , _phylo_periods     :: [PhyloPeriod]
            , _phylo_docsByYears :: Map Date Double
-           , _phylo_cooc        :: Map Date (Map (Int,Int) Double)
-           , _phylo_fis         :: Map (Date,Date) [PhyloFis]
+           , _phylo_cooc        :: !(Map Date (Map (Int,Int) Double))
+           , _phylo_fis         :: !(Map (Date,Date) [PhyloFis])
            , _phylo_param       :: PhyloParam
            }
            deriving (Generic, Show, Eq)
@@ -156,7 +156,7 @@ data PhyloGroup =
                 , _phylo_groupNgramsMeta    :: Map Text [Double]
                 , _phylo_groupMeta          :: Map Text Double
                 , _phylo_groupBranchId      :: Maybe PhyloBranchId
-                , _phylo_groupCooc          :: Map (Int,Int) Double
+                , _phylo_groupCooc          :: !(Map (Int,Int) Double)
 
                 , _phylo_groupPeriodParents :: [Pointer]
                 , _phylo_groupPeriodChilds  :: [Pointer]

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -22,9 +22,10 @@ module Gargantext.Viz.Phylo.LevelMaker
 import Control.Parallel.Strategies
 import Control.Lens                 hiding (both, Level)
 import Data.List                    ((++), sort, concat, nub, zip, last, null)
-import Data.Map                     (Map, (!), empty, singleton)
+import Data.Map                     (Map, (!), empty, singleton, size)
 import Data.Text (Text)
 import Data.Tuple.Extra
+import Data.Vector (Vector)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Metrics
@@ -83,7 +84,7 @@ instance PhyloLevelMaker PhyloFis
     --------------------------------------
     -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
     toPhyloGroups lvl (d,d') l _ p =
-      let groups  = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis p) $ zip [1..] l
+      let groups  = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis (getPhyloCooc p) (getFoundationsRoots p)) $ zip [1..] l
           groups' = groups `using` parList rdeepseq
       in  groups' 
     --------------------------------------
@@ -111,7 +112,7 @@ addPhyloLevel' lvl m p = alterPhyloPeriods
                                     in  over (phylo_periodLevels)
                                         (\phyloLevels ->
                                             let groups = toPhyloGroups lvl pId (m ! pId) m p
-                                            in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
+                                            in trace (show (length groups) <> " groups for " <> show (pId) ) $ phyloLevels ++ [PhyloLevel (pId, lvl) groups]
                                         ) period) p
 
 
@@ -121,8 +122,8 @@ addPhyloLevel' lvl m p = alterPhyloPeriods
 
 
 -- | To transform a Clique into a PhyloGroup
-cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> PhyloFis -> Phylo -> PhyloGroup
-cliqueToGroup prd lvl idx lbl fis p = PhyloGroup ((prd, lvl), idx) lbl ngrams 
+cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> PhyloFis -> Map Date (Map (Int,Int) Double) -> Vector Ngrams -> PhyloGroup
+cliqueToGroup prd lvl idx lbl fis cooc' root = PhyloGroup ((prd, lvl), idx) lbl ngrams 
     (getNgramsMeta cooc ngrams)
     -- empty
     (singleton "support" (fromIntegral $ getSupport fis)) 
@@ -132,10 +133,10 @@ cliqueToGroup prd lvl idx lbl fis p = PhyloGroup ((prd, lvl), idx) lbl ngrams
       where
         --------------------------------------
         cooc :: Map (Int, Int) Double
-        cooc = getMiniCooc (listToFullCombi ngrams) (periodsToYears [prd]) (getPhyloCooc p)
+        cooc = getMiniCooc (listToFullCombi ngrams) (periodsToYears [prd]) cooc'
         --------------------------------------
         ngrams :: [Int]
-        ngrams = sort $ map (\x -> getIdxInRoots x p)
+        ngrams = sort $ map (\x -> getIdxInRoots' x root)
                       $ Set.toList
                       $ getClique fis
         --------------------------------------
@@ -210,7 +211,11 @@ toNthLevel lvlMax prox clus p
   | otherwise     = toNthLevel lvlMax prox clus
                   $ traceBranches (lvl + 1)
                   $ setPhyloBranches (lvl + 1)
-                  $ transposePeriodLinks (lvl + 1)
+                  -- $ transposePeriodLinks (lvl + 1)
+                  $ traceTranspose (lvl + 1) Descendant
+                  $ transposeLinks (lvl + 1) Descendant
+                  $ traceTranspose (lvl + 1) Ascendant
+                  $ transposeLinks (lvl + 1) Ascendant
                   $ tracePhyloN (lvl + 1)
                   $ setLevelLinks (lvl, lvl + 1)
                   $ addPhyloLevel (lvl + 1)
@@ -238,7 +243,8 @@ toPhylo1 clus prox d p = case clus of
                        $ interTempoMatching Ascendant 1 prox
                        $ tracePhyloN 1
                        -- $ setLevelLinks (0,1)
-                       $ addPhyloLevel 1 (getPhyloFis phyloFis) phyloFis
+                       $ addPhyloLevel 1 (getPhyloFis phyloFis)
+                       $ trace (show (size $ getPhyloFis phyloFis) <> " Fis created") $ phyloFis
     where
       --------------------------------------
       phyloFis :: Phylo
@@ -279,6 +285,9 @@ tracePhyloN :: Level -> Phylo -> Phylo
 tracePhyloN lvl p = trace ("\n---------------\n--| Phylo " <> show (lvl) <> " |--\n---------------\n\n"
                       <> show (length $ getGroupsWithLevel lvl p) <> " groups created \n") p
 
+traceTranspose :: Level -> Filiation -> Phylo -> Phylo
+traceTranspose lvl fil p = trace ("----\n Transpose " <> show (fil) <> " links for " <> show (length $ getGroupsWithLevel lvl p) <> " groups\n") p
+
 
 tracePhyloBase :: Phylo -> Phylo
 tracePhyloBase p = trace ( "\n-------------\n--| Phylo |--\n-------------\n\n" 

src/Gargantext/Viz/Phylo/LinkMaker.hs

@@ -19,9 +19,9 @@ module Gargantext.Viz.Phylo.LinkMaker
 
 import Control.Parallel.Strategies
 import Control.Lens                 hiding (both, Level)
-import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, delete, intersect, groupBy, union, inits, scanl, find)
+import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, delete, intersect, elemIndex, groupBy, union, inits, scanl, find)
 import Data.Tuple.Extra
-import Data.Map                     (Map,(!),fromListWith,elems,restrictKeys,unionWith,member)
+import Data.Map                     (Map, (!), fromListWith, elems, restrictKeys, filterWithKey, keys, unionWith, unions, intersectionWith, member, fromList)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
@@ -222,6 +222,62 @@ interTempoMatching fil lvl _ p = updateGroups fil lvl (Map.fromList pointers) p
 ------------------------------------------------------------------------
 -- | Make links from Period to Period after level 1
 
+
+listToTuple :: (a -> b) -> [a] -> [(b,a)]
+listToTuple f l = map (\x -> (f x, x)) l
+
+
+groupsToMaps :: Ord b => (PhyloGroup -> b) -> [PhyloGroup] -> [Map PhyloGroupId PhyloGroup]
+groupsToMaps f gs = map (\gs' -> fromList $ listToTuple getGroupId gs')
+                  $ groupBy ((==) `on` f)
+                  $ sortOn f gs
+
+
+phyloToPeriodMaps :: Level -> Filiation -> Phylo -> [Map PhyloGroupId PhyloGroup]
+phyloToPeriodMaps lvl fil p =
+  let prdMap = groupsToMaps (fst . getGroupPeriod) (getGroupsWithLevel lvl p)
+  in case fil of  
+    Ascendant  -> reverse prdMap
+    Descendant -> prdMap
+    _          -> panic ("[ERR][Viz.Phylo.LinkMaker.phyloToPeriodMaps] Wrong type of filiation")
+
+
+trackPointersRec :: Filiation -> Map PhyloGroupId PhyloGroup -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
+trackPointersRec fil m gs res =
+  if (null gs) then res
+  else if (Map.null m) then res ++ gs
+  else 
+    let g = head' "track" gs
+        pts  = Map.fromList $ getGroupPointers PeriodEdge fil g
+        pts' = Map.toList $ fromListWith (\w w' -> max w w') $ concat $ elems
+             $ intersectionWith (\w g' -> map (\(id,_w') -> (id, w))
+                                        $ getGroupPointers LevelEdge Ascendant g') pts m
+        res' = res ++ [case fil of 
+                        Ascendant  -> g & phylo_groupPeriodParents .~ pts' 
+                        Descendant -> g & phylo_groupPeriodChilds  .~ pts'
+                        _          -> panic ("[ERR][Viz.Phylo.LinkMaker.transposeLinks] Wrong type of filiation")]
+    in trackPointersRec fil (filterWithKey (\k _ -> not $ elem k (keys pts)) m) (tail' "track" gs) res'
+
+
+
+transposeLinks :: Level -> Filiation -> Phylo -> Phylo
+transposeLinks lvl fil p = 
+  let prdMap = zip (phyloToPeriodMaps (lvl - 1) fil p) (phyloToPeriodMaps lvl fil p)
+      transposed =  map (\(gs,gs') -> 
+                            let idx  = fromJust $ elemIndex (gs,gs') prdMap
+                                next = take (getPhyloMatchingFrame p) $ snd $ splitAt (idx + 1) prdMap
+                                groups = trackPointersRec fil (unions $ map fst next) (elems gs') []
+                            in  (getGroupPeriod $ head' "transpose" groups ,groups)
+                         ) prdMap
+      transposed' = Map.fromList $ (transposed `using` parList rdeepseq)
+  in alterPhyloGroups
+      (\gs -> if ((not . null) gs) && (lvl == (getGroupLevel $ head' "transpose" gs))
+              then transposed' ! (getGroupPeriod $ head' "transpose" gs)
+              else gs
+      ) p 
+
+
+
 -- | Transpose the parent/child pointers from one level to another
 transposePeriodLinks :: Level -> Phylo -> Phylo
 transposePeriodLinks lvl p = alterPhyloGroups

src/Gargantext/Viz/Phylo/Tools.hs

@@ -241,6 +241,11 @@ getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
     Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
     Just idx -> idx
 
+getIdxInRoots' :: Ngrams -> Vector Ngrams -> Int
+getIdxInRoots' n root = case (elemIndex n root) of
+    Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
+    Just idx -> idx    
+
 getIdxInVector :: Ngrams -> Vector Ngrams -> Int
 getIdxInVector n ns = case (elemIndex n ns) of
   Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInVector] Ngrams not in foundationsRoots: " <> cs n