]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/SynchronicClustering.hs
bug fix
[gargantext.git] / src / Gargantext / Viz / Phylo / SynchronicClustering.hs
1 {-|
2 Module : Gargantext.Viz.Phylo.SynchronicClustering
3 Description : Module dedicated to the adaptative synchronic clustering of 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.SynchronicClustering where
17
18 import Gargantext.Prelude
19 import Gargantext.Viz.AdaptativePhylo
20 import Gargantext.Viz.Phylo.PhyloTools
21 import Gargantext.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
22 import Gargantext.Viz.Phylo.PhyloExport (processDynamics)
23
24 import Data.List ((++), null, intersect, nub, concat, sort, sortOn, all, groupBy, group, maximum)
25 import Data.Map (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
26 import Data.Text (Text)
27
28 import Control.Lens hiding (Level)
29 import Control.Parallel.Strategies (parList, rdeepseq, using)
30 -- import Debug.Trace (trace)
31
32 import qualified Data.Map as Map
33 import qualified Data.Set as Set
34
35
36 -------------------------
37 -- | New Level Maker | --
38 -------------------------
39
40 mergeBranchIds :: [[Int]] -> [Int]
41 mergeBranchIds ids = (head' "mergeBranchIds" . sort . mostFreq') ids
42 where
43 -- | 2) find the most Up Left ids in the hierarchy of similarity
44 -- mostUpLeft :: [[Int]] -> [[Int]]
45 -- mostUpLeft ids' =
46 -- let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
47 -- inf = (fst . minimum) groupIds
48 -- in map snd $ filter (\gIds -> fst gIds == inf) groupIds
49 -- | 1) find the most frequent ids
50 mostFreq' :: [[Int]] -> [[Int]]
51 mostFreq' ids' =
52 let groupIds = (map (\gIds -> (length gIds, head' "gIds" gIds)) . group . sort) ids'
53 sup = (fst . maximum) groupIds
54 in map snd $ filter (\gIds -> fst gIds == sup) groupIds
55
56
57 mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
58 mergeMeta bId groups =
59 let ego = head' "mergeMeta" $ filter (\g -> (snd (g ^. phylo_groupBranchId)) == bId) groups
60 in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
61
62
63 groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
64 groupsToBranches' groups =
65 -- | run the related component algorithm
66 let egos = map (\g -> [getGroupId g]
67 ++ (map fst $ g ^. phylo_groupPeriodParents)
68 ++ (map fst $ g ^. phylo_groupPeriodChilds) ) $ elems groups
69 graph = relatedComponents egos
70 -- | update each group's branch id
71 in map (\ids ->
72 let groups' = elems $ restrictKeys groups (Set.fromList ids)
73 bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
74 in map (\g -> g & phylo_groupBranchId %~ (\(lvl,_) -> (lvl,bId))) groups') graph
75
76
77 mergeGroups :: [Cooc] -> PhyloGroupId -> Map PhyloGroupId PhyloGroupId -> [PhyloGroup] -> PhyloGroup
78 mergeGroups coocs id mapIds childs =
79 let ngrams = (sort . nub . concat) $ map _phylo_groupNgrams childs
80 in PhyloGroup (fst $ fst id) (snd $ fst id) (snd id) ""
81 (sum $ map _phylo_groupSupport childs) ngrams
82 (ngramsToCooc ngrams coocs)
83 ((snd $ fst id),bId)
84 (mergeMeta bId childs) [] (map (\g -> (getGroupId g, 1)) childs)
85 (updatePointers $ concat $ map _phylo_groupPeriodParents childs)
86 (updatePointers $ concat $ map _phylo_groupPeriodChilds childs)
87 where
88 --------------------
89 bId :: [Int]
90 bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) childs
91 --------------------
92 updatePointers :: [Pointer] -> [Pointer]
93 updatePointers pointers = map (\(pId,w) -> (mapIds ! pId,w)) pointers
94
95
96 addPhyloLevel :: Level -> Phylo -> Phylo
97 addPhyloLevel lvl phylo =
98 over ( phylo_periods . traverse )
99 (\phyloPrd -> phyloPrd & phylo_periodLevels
100 %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) (PhyloLevel (phyloPrd ^. phylo_periodPeriod) lvl empty))) phylo
101
102
103 toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
104 toNextLevel' phylo groups =
105 let curLvl = getLastLevel phylo
106 oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
107 newGroups = concat $ groupsToBranches'
108 $ fromList $ map (\g -> (getGroupId g, g))
109 $ foldlWithKey (\acc id groups' ->
110 -- | 4) create the parent group
111 let parent = mergeGroups (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [(fst . fst) id]) id oldGroups groups'
112 in acc ++ [parent]) []
113 -- | 3) group the current groups by parentId
114 $ fromListWith (++) $ map (\g -> (getLevelParentId g, [g])) groups
115
116 newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups
117 in traceSynchronyEnd
118 $ over ( phylo_periods . traverse . phylo_periodLevels . traverse
119 -- | 6) update each period at curLvl + 1
120 . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == (curLvl + 1)))
121 -- | 7) by adding the parents
122 (\phyloLvl ->
123 if member (phyloLvl ^. phylo_levelPeriod) newPeriods
124 then phyloLvl & phylo_levelGroups
125 .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_levelPeriod))
126 else phyloLvl)
127 -- | 2) add the curLvl + 1 phyloLevel to the phylo
128 $ addPhyloLevel (curLvl + 1)
129 -- | 1) update the current groups (with level parent pointers) in the phylo
130 $ updatePhyloGroups curLvl (fromList $ map (\g -> (getGroupId g, g)) groups) phylo
131
132 --------------------
133 -- | Clustering | --
134 --------------------
135
136 toPairs :: SynchronyStrategy -> [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
137 toPairs strategy groups = case strategy of
138 MergeRegularGroups -> pairs
139 $ filter (\g -> all (== 3) $ (g ^. phylo_groupMeta) ! "dynamics") groups
140 MergeAllGroups -> pairs groups
141 where
142 pairs :: [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
143 pairs gs = filter (\(g,g') -> (not . null) $ intersect (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams)) (listToCombi' gs)
144
145
146 toDiamonds :: [PhyloGroup] -> [[PhyloGroup]]
147 toDiamonds groups = foldl' (\acc groups' ->
148 acc ++ ( elems
149 $ Map.filter (\v -> length v > 1)
150 $ fromListWith (++)
151 $ foldl' (\acc' g ->
152 acc' ++ (map (\(id,_) -> (id,[g]) ) $ g ^. phylo_groupPeriodChilds)) [] groups')) []
153 $ elems
154 $ Map.filter (\v -> length v > 1)
155 $ fromListWith (++)
156 $ foldl' (\acc g -> acc ++ (map (\(id,_) -> (id,[g]) ) $ g ^. phylo_groupPeriodParents) ) [] groups
157
158
159 groupsToEdges :: Proximity -> Synchrony -> Double -> Map Int Double -> [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)]
160 groupsToEdges prox sync nbDocs diago groups =
161 case sync of
162 ByProximityThreshold thr sens _ strat ->
163 filter (\(_,w) -> w >= thr)
164 $ toEdges sens
165 $ toPairs strat groups
166 ByProximityDistribution sens strat ->
167 let diamonds = sortOn snd
168 $ toEdges sens $ concat
169 $ map (\gs -> toPairs strat gs) $ toDiamonds groups
170 in take (div (length diamonds) 2) diamonds
171 where
172 toEdges :: Double -> [(PhyloGroup,PhyloGroup)] -> [((PhyloGroup,PhyloGroup),Double)]
173 toEdges sens edges =
174 case prox of
175 WeightedLogJaccard _ -> map (\(g,g') ->
176 ((g,g'), weightedLogJaccard' sens nbDocs diago
177 (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
178 _ -> undefined
179
180 toParentId :: PhyloGroup -> PhyloGroupId
181 toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupLevel + 1), child ^. phylo_groupIndex)
182
183
184 reduceGroups :: Proximity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
185 reduceGroups prox sync docs diagos branch =
186 -- | 1) reduce a branch as a set of periods & groups
187 let periods = fromListWith (++)
188 $ map (\g -> (g ^. phylo_groupPeriod,[g])) branch
189 in (concat . concat . elems)
190 $ mapWithKey (\prd groups ->
191 -- | 2) for each period, transform the groups as a proximity graph filtered by a threshold
192 let diago = reduceDiagos $ filterDiago diagos [prd]
193 edges = groupsToEdges prox sync ((sum . elems) $ restrictKeys docs $ periodsToYears [prd]) diago groups
194 in map (\comp ->
195 -- | 4) add to each groups their futur level parent group
196 let parentId = toParentId (head' "parentId" comp)
197 in map (\g -> g & phylo_groupLevelParents %~ (++ [(parentId,1)]) ) comp )
198 -- |3) reduce the graph a a set of related components
199 $ toRelatedComponents groups edges) periods
200
201
202 adjustClustering :: Synchrony -> [[PhyloGroup]] -> [[PhyloGroup]]
203 adjustClustering sync branches = case sync of
204 ByProximityThreshold _ _ scope _ -> case scope of
205 SingleBranch -> branches
206 SiblingBranches -> groupBy (\g g' -> (last' "adjustClustering" $ (g ^. phylo_groupMeta) ! "breaks")
207 == (last' "adjustClustering" $ (g' ^. phylo_groupMeta) ! "breaks"))
208 $ sortOn _phylo_groupBranchId $ concat branches
209 AllBranches -> [concat branches]
210 ByProximityDistribution _ _ -> branches
211
212
213
214 synchronicClustering :: Phylo -> Phylo
215 synchronicClustering phylo =
216 let prox = phyloProximity $ getConfig phylo
217 sync = phyloSynchrony $ getConfig phylo
218 docs = phylo ^. phylo_timeDocs
219 diagos = map coocToDiago $ phylo ^. phylo_timeCooc
220 newBranches = map (\branch -> reduceGroups prox sync docs diagos branch)
221 $ map processDynamics
222 $ adjustClustering sync
223 $ phyloToLastBranches
224 $ traceSynchronyStart phylo
225 newBranches' = newBranches `using` parList rdeepseq
226 in toNextLevel' phylo $ concat newBranches'
227
228
229 -- synchronicDistance :: Phylo -> Level -> String
230 -- synchronicDistance phylo lvl =
231 -- foldl' (\acc branch ->
232 -- acc <> (foldl' (\acc' period ->
233 -- acc' <> let prox = phyloProximity $ getConfig phylo
234 -- sync = phyloSynchrony $ getConfig phylo
235 -- docs = _phylo_timeDocs phylo
236 -- prd = _phylo_groupPeriod $ head' "distance" period
237 -- edges = groupsToEdges prox 0.1 (_bpt_sensibility sync)
238 -- ((sum . elems) $ restrictKeys docs $ periodsToYears [_phylo_groupPeriod $ head' "distance" period]) period
239 -- in foldl' (\mem (_,w) ->
240 -- mem <> show (prd)
241 -- <> "\t"
242 -- <> show (w)
243 -- <> "\n"
244 -- ) "" edges
245 -- ) "" $ elems $ groupByField _phylo_groupPeriod branch)
246 -- ) "period\tdistance\n" $ elems $ groupByField _phylo_groupBranchId $ getGroupsFromLevel lvl phylo