src/Gargantext/Viz/Phylo/PhyloTools.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.PhyloTools
   3 Description : Module dedicated to all the tools needed for making 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 FlexibleContexts  #-}
  12 {-# LANGUAGE NoImplicitPrelude #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14 {-# LANGUAGE RankNTypes        #-}
  15 {-# LANGUAGE ViewPatterns      #-}
  16
  17 module Gargantext.Viz.Phylo.PhyloTools where
  18
  19 import Data.Vector (Vector, elemIndex)
  20 import Data.List (sort, concat, null, union, (++), tails, sortOn)
  21 import Data.Set (size)
  22 import Data.Map (Map, elems, fromList, unionWith, keys)
  23 import Data.String (String)
  24
  25 import Gargantext.Prelude
  26 import Gargantext.Viz.AdaptativePhylo
  27
  28 import Debug.Trace (trace)
  29 import Control.Lens
  30
  31 import qualified Data.Vector as Vector
  32
  33 --------------
  34 -- | Misc | --
  35 --------------
  36
  37
  38 countSup :: Double -> [Double] -> Int
  39 countSup s l = length $ filter (>s) l
  40
  41
  42 ---------------------
  43 -- | Foundations | --
  44 ---------------------
  45
  46
  47 -- | Is this Ngrams a Foundations Root ?
  48 isRoots :: Ngrams -> Vector Ngrams -> Bool
  49 isRoots n ns = Vector.elem n ns
  50
  51 -- | To transform a list of nrams into a list of foundation's index
  52 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
  53 ngramsToIdx ns fdt = map (\n -> fromJust $ elemIndex n fdt) ns
  54
  55
  56 --------------
  57 -- | Time | --
  58 --------------
  59
  60
  61 findBounds :: [Date] -> (Date,Date)
  62 findBounds dates =
  63     let dates' = sort dates
  64     in  (head' "findBounds" dates', last' "findBounds" dates')
  65
  66
  67 toPeriods :: [Date] -> Int -> Int -> [(Date,Date)]
  68 toPeriods dates p s =
  69     let (start,end) = findBounds dates
  70     in map (\dates' -> (head' "toPeriods" dates', last' "toPeriods" dates'))
  71      $ chunkAlong p s [start .. end]
  72
  73
  74 -- | Get a regular & ascendante timeScale from a given list of dates
  75 toTimeScale :: [Date] -> Int -> [Date]
  76 toTimeScale dates step =
  77     let (start,end) = findBounds dates
  78     in  [start, (start + step) .. end]
  79
  80
  81 -------------
  82 -- | Fis | --
  83 -------------
  84
  85
  86 -- | To find if l' is nested in l
  87 isNested :: Eq a => [a] -> [a] -> Bool
  88 isNested l l'
  89   | null l'               = True
  90   | length l' > length l  = False
  91   | (union  l l') == l    = True
  92   | otherwise             = False
  93
  94
  95 -- | To filter Fis with small Support but by keeping non empty Periods
  96 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
  97 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
  98                      then keepFilled f (thr - 1) l
  99                      else f thr l
 100
 101
 102 traceClique :: Map (Date, Date) [PhyloFis] -> String
 103 traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
 104     where
 105         --------------------------------------
 106         cliques :: [Double]
 107         cliques = sort $ map (fromIntegral . size . _phyloFis_clique) $ concat $ elems mFis
 108         --------------------------------------
 109
 110
 111 traceSupport :: Map (Date, Date) [PhyloFis] -> String
 112 traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
 113     where
 114         --------------------------------------
 115         supports :: [Double]
 116         supports = sort $ map (fromIntegral . _phyloFis_support) $ concat $ elems mFis
 117         --------------------------------------
 118
 119
 120 traceFis :: [Char] -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
 121 traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
 122                          <> "Support : " <> (traceSupport mFis) <> "\n"
 123                          <> "Clique : "  <> (traceClique mFis)  <> "\n" ) mFis
 124
 125
 126 --------------
 127 -- | Cooc | --
 128 --------------
 129
 130
 131 listToCombi' :: [a] -> [(a,a)]
 132 listToCombi' l = [(x,y) | (x:rest) <- tails l,  y <- rest]
 133
 134 listToEqual' :: Eq a => [a] -> [(a,a)]
 135 listToEqual' l = [(x,y) | x <- l, y <- l, x == y]
 136
 137 listToKeys :: [Int] -> [(Int,Int)]
 138 listToKeys lst = (listToCombi' lst) ++ (listToEqual' lst)
 139
 140 listToMatrix :: [Int] -> Map (Int,Int) Double
 141 listToMatrix lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
 142
 143 sumCooc :: Cooc -> Cooc -> Cooc
 144 sumCooc cooc cooc' = unionWith (+) cooc cooc'
 145
 146
 147 ---------------
 148 -- | Phylo | --
 149 ---------------
 150
 151 getPeriodIds :: Phylo -> [(Date,Date)]
 152 getPeriodIds phylo = sortOn fst
 153                    $ keys
 154                    $ phylo ^. phylo_periods
 155
 156
 157 getConfig :: Phylo -> Config
 158 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
 159
 160
 161 getRoots :: Phylo -> Vector Ngrams
 162 getRoots phylo = (phylo ^. phylo_foundations) ^. foundations_roots