-}
-{-# 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
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))
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
--------------------------------------
------------------------------------------------------------------------
-- | 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