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, concat, union)
22 import Data.Map (Map, mapKeys, member, elems, adjust)
24 import Data.Text (Text, toLower)
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
33 import qualified Data.Vector as Vector
36 ------------------------------------------------------------------------
40 -- | To add a new PhyloGroupId to a PhyloBranch
41 addGroupIdToBranch :: PhyloGroupId -> PhyloBranch -> PhyloBranch
42 addGroupIdToBranch id b = over (phylo_branchGroups) (++ [id]) b
45 -- | To alter each list of PhyloGroups following a given function
46 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
47 alterPhyloGroups f p = over ( phylo_periods
55 -- | To alter each PhyloPeriod of a Phylo following a given function
56 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
57 alterPhyloPeriods f p = over ( phylo_periods
61 -- | To alter the list of PhyloBranches of a Phylo
62 -- alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
63 -- alterPhyloBranches f p = over ( phylo_branches ) f p
66 -- | To alter a list of PhyloLevels following a given function
67 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
68 alterPhyloLevels f p = over ( phylo_periods
70 . phylo_periodLevels) f p
73 -- | To append a list of PhyloPeriod to a Phylo
74 appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
75 appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
78 -- | Does a List of Sets contains at least one Set of an other List
79 doesAnySetContains :: Eq a => Set a -> [Set a] -> [Set a] -> Bool
80 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
83 -- | Does a list of A contains an other list of A
84 doesContains :: Eq a => [a] -> [a] -> Bool
87 | length l' > length l = False
88 | elem (head l') l = doesContains l (tail l')
92 -- | Does a list of ordered A contains an other list of ordered A
93 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
96 | last l < head l' = False
97 | head l' `elem` l = True
98 | otherwise = doesContainsOrd l (tail l')
101 -- | To filter the PhyloGroup of a Phylo according to a function and a value
102 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
103 filterGroups f x l = filter (\g -> (f g) == x) l
106 -- | To filter nested Sets of a
107 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
108 filterNestedSets h l l'
109 | null l = if doesAnySetContains h l l'
112 | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
113 | otherwise = filterNestedSets (head l) (tail l) (h : l')
116 -- | To filter some PhyloEdges with a given threshold
117 filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
118 filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges
121 -- | To get the foundations of a Phylo
122 getFoundations :: Phylo -> Vector Ngrams
123 getFoundations = _phylo_foundations
126 -- | To get the Index of a Ngrams in the Foundations of a Phylo
127 getIdxInFoundations :: Ngrams -> Phylo -> Int
128 getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
129 Nothing -> panic "[ERR][Viz.Phylo.Tools.getFoundationIdx] Ngrams not in Foundations"
133 -- | To get the PhyloGroups Childs of a PhyloGroup
134 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
135 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
138 -- | To get the id of a PhyloGroup
139 getGroupId :: PhyloGroup -> PhyloGroupId
140 getGroupId = _phylo_groupId
143 -- | To get the Cooc Matrix of a PhyloGroup
144 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
145 getGroupCooc = _phylo_groupCooc
148 -- | To get the level out of the id of a PhyloGroup
149 getGroupLevel :: PhyloGroup -> Int
150 getGroupLevel = snd . fst . getGroupId
153 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
154 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
155 getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
158 -- | To get the Ngrams of a PhyloGroup
159 getGroupNgrams :: PhyloGroup -> [Int]
160 getGroupNgrams = _phylo_groupNgrams
163 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
164 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
165 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
168 -- | To get the PhyloGroups Parents of a PhyloGroup
169 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
170 getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
173 -- | To get the period out of the id of a PhyloGroup
174 getGroupPeriod :: PhyloGroup -> (Date,Date)
175 getGroupPeriod = fst . fst . getGroupId
178 -- | To get all the PhyloGroup of a Phylo
179 getGroups :: Phylo -> [PhyloGroup]
180 getGroups = view ( phylo_periods
188 -- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
189 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
190 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
193 -- | To get all the PhyloGroup of a Phylo with a given level and period
194 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
195 getGroupsWithFilters lvl prd p = (getGroupsWithLevel lvl p)
197 (getGroupsWithPeriod prd p)
200 -- | To get all the PhyloGroup of a Phylo with a given Level
201 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
202 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
205 -- | To get all the PhyloGroup of a Phylo with a given Period
206 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
207 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
210 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
211 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
212 getKeyPair (x,y) m = case findPair (x,y) m of
213 Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
216 --------------------------------------
217 findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
219 | member (x,y) m = Just (x,y)
220 | member (y,x) m = Just (y,x)
221 | otherwise = Nothing
222 --------------------------------------
225 -- | To get the last computed Level in a Phylo
226 getLastLevel :: Phylo -> Level
227 getLastLevel p = (last . sort)
228 $ map (snd . getPhyloLevelId)
229 $ view ( phylo_periods
231 . phylo_periodLevels ) p
234 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges
235 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
236 getNeighbours directed g e = case directed of
237 True -> map (\((s,t),w) -> t)
238 $ filter (\((s,t),w) -> s == g) e
239 False -> map (\((s,t),w) -> head $ delete g $ nub [s,t,g])
240 $ filter (\((s,t),w) -> s == g || t == g) e
243 -- | To get the Branches of a Phylo
244 -- getPhyloBranches :: Phylo -> [PhyloBranch]
245 -- getPhyloBranches = _phylo_branches
248 -- | To get the PhylolevelId of a given PhyloLevel
249 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
250 getPhyloLevelId = _phylo_levelId
253 -- | To get all the Phylolevels of a given PhyloPeriod
254 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
255 getPhyloLevels = view (phylo_periodLevels)
258 -- | To get all the PhyloPeriodIds of a Phylo
259 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
260 getPhyloPeriods p = map _phylo_periodId
261 $ view (phylo_periods) p
264 -- | To get the id of a given PhyloPeriod
265 getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
266 getPhyloPeriodId prd = _phylo_periodId prd
269 -- | To init the foundation of the Phylo as a Vector of Ngrams
270 initFoundations :: [Ngrams] -> Vector Ngrams
271 initFoundations l = Vector.fromList $ map toLower l
274 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
275 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
276 initGroup ngrams lbl idx lvl from to p = PhyloGroup
277 (((from, to), lvl), idx)
279 (sort $ map (\x -> getIdxInFoundations x p) ngrams)
285 -- | To init the Base of a Phylo from a List of Periods and Foundations
286 initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> Phylo
287 initPhyloBase pds fds = Phylo ((fst . head) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds)
290 -- | To create a PhyloLevel
291 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
292 initPhyloLevel id groups = PhyloLevel id groups
295 -- | To create a PhyloPeriod
296 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
297 initPhyloPeriod id l = PhyloPeriod id l
300 -- | To filter Fis with small Support but by keeping non empty Periods
301 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
302 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
303 then keepFilled f (thr - 1) l
307 -- | To get all combinations of a list
308 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
309 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
312 -- | To get all combinations of a list and apply a function to the resulting list of pairs
313 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
314 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
317 -- | To get all combinations of a list with no repetition
318 listToUnDirectedCombi :: [a] -> [(a,a)]
319 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l, y <- rest ]
322 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
323 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
324 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
327 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
328 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
329 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
330 = PhyloLevel (id, lvl') groups'
332 groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
335 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
336 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
337 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2