[FIX] TFICF condition (better implemented definition)
[gargantext.git] / src / Gargantext / Viz / Phylo / LinkMaker.hs
index c3766be52b9ede9090f166420da8d74d3dd26e87..321460ae0bffb377e1340ebb9aadb6d696db5c42 100644 (file)
@@ -10,22 +10,19 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Gargantext.Viz.Phylo.LinkMaker
   where
 
 import Control.Parallel.Strategies
 import Control.Lens                 hiding (both, Level)
-import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, delete, intersect, nub, 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
-import Gargantext.Viz.Phylo.Metrics.Proximity
+import Gargantext.Viz.Phylo.Metrics
 import qualified Data.List  as List
 import qualified Data.Maybe as Maybe
 import qualified Data.Map as Map
@@ -129,15 +126,15 @@ phyloGroupMatching :: [PhyloPeriodId] -> PhyloGroup -> Phylo -> [Pointer]
 phyloGroupMatching periods g p = case pointers of
   Nothing  -> []
   Just pts -> head' "phyloGroupMatching"  
-            -- Keep only the best set of pointers grouped by proximity
+            -- Keep only the best set of pointers grouped by proximity
             $ groupBy (\pt pt' -> snd pt == snd pt') 
             $ reverse $ sortOn snd pts
-            -- Find the first time frame where at leats one pointer satisfies the proximity threshold
+            -- Find the first time frame where at leats one pointer satisfies the proximity threshold
   where
     --------------------------------------
     pointers :: Maybe [Pointer]
     pointers = find (not . null)
-             -- For each time frame, process the Proximity on relevant pairs of targeted groups
+             -- For each time frame, process the Proximity on relevant pairs of targeted groups
              $ scanl (\acc frame -> 
                  let pairs = makePairs frame g p
                  in  acc ++ ( filter (\(_,proxi) -> filterProximity proxi (getPhyloProximity p))
@@ -148,7 +145,7 @@ phyloGroupMatching periods g p = case pointers of
                                   if (t == t')
                                     then [(getGroupId t,proxi)]
                                     else [(getGroupId t,proxi),(getGroupId t',proxi)] ) pairs ) ) []
-             -- [[1900],[1900,1901],[1900,1901,1902],...] | length max => + 5 years
+             -- [[1900],[1900,1901],[1900,1901,1902],...] | length max => + 5 years
              $ inits periods
     --------------------------------------           
 
@@ -221,16 +218,69 @@ 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
   (\gs -> if ((not . null) gs) && (elem lvl $ map getGroupLevel gs)  
               then 
-                let groups  = map (\g -> g & phylo_groupPeriodParents .~ (trackPointers (reduceGroups g lvlGroups) 
-                                                                                      $ g ^. phylo_groupPeriodParents)
-                                           & phylo_groupPeriodChilds  .~ (trackPointers (reduceGroups g lvlGroups)
-                                                                                      $ g ^. phylo_groupPeriodChilds )) gs
+                let groups  = map (\g -> let m = reduceGroups g lvlGroups
+                                         in  g & phylo_groupPeriodParents .~ (trackPointers m $ g ^. phylo_groupPeriodParents)
+                                               & phylo_groupPeriodChilds  .~ (trackPointers m $ g ^. phylo_groupPeriodChilds )) gs
                     groups' = groups `using` parList rdeepseq
                     in groups'
               else gs