]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/PhyloMaker.hs
bug fix
[gargantext.git] / src / Gargantext / Viz / Phylo / PhyloMaker.hs
1 {-|
2 Module : Gargantext.Viz.Phylo.PhyloMaker
3 Description : Maker engine for rebuilding a Phylo
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 {-# LANGUAGE NoImplicitPrelude #-}
12 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE OverloadedStrings #-}
14 {-# LANGUAGE MultiParamTypeClasses #-}
15
16 module Gargantext.Viz.Phylo.PhyloMaker where
17
18 import Data.List (concat, nub, partition, sort, (++), group, intersect, null, sortOn, groupBy, tail)
19 import Data.Map (Map, fromListWith, keys, unionWith, fromList, empty, toList, elems, (!), restrictKeys, foldlWithKey, insert)
20 import Data.Vector (Vector)
21
22 import Gargantext.Prelude
23 import Gargantext.Viz.AdaptativePhylo
24 import Gargantext.Viz.Phylo.PhyloTools
25 import Gargantext.Viz.Phylo.TemporalMatching (adaptativeTemporalMatching, constanteTemporalMatching, getNextPeriods, filterDocs, filterDiago, reduceDiagos, toProximity)
26 import Gargantext.Viz.Phylo.SynchronicClustering (synchronicClustering)
27 import Gargantext.Text.Context (TermList)
28 import Gargantext.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
29 import Gargantext.Viz.Graph.MaxClique (getMaxCliques)
30
31 import Control.DeepSeq (NFData)
32 import Control.Parallel.Strategies (parList, rdeepseq, using)
33 import Debug.Trace (trace)
34 import Control.Lens hiding (Level)
35
36 import qualified Data.Vector as Vector
37 import qualified Data.Set as Set
38
39
40 ------------------
41 -- | To Phylo | --
42 ------------------
43
44
45 toPhylo :: [Document] -> TermList -> Config -> Phylo
46 toPhylo docs lst conf = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1))
47 $ traceToPhylo (phyloLevel conf) $
48 if (phyloLevel conf) > 1
49 then foldl' (\phylo' _ -> synchronicClustering phylo') phylo1 [2..(phyloLevel conf)]
50 else phylo1
51 where
52 --------------------------------------
53 phylo1 :: Phylo
54 phylo1 = toPhylo1 docs phyloBase
55 --------------------------------------
56 phyloBase :: Phylo
57 phyloBase = toPhyloBase docs lst conf
58 --------------------------------------
59
60
61
62 --------------------
63 -- | To Phylo 1 | --
64 --------------------
65
66 toGroupsProxi :: Level -> Phylo -> Phylo
67 toGroupsProxi lvl phylo =
68 let proximity = phyloProximity $ getConfig phylo
69 groupsProxi = foldlWithKey (\acc pId pds ->
70 -- 1) process period by period
71 let egos = map (\g -> (getGroupId g, g ^. phylo_groupNgrams))
72 $ elems
73 $ view ( phylo_periodLevels
74 . traverse . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
75 . phylo_levelGroups ) pds
76 next = getNextPeriods ToParents (getTimeFrame $ timeUnit $ getConfig phylo) pId (keys $ phylo ^. phylo_periods)
77 targets = map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ getGroupsFromLevelPeriods lvl next phylo
78 docs = filterDocs (phylo ^. phylo_timeDocs) ([pId] ++ next)
79 diagos = filterDiago (phylo ^. phylo_timeCooc) ([pId] ++ next)
80 -- 2) compute the pairs in parallel
81 pairs = map (\(id,ngrams) ->
82 map (\(id',ngrams') ->
83 let nbDocs = (sum . elems) $ filterDocs docs ([idToPrd id, idToPrd id'])
84 diago = reduceDiagos $ filterDiago diagos ([idToPrd id, idToPrd id'])
85 in ((id,id'),toProximity nbDocs diago proximity ngrams ngrams' ngrams')
86 ) $ filter (\(_,ngrams') -> (not . null) $ intersect ngrams ngrams') targets
87 ) egos
88 pairs' = pairs `using` parList rdeepseq
89 in acc ++ (concat pairs')
90 ) [] $ phylo ^. phylo_periods
91 in phylo & phylo_groupsProxi .~ ((traceGroupsProxi . fromList) groupsProxi)
92
93
94 appendGroups :: (a -> PhyloPeriodId -> Level -> Int -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
95 appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n")
96 $ over ( phylo_periods
97 . traverse
98 . phylo_periodLevels
99 . traverse)
100 (\phyloLvl -> if lvl == (phyloLvl ^. phylo_levelLevel)
101 then
102 let pId = phyloLvl ^. phylo_levelPeriod
103 phyloCUnit = m ! pId
104 in phyloLvl
105 & phylo_levelGroups .~ (fromList $ foldl (\groups obj ->
106 groups ++ [ (((pId,lvl),length groups)
107 , f obj pId lvl (length groups)
108 (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId]))
109 ] ) [] phyloCUnit)
110 else
111 phyloLvl )
112 phylo
113
114
115 cliqueToGroup :: PhyloClique -> PhyloPeriodId -> Level -> Int -> [Cooc] -> PhyloGroup
116 cliqueToGroup fis pId lvl idx coocs = PhyloGroup pId lvl idx ""
117 (fis ^. phyloClique_support)
118 (fis ^. phyloClique_nodes)
119 (ngramsToCooc (fis ^. phyloClique_nodes) coocs)
120 (1,[0]) -- | branchid (lvl,[path in the branching tree])
121 (fromList [("breaks",[0]),("seaLevels",[0])])
122 [] [] [] []
123
124
125 toPhylo1 :: [Document] -> Phylo -> Phylo
126 toPhylo1 docs phyloBase = case (getSeaElevation phyloBase) of
127 Constante start gap -> constanteTemporalMatching start gap
128 $ appendGroups cliqueToGroup 1 phyloClique phyloBase
129 Adaptative steps -> adaptativeTemporalMatching steps
130 $ toGroupsProxi 1
131 $ appendGroups cliqueToGroup 1 phyloClique phyloBase
132 where
133 --------------------------------------
134 phyloClique :: Map (Date,Date) [PhyloClique]
135 phyloClique = toPhyloClique phyloBase docs'
136 --------------------------------------
137 docs' :: Map (Date,Date) [Document]
138 docs' = groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
139 -- docs' = groupDocsByPeriod' date (getPeriodIds phyloBase) docs
140 --------------------------------------
141
142
143 ---------------------------
144 -- | Frequent Item Set | --
145 ---------------------------
146
147
148 -- | To apply a filter with the possibility of keeping some periods non empty (keep : True|False)
149 filterClique :: Bool -> Int -> (Int -> [PhyloClique] -> [PhyloClique]) -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
150 filterClique keep thr f m = case keep of
151 False -> map (\l -> f thr l) m
152 True -> map (\l -> keepFilled (f) thr l) m
153
154
155 -- | To filter Fis with small Support
156 filterCliqueBySupport :: Int -> [PhyloClique] -> [PhyloClique]
157 filterCliqueBySupport thr l = filter (\clq -> (clq ^. phyloClique_support) >= thr) l
158
159
160 -- | To filter Fis with small Clique size
161 filterCliqueBySize :: Int -> [PhyloClique] -> [PhyloClique]
162 filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. phyloClique_nodes) >= thr) l
163
164
165 -- | To filter nested Fis
166 filterCliqueByNested :: Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
167 filterCliqueByNested m =
168 let clq = map (\l ->
169 foldl (\mem f -> if (any (\f' -> isNested (f' ^. phyloClique_nodes) (f ^. phyloClique_nodes)) mem)
170 then mem
171 else
172 let fMax = filter (\f' -> not $ isNested (f ^. phyloClique_nodes) (f' ^. phyloClique_nodes)) mem
173 in fMax ++ [f] ) [] l)
174 $ elems m
175 clq' = clq `using` parList rdeepseq
176 in fromList $ zip (keys m) clq'
177
178
179 -- | To transform a time map of docs into a time map of Fis with some filters
180 toPhyloClique :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [PhyloClique]
181 toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
182 Fis s s' -> -- traceFis "Filtered Fis"
183 filterCliqueByNested
184 -- $ traceFis "Filtered by clique size"
185 $ filterClique True s' (filterCliqueBySize)
186 -- $ traceFis "Filtered by support"
187 $ filterClique True s (filterCliqueBySupport)
188 -- $ traceFis "Unfiltered Fis"
189 phyloClique
190 MaxClique s -> filterClique True s (filterCliqueBySize)
191 phyloClique
192 where
193 --------------------------------------
194 phyloClique :: Map (Date,Date) [PhyloClique]
195 phyloClique = case (clique $ getConfig phylo) of
196 Fis _ _ ->
197 let fis = map (\(prd,docs) ->
198 let lst = toList $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs)
199 in (prd, map (\f -> PhyloClique (Set.toList $ fst f) (snd f) prd) lst))
200 $ toList phyloDocs
201 fis' = fis `using` parList rdeepseq
202 in fromList fis'
203 MaxClique _ ->
204 let mcl = map (\(prd,docs) ->
205 let cooc = map round
206 $ foldl sumCooc empty
207 $ map listToMatrix
208 $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
209 in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques 0 cooc))
210 $ toList phyloDocs
211 mcl' = mcl `using` parList rdeepseq
212 in fromList mcl'
213 --------------------------------------
214
215 -- dev viz graph maxClique getMaxClique
216
217
218 --------------------
219 -- | Coocurency | --
220 --------------------
221
222
223 -- | To transform the docs into a time map of coocurency matrix
224 docsToTimeScaleCooc :: [Document] -> Vector Ngrams -> Map Date Cooc
225 docsToTimeScaleCooc docs fdt =
226 let mCooc = fromListWith sumCooc
227 $ map (\(_d,l) -> (_d, listToMatrix l))
228 $ map (\doc -> (date doc, sort $ ngramsToIdx (text doc) fdt)) docs
229 mCooc' = fromList
230 $ map (\t -> (t,empty))
231 $ toTimeScale (map date docs) 1
232 in trace ("\n" <> "-- | Build the coocurency matrix for " <> show (length $ keys mCooc') <> " unit of time" <> "\n")
233 $ unionWith sumCooc mCooc mCooc'
234
235
236 -----------------------
237 -- | to Phylo Base | --
238 -----------------------
239
240 groupDocsByPeriodRec :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc] -> Map (date, date) [doc]
241 groupDocsByPeriodRec f prds docs acc =
242 if ((null prds) || (null docs))
243 then acc
244 else
245 let prd = head' "groupBy" prds
246 docs' = partition (\d -> (f d >= fst prd) && (f d <= snd prd)) docs
247 in groupDocsByPeriodRec f (tail prds) (snd docs') (insert prd (fst docs') acc)
248
249
250 -- | To group a list of Documents by fixed periods
251 groupDocsByPeriod' :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
252 groupDocsByPeriod' f pds docs =
253 let docs' = groupBy (\d d' -> f d == f d') $ sortOn f docs
254 periods = map (inPeriode f docs') pds
255 periods' = periods `using` parList rdeepseq
256 in trace ("\n" <> "-- | Group " <> show(length docs) <> " docs by " <> show(length pds) <> " periods" <> "\n")
257 $ fromList $ zip pds periods'
258 where
259 --------------------------------------
260 inPeriode :: Ord b => (t -> b) -> [[t]] -> (b, b) -> [t]
261 inPeriode f' h (start,end) =
262 concat $ fst $ partition (\d -> f' (head' "inPeriode" d) >= start && f' (head' "inPeriode" d) <= end) h
263
264
265
266 -- | To group a list of Documents by fixed periods
267 groupDocsByPeriod :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
268 groupDocsByPeriod _ _ [] = panic "[ERR][Viz.Phylo.PhyloMaker] Empty [Documents] can not have any periods"
269 groupDocsByPeriod f pds es =
270 let periods = map (inPeriode f es) pds
271 periods' = periods `using` parList rdeepseq
272
273 in trace ("\n" <> "-- | Group " <> show(length es) <> " docs by " <> show(length pds) <> " periods" <> "\n")
274 $ fromList $ zip pds periods'
275 where
276 --------------------------------------
277 inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
278 inPeriode f' h (start,end) =
279 fst $ partition (\d -> f' d >= start && f' d <= end) h
280 --------------------------------------
281
282
283 docsToTermFreq :: [Document] -> Vector Ngrams -> Map Int Double
284 docsToTermFreq docs fdt =
285 let nbDocs = fromIntegral $ length docs
286 freqs = map (/(nbDocs))
287 $ fromList
288 $ map (\lst -> (head' "docsToTermFreq" lst, fromIntegral $ length lst))
289 $ group $ sort $ concat $ map (\d -> nub $ ngramsToIdx (text d) fdt) docs
290 sumFreqs = sum $ elems freqs
291 in map (/sumFreqs) freqs
292
293
294 -- | To count the number of docs by unit of time
295 docsToTimeScaleNb :: [Document] -> Map Date Double
296 docsToTimeScaleNb docs =
297 let docs' = fromListWith (+) $ map (\d -> (date d,1)) docs
298 time = fromList $ map (\t -> (t,0)) $ toTimeScale (keys docs') 1
299 in trace ("\n" <> "-- | Group " <> show(length docs) <> " docs by " <> show(length time) <> " unit of time" <> "\n")
300 $ unionWith (+) time docs'
301
302
303 initPhyloLevels :: Int -> PhyloPeriodId -> Map PhyloLevelId PhyloLevel
304 initPhyloLevels lvlMax pId =
305 fromList $ map (\lvl -> ((pId,lvl),PhyloLevel pId lvl empty)) [1..lvlMax]
306
307
308 -- | To init the basic elements of a Phylo
309 toPhyloBase :: [Document] -> TermList -> Config -> Phylo
310 toPhyloBase docs lst conf =
311 let foundations = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst
312 params = defaultPhyloParam { _phyloParam_config = conf }
313 periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit conf) (getTimeStep $ timeUnit conf)
314 in trace ("\n" <> "-- | Create PhyloBase out of " <> show(length docs) <> " docs \n")
315 $ Phylo foundations
316 (docsToTimeScaleCooc docs (foundations ^. foundations_roots))
317 (docsToTimeScaleNb docs)
318 (docsToTermFreq docs (foundations ^. foundations_roots))
319 empty
320 empty
321 params
322 (fromList $ map (\prd -> (prd, PhyloPeriod prd (initPhyloLevels 1 prd))) periods)