]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/Tools.hs
add the foundations to the phylo
[gargantext.git] / src / Gargantext / Viz / Phylo / Tools.hs
1 {-|
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
8 Portability : POSIX
9
10
11 -}
12
13 {-# LANGUAGE NoImplicitPrelude #-}
14 {-# LANGUAGE FlexibleContexts #-}
15 {-# LANGUAGE OverloadedStrings #-}
16
17 module Gargantext.Viz.Phylo.Tools
18 where
19
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)
23 import Data.Set (Set)
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
29
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
34
35
36 ------------------------------------------------------------------------
37 -- | Tools | --
38
39
40 -- | To add a new PhyloGroupId to a PhyloBranch
41 addGroupIdToBranch :: PhyloGroupId -> PhyloBranch -> PhyloBranch
42 addGroupIdToBranch id b = over (phylo_branchGroups) (++ [id]) b
43
44
45 -- | To alter each list of PhyloGroups following a given function
46 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
47 alterPhyloGroups f p = over ( phylo_periods
48 . traverse
49 . phylo_periodLevels
50 . traverse
51 . phylo_levelGroups
52 ) f p
53
54
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
58 . traverse) f p
59
60
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
64
65
66 -- | To alter a list of PhyloLevels following a given function
67 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
68 alterPhyloLevels f p = over ( phylo_periods
69 . traverse
70 . phylo_periodLevels) f p
71
72
73 -- | To append a list of PhyloPeriod to a Phylo
74 appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
75 appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
76
77
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)
81
82
83 -- | Does a list of A contains an other list of A
84 doesContains :: Eq a => [a] -> [a] -> Bool
85 doesContains l l'
86 | null l' = True
87 | length l' > length l = False
88 | elem (head l') l = doesContains l (tail l')
89 | otherwise = False
90
91
92 -- | Does a list of ordered A contains an other list of ordered A
93 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
94 doesContainsOrd l l'
95 | null l' = False
96 | last l < head l' = False
97 | head l' `elem` l = True
98 | otherwise = doesContainsOrd l (tail l')
99
100
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
104
105
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'
110 then l'
111 else h : l'
112 | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
113 | otherwise = filterNestedSets (head l) (tail l) (h : l')
114
115
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
119
120
121 -- | To get the foundations of a Phylo
122 getFoundations :: Phylo -> Vector Ngrams
123 getFoundations = _phylo_foundations
124
125
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"
130 Just idx -> idx
131
132
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
136
137
138 -- | To get the id of a PhyloGroup
139 getGroupId :: PhyloGroup -> PhyloGroupId
140 getGroupId = _phylo_groupId
141
142
143 -- | To get the Cooc Matrix of a PhyloGroup
144 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
145 getGroupCooc = _phylo_groupCooc
146
147
148 -- | To get the level out of the id of a PhyloGroup
149 getGroupLevel :: PhyloGroup -> Int
150 getGroupLevel = snd . fst . getGroupId
151
152
153 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
154 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
155 getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
156
157
158 -- | To get the Ngrams of a PhyloGroup
159 getGroupNgrams :: PhyloGroup -> [Int]
160 getGroupNgrams = _phylo_groupNgrams
161
162
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)
166
167
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
171
172
173 -- | To get the period out of the id of a PhyloGroup
174 getGroupPeriod :: PhyloGroup -> (Date,Date)
175 getGroupPeriod = fst . fst . getGroupId
176
177
178 -- | To get all the PhyloGroup of a Phylo
179 getGroups :: Phylo -> [PhyloGroup]
180 getGroups = view ( phylo_periods
181 . traverse
182 . phylo_periodLevels
183 . traverse
184 . phylo_levelGroups
185 )
186
187
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
191
192
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)
196 `intersect`
197 (getGroupsWithPeriod prd p)
198
199
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)
203
204
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)
208
209
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"
214 Just i -> i
215 where
216 --------------------------------------
217 findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
218 findPair (x,y) m
219 | member (x,y) m = Just (x,y)
220 | member (y,x) m = Just (y,x)
221 | otherwise = Nothing
222 --------------------------------------
223
224
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
230 . traverse
231 . phylo_periodLevels ) p
232
233
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
241
242
243 -- | To get the Branches of a Phylo
244 -- getPhyloBranches :: Phylo -> [PhyloBranch]
245 -- getPhyloBranches = _phylo_branches
246
247
248 -- | To get the PhylolevelId of a given PhyloLevel
249 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
250 getPhyloLevelId = _phylo_levelId
251
252
253 -- | To get all the Phylolevels of a given PhyloPeriod
254 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
255 getPhyloLevels = view (phylo_periodLevels)
256
257
258 -- | To get all the PhyloPeriodIds of a Phylo
259 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
260 getPhyloPeriods p = map _phylo_periodId
261 $ view (phylo_periods) p
262
263
264 -- | To get the id of a given PhyloPeriod
265 getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
266 getPhyloPeriodId prd = _phylo_periodId prd
267
268
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
272
273
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)
278 lbl
279 (sort $ map (\x -> getIdxInFoundations x p) ngrams)
280 (Map.empty)
281 (Map.empty)
282 [] [] [] []
283
284
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)
288
289
290 -- | To create a PhyloLevel
291 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
292 initPhyloLevel id groups = PhyloLevel id groups
293
294
295 -- | To create a PhyloPeriod
296 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
297 initPhyloPeriod id l = PhyloPeriod id l
298
299
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
304 else f thr l
305
306
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]
310
311
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]
315
316
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 ]
320
321
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 ]
325
326
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'
331 where
332 groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
333
334
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
338 then (y,x)
339 else (x,y) ) m1