src/Gargantext/Viz/Phylo/Aggregates/Cluster.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.Aggregates.Cluster
  18   where
  19
  20 import Data.List        (null,tail,concat,sort,intersect)
  21 import Data.Map         (Map)
  22 import Data.Tuple       (fst)
  23 import Gargantext.Prelude
  24 import Gargantext.Viz.Phylo
  25 import Gargantext.Viz.Phylo.Tools
  26 import Gargantext.Viz.Phylo.Metrics.Proximity
  27 import Gargantext.Viz.Phylo.Metrics.Clustering
  28 import Gargantext.Viz.Phylo.LinkMaker
  29 import qualified Data.Map    as Map
  30
  31 import qualified Data.Vector.Storable as VS
  32 import Debug.Trace (trace)
  33 import Numeric.Statistics (percentile)
  34
  35
  36 -- | Optimisation to filter only relevant candidates
  37 getCandidates :: [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
  38 getCandidates gs = filter (\(g,g') -> (not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))
  39                  $ filter (\(g,g') -> g /= g')
  40                  $ listToDirectedCombi gs
  41
  42
  43 -- | To transform a Graph into Clusters
  44 graphToClusters :: Cluster -> GroupGraph -> [PhyloCluster]
  45 graphToClusters clust (nodes,edges) = case clust of
  46       Louvain (LouvainParams _)      -> undefined
  47       RelatedComponents (RCParams _) -> relatedComp 0 (head' "graphToClusters" nodes) (tail nodes,edges) [] []
  48       _                              -> panic "[ERR][Viz.Phylo.Aggregates.Cluster.graphToClusters] not implemented"
  49
  50
  51 -- | To transform a list of PhyloGroups into a Graph of Proximity
  52 groupsToGraph :: Double -> Proximity -> [PhyloGroup] -> ([GroupNode],[GroupEdge])
  53 groupsToGraph nbDocs prox gs = case prox of
  54       WeightedLogJaccard (WLJParams _ sens) -> (gs, map (\(x,y) -> ((x,y), weightedLogJaccard sens (getGroupCooc x) (getGroupCooc y) nbDocs))
  55                                                   $ getCandidates gs)
  56       Hamming (HammingParams _)             -> (gs, map (\(x,y) -> ((x,y), hamming (getGroupCooc x) (getGroupCooc y))) $ getCandidates gs)
  57       _                                     -> undefined
  58
  59
  60 -- | To filter a Graph of Proximity using a given threshold
  61 filterGraph :: Proximity -> ([GroupNode],[GroupEdge]) -> ([GroupNode],[GroupEdge])
  62 filterGraph prox (ns,es) = case prox of
  63       WeightedLogJaccard (WLJParams thr _) -> (ns, filter (\(_,v) -> v >= thr) es)
  64       Hamming (HammingParams thr)          -> (ns, filter (\(_,v) -> v <= thr) es)
  65       _                                    -> undefined
  66
  67
  68 -- | To clusterise a Phylo
  69 phyloToClusters :: Level -> Cluster -> Phylo -> Map (Date,Date) [PhyloCluster]
  70 phyloToClusters lvl clus p = Map.fromList
  71                             $ zip periods
  72                             $ map (\g -> if null (fst g)
  73                                          then []
  74                                          else graphToClusters clus g) graphs'
  75   where
  76     --------------------------------------
  77     graphs' :: [([GroupNode],[GroupEdge])]
  78     graphs' = traceGraphFiltered lvl
  79             $ map (\g -> filterGraph prox g) graphs
  80     --------------------------------------
  81     graphs  :: [([GroupNode],[GroupEdge])]
  82     graphs  = traceGraph lvl (getThreshold prox)
  83             $ map (\prd -> groupsToGraph (periodsToNbDocs [prd] p) prox (getGroupsWithFilters lvl prd p))
  84             $ trace (show(map (\prd -> (prd,length $ getGroupsWithFilters lvl prd p)) periods)) periods
  85     --------------------------------------
  86     prox :: Proximity
  87     prox = getProximity clus
  88     --------------------------------------
  89     periods :: [PhyloPeriodId]
  90     periods = getPhyloPeriods p
  91     --------------------------------------
  92
  93
  94 ----------------
  95 -- | Tracer | --
  96 ----------------
  97
  98
  99 traceGraph :: Level -> Double -> [([GroupNode],[GroupEdge])] -> [([GroupNode],[GroupEdge])]
 100 traceGraph lvl thr g = trace ( "----\nUnfiltered clustering in Phylo" <> show (lvl) <> " :\n"
 101                                       <> "count : " <> show (length lst) <> " potential edges (" <> show (length $ filter (>= thr) lst) <> " >= " <> show (thr) <> ")\n"
 102                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 103                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 104                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 105                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") g
 106   where
 107     lst = sort $ map snd $ concat $ map snd g
 108
 109
 110 traceGraphFiltered :: Level -> [([GroupNode],[GroupEdge])] -> [([GroupNode],[GroupEdge])]
 111 traceGraphFiltered lvl g = trace ( "----\nClustering in Phylo" <> show (lvl) <> " :\n"
 112                                       <> "count : " <> show (length lst) <> " edges\n"
 113                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 114                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 115                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 116                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") g
 117   where
 118     lst = sort $ map snd $ concat $ map snd g
 119
 120
 121 -- traceSim :: PhyloGroup -> PhyloGroup  -> Phylo -> Double -> Double
 122 -- traceSim g g' p sim = trace (show (getGroupText g p) <> " [vs] " <>  show (getGroupText g' p) <> " = " <> show (sim) <> "\n") sim