src/Gargantext/Core/Viz/Phylo/Cluster.hs

   1 {-|
   2 Module      : Gargantext.Core.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 TemplateHaskell #-}
  14
  15 module Gargantext.Core.Viz.Phylo.Cluster
  16   where
  17 import Control.Parallel.Strategies
  18 import Data.Graph.Clustering.Louvain.CplusPlus
  19 import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
  20 import Data.List        (null,concat,sort,intersect,(++), elemIndex, groupBy, nub, union, (\\), (!!))
  21 import Data.Map         (Map, fromList, mapKeys)
  22 import Gargantext.Prelude
  23 import Gargantext.Core.Viz.Phylo
  24 import Gargantext.Core.Viz.Phylo.Tools
  25 import Gargantext.Core.Viz.Phylo.Metrics
  26 import Gargantext.Core.Viz.Phylo.LinkMaker
  27 import qualified Data.Map    as Map
  28
  29 import qualified Data.Vector.Storable as VS
  30 import Debug.Trace (trace)
  31 import Numeric.Statistics (percentile)
  32
  33
  34 --------------
  35 -- | Algo | --
  36 --------------
  37
  38
  39 relatedComp :: Eq a => [[a]] -> [[a]]
  40 relatedComp graphs = foldl' (\mem groups ->
  41   if (null mem)
  42   then mem ++ [groups]
  43   else
  44     let related = filter (\groups' -> (not . null) $ intersect groups groups') mem
  45     in if (null related)
  46        then mem ++ [groups]
  47        else (mem \\ related) ++ [union groups (nub $ concat related)] ) [] graphs
  48
  49
  50 louvain :: ([GroupNode],[GroupEdge]) -> IO [[PhyloGroup]]
  51 louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
  52                       <$> groupBy (\a b -> (l_community_id a) == (l_community_id b))
  53                       <$> (cLouvain "0.0001" $ mapKeys (\(x,y) -> (idx x, idx y)) $ fromList edges)
  54   where
  55     --------------------------------------
  56     idx :: PhyloGroup -> Int
  57     idx e = case elemIndex e nodes of
  58       Nothing -> panic "[ERR][Gargantext.Core.Viz.Phylo.Metrics.Clustering] a node is missing"
  59       Just i  -> i
  60     --------------------------------------
  61
  62
  63 -----------------------
  64 -- | Cluster Maker | --
  65 -----------------------
  66
  67
  68 -- | Optimisation to filter only relevant candidates
  69 getCandidates :: [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
  70 getCandidates gs = filter (\(g,g') -> (not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))
  71                  $ filter (\(g,g') -> g /= g')
  72                  $ listToDirectedCombi gs
  73
  74
  75 -- | To transform a Graph into Clusters
  76 graphToClusters :: Cluster -> GroupGraph -> [PhyloCluster]
  77 graphToClusters clust (nodes,edges) = case clust of
  78       Louvain (LouvainParams _)      -> undefined
  79       RelatedComponents (RCParams _) -> relatedComp $ ((map (\((g,g'),_) -> [g,g']) edges) ++ (map (\g -> [g]) nodes))
  80       _                              -> panic "[ERR][Viz.Phylo.Aggregates.Cluster.graphToClusters] not implemented"
  81
  82
  83 -- | To transform a list of PhyloGroups into a Graph of Proximity
  84 groupsToGraph :: Double -> Proximity -> [PhyloGroup] -> ([GroupNode],[GroupEdge])
  85 groupsToGraph nbDocs prox gs = case prox of
  86       WeightedLogJaccard (WLJParams _ sens) -> (gs, let candidates  = map (\(x,y) -> ((x,y), weightedLogJaccard sens nbDocs (getGroupCooc x) (getGroupCooc y) (getGroupNgrams x) (getGroupNgrams y)))
  87                                                                     $ getCandidates gs
  88                                                         candidates' = candidates `using` parList rdeepseq
  89                                                     in  candidates' )
  90       Hamming (HammingParams _)             -> (gs, map (\(x,y) -> ((x,y), hamming (getGroupCooc x) (getGroupCooc y))) $ getCandidates gs)
  91       _                                     -> undefined
  92
  93
  94 -- | To filter a Graph of Proximity using a given threshold
  95 filterGraph :: Proximity -> ([GroupNode],[GroupEdge]) -> ([GroupNode],[GroupEdge])
  96 filterGraph prox (ns,es) = case prox of
  97       WeightedLogJaccard (WLJParams thr _) -> (ns, filter (\(_,v) -> v >= thr) es)
  98       Hamming (HammingParams thr)          -> (ns, filter (\(_,v) -> v <= thr) es)
  99       _                                    -> undefined
 100
 101
 102 -- | To clusterise a Phylo
 103 phyloToClusters :: Level -> Cluster -> Phylo -> Map (Date,Date) [PhyloCluster]
 104 phyloToClusters lvl clus p = Map.fromList
 105                             $ zip periods
 106                             $ map (\g -> if null (fst g)
 107                                          then []
 108                                          else graphToClusters clus g) graphs'
 109   where
 110     --------------------------------------
 111     graphs' :: [([GroupNode],[GroupEdge])]
 112     graphs' = traceGraphFiltered lvl
 113             $ map (\g -> filterGraph prox g) graphs
 114     --------------------------------------
 115     graphs :: [([GroupNode],[GroupEdge])]
 116     graphs = traceGraph lvl (getThreshold prox)
 117            $ let gs  = (trace $ "PROX: " <> show prox) $ map (\prd -> groupsToGraph (periodsToNbDocs [prd] p) prox (getGroupsWithFilters lvl prd p)) periods
 118                  gs' = gs `using` parList rdeepseq
 119              in  gs'
 120     --------------------------------------
 121     prox :: Proximity
 122     prox = getProximity clus
 123     --------------------------------------
 124     periods :: [PhyloPeriodId]
 125     periods = getPhyloPeriods p
 126     --------------------------------------
 127
 128
 129 ----------------
 130 -- | Tracer | --
 131 ----------------
 132
 133
 134 traceGraph :: Level -> Double -> [([GroupNode],[GroupEdge])] -> [([GroupNode],[GroupEdge])]
 135 traceGraph lvl thr g = trace ( "----\nUnfiltered clustering in Phylo" <> show (lvl) <> " :\n"
 136                                       <> "count : " <> show (length lst) <> " potential edges (" <> show (length $ filter (>= thr) lst) <> " >= " <> show (thr) <> ")\n"
 137                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 138                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 139                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 140                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") g
 141   where
 142     lst = sort $ map snd $ concat $ map snd g
 143
 144
 145 traceGraphFiltered :: Level -> [([GroupNode],[GroupEdge])] -> [([GroupNode],[GroupEdge])]
 146 traceGraphFiltered lvl g = trace ( "----\nClustering in Phylo" <> show (lvl) <> " :\n"
 147                                       <> "count : " <> show (length lst) <> " edges\n"
 148                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 149                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 150                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 151                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") g
 152   where
 153     lst = sort $ map snd $ concat $ map snd g