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