2 Module : Gargantext.Viz.Phylo.Tools
3 Description : Phylomemy Tools to build/manage it
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
13 {-# LANGUAGE NoImplicitPrelude #-}
14 {-# LANGUAGE FlexibleContexts #-}
15 {-# LANGUAGE OverloadedStrings #-}
17 module Gargantext.Viz.Phylo.Tools
20 import Control.Lens hiding (both, Level)
21 import Data.List (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub)
22 import Data.Map (Map, mapKeys, member)
24 import Data.Text (Text)
25 import Data.Tuple.Extra
26 import Data.Vector (Vector,elemIndex)
27 import Gargantext.Prelude hiding (head)
28 import Gargantext.Viz.Phylo
30 import qualified Data.List as List
31 import qualified Data.Map as Map
32 import qualified Data.Set as Set
35 ------------------------------------------------------------------------
39 -- | To add a new PhyloGroupId to a PhyloBranch
40 addGroupIdToBranch :: PhyloGroupId -> PhyloBranch -> PhyloBranch
41 addGroupIdToBranch id b = over (phylo_branchGroups) (++ [id]) b
44 -- | To add a PhyloLevel at the end of a list of PhyloLevels
45 addPhyloLevel :: PhyloLevel -> [PhyloLevel] -> [PhyloLevel]
46 addPhyloLevel lvl l = l ++ [lvl]
49 -- | To alter each list of PhyloGroups following a given function
50 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
51 alterPhyloGroups f p = over ( phylo_periods
59 -- | To alter each PhyloPeriod of a Phylo following a given function
60 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
61 alterPhyloPeriods f p = over ( phylo_periods
65 -- | To alter the list of PhyloBranches of a Phylo
66 alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
67 alterPhyloBranches f p = over ( phylo_branches ) f p
70 -- | To alter a list of PhyloLevels following a given function
71 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
72 alterPhyloLevels f p = over ( phylo_periods
74 . phylo_periodLevels) f p
77 -- | To append a list of PhyloPeriod to a Phylo
78 appendPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
79 appendPhyloPeriods l p = over (phylo_periods) (++ l) p
82 -- | Does a List of Sets contains at least one Set of an other List
83 doesAnySetContains :: Eq a => Set a -> [Set a] -> [Set a] -> Bool
84 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
87 -- | Does a list of A contains an other list of A
88 doesContains :: Eq a => [a] -> [a] -> Bool
91 | length l' > length l = False
92 | elem (head l') l = doesContains l (tail l')
96 -- | Does a list of ordered A contains an other list of ordered A
97 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
100 | last l < head l' = False
101 | head l' `elem` l = True
102 | otherwise = doesContainsOrd l (tail l')
105 -- | To filter the PhyloGroup of a Phylo according to a function and a value
106 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
107 filterGroups f x l = filter (\g -> (f g) == x) l
110 -- | To filter nested Sets of a
111 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
112 filterNestedSets h l l'
113 | null l = if doesAnySetContains h l l'
116 | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
117 | otherwise = filterNestedSets (head l) (tail l) (h : l')
120 -- | To filter some PhyloEdges with a given threshold
121 filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
122 filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges
125 -- | To get the PhyloGroups Childs of a PhyloGroup
126 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
127 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
130 -- | To get the id of a PhyloGroup
131 getGroupId :: PhyloGroup -> PhyloGroupId
132 getGroupId = _phylo_groupId
135 -- | To get the Cooc Matrix of a PhyloGroup
136 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
137 getGroupCooc = _phylo_groupCooc
140 -- | To get the level out of the id of a PhyloGroup
141 getGroupLevel :: PhyloGroup -> Int
142 getGroupLevel = snd . fst . getGroupId
145 -- | To get the Ngrams of a PhyloGroup
146 getGroupNgrams :: PhyloGroup -> [Int]
147 getGroupNgrams = _phylo_groupNgrams
150 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
151 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
152 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
155 -- | To get the PhyloGroups Parents of a PhyloGroup
156 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
157 getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
160 -- | To get the period out of the id of a PhyloGroup
161 getGroupPeriod :: PhyloGroup -> (Date,Date)
162 getGroupPeriod = fst . fst . getGroupId
165 -- | To get all the PhyloGroup of a Phylo
166 getGroups :: Phylo -> [PhyloGroup]
167 getGroups = view ( phylo_periods
175 -- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
176 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
177 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
180 -- | To get all the PhyloGroup of a Phylo with a given level and period
181 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
182 getGroupsWithFilters lvl prd p = (getGroupsWithLevel lvl p)
184 (getGroupsWithPeriod prd p)
187 -- | To get all the PhyloGroup of a Phylo with a given Level
188 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
189 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
192 -- | To get all the PhyloGroup of a Phylo with a given Period
193 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
194 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
197 -- | To get the index of an element of a Vector
198 getIdx :: Eq a => a -> Vector a -> Int
199 getIdx x v = case (elemIndex x v) of
200 Nothing -> panic "[ERR][Viz.Phylo.Tools.getIndex] Nothing"
204 -- | To get the label of a Level
205 getLevelLabel :: Level -> LevelLabel
206 getLevelLabel lvl = _levelLabel lvl
209 -- | To get the value of a Level
210 getLevelValue :: Level -> Int
211 getLevelValue lvl = _levelValue lvl
214 -- | To get the label of a LevelLink based on a Direction
215 getLevelLinkLabel :: Direction -> LevelLink -> LevelLabel
216 getLevelLinkLabel dir link = case dir of
217 From -> view (levelFrom . levelLabel) link
218 To -> view (levelTo . levelLabel) link
219 _ -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkLabel] Wrong direction"
222 -- | To get the value of a LevelLink based on a Direction
223 getLevelLinkValue :: Direction -> LevelLink -> Int
224 getLevelLinkValue dir link = case dir of
225 From -> view (levelFrom . levelValue) link
226 To -> view (levelTo . levelValue) link
227 _ -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkValue] Wrong direction"
230 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges
231 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
232 getNeighbours directed g e = case directed of
233 True -> map (\((s,t),w) -> t)
234 $ filter (\((s,t),w) -> s == g) e
235 False -> map (\((s,t),w) -> head $ delete g $ nub [s,t,g])
236 $ filter (\((s,t),w) -> s == g || t == g) e
239 -- | To get the Branches of a Phylo
240 getPhyloBranches :: Phylo -> [PhyloBranch]
241 getPhyloBranches = _phylo_branches
244 -- | To get all the Phylolevels of a given PhyloPeriod
245 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
246 getPhyloLevels = view (phylo_periodLevels)
249 -- | To get the Ngrams of a Phylo
250 getPhyloNgrams :: Phylo -> PhyloNgrams
251 getPhyloNgrams = _phylo_ngrams
254 -- | To get all the PhyloPeriodIds of a Phylo
255 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
256 getPhyloPeriods p = map _phylo_periodId
257 $ view (phylo_periods) p
260 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
261 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
262 initGroup ngrams lbl idx lvl from to p = PhyloGroup
263 (((from, to), lvl), idx)
265 (sort $ map (\x -> ngramsToIdx x p) ngrams)
271 -- | To create a Level
272 initLevel :: Int -> LevelLabel -> Level
273 initLevel lvl lbl = Level lbl lvl
276 -- | To create a LevelLink
277 initLevelLink :: Level -> Level -> LevelLink
278 initLevelLink lvl lvl' = LevelLink lvl lvl'
281 -- | To create a PhyloLevel
282 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
283 initPhyloLevel id groups = PhyloLevel id groups
286 -- | To create a PhyloPeriod
287 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
288 initPhyloPeriod id l = PhyloPeriod id l
291 -- | To get all combinations of a list
292 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
293 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
296 -- | To get all combinations of a list and apply a function to the resulting list of pairs
297 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
298 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
301 -- | To get all combinations of a list with no repetition
302 listToUnDirectedCombi :: [a] -> [(a,a)]
303 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l, y <- rest ]
306 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
307 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
308 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
311 -- | To transform an Ngrams into its corresponding index in a Phylo
312 ngramsToIdx :: Ngrams -> Phylo -> Int
313 ngramsToIdx x p = getIdx x (_phylo_ngrams p)
316 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
317 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
318 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
319 = PhyloLevel (id, lvl') groups'
321 groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
324 -- | To choose a LevelLink strategy based an a given Level
325 shouldLink :: LevelLink -> [Int] -> [Int] -> Bool
327 | from <= 1 = doesContainsOrd l l'
328 | from > 1 = undefined
329 | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined")
331 --------------------------------------
333 from = getLevelLinkValue From lvl
334 --------------------------------------
337 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
338 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
339 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2