src/Gargantext/Viz/Phylo/Tools.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.Tools
  18   where
  19
  20 import Control.Lens         hiding (both, Level)
  21 import Data.List            (filter, intersect, (++), sort, null, head, tail, last)
  22 import Data.Map             (Map)
  23 import Data.Set             (Set)
  24 import Data.Text            (Text)
  25 import Data.Tuple.Extra
  26 import Data.Vector          (Vector,elemIndex)
  27 import Gargantext.Prelude   hiding (head)
  28 import Gargantext.Viz.Phylo
  29
  30 import qualified Data.List  as List
  31 import qualified Data.Map   as Map
  32 import qualified Data.Set   as Set
  33
  34
  35 ------------------------------------------------------------------------
  36 -- | Tools | --
  37
  38
  39 -- | To add a PhyloLevel at the end of a list of PhyloLevels
  40 addPhyloLevel :: PhyloLevel -> [PhyloLevel] -> [PhyloLevel]
  41 addPhyloLevel lvl l = l ++ [lvl]
  42
  43
  44 -- | To alter each list of PhyloGroups following a given function
  45 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
  46 alterPhyloGroups f p = over ( phylo_periods
  47                             .  traverse
  48                             . phylo_periodLevels
  49                             .  traverse
  50                             . phylo_levelGroups
  51                             ) f p
  52
  53
  54 -- | To alter each PhyloPeriod of a Phylo following a given function
  55 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
  56 alterPhyloPeriods f p = over ( phylo_periods
  57                              .  traverse) f p
  58
  59
  60 -- | To alter a list of PhyloLevels following a given function
  61 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
  62 alterPhyloLevels f p = over ( phylo_periods
  63                             .  traverse
  64                             . phylo_periodLevels) f p
  65
  66
  67 -- | To append a list of PhyloPeriod to a Phylo
  68 appendPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
  69 appendPhyloPeriods l p = over (phylo_periods) (++ l) p
  70
  71
  72 -- | Does a List of Sets contains at least one Set of an other List
  73 doesAnySetContains :: Eq a =>  Set a -> [Set a] -> [Set a] -> Bool
  74 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
  75
  76
  77 -- | Does a list of A contains an other list of A
  78 doesContains :: Eq a => [a] -> [a] -> Bool
  79 doesContains l l'
  80   | null l'               = True
  81   | length l' > length l  = False
  82   | elem (head l') l      = doesContains l (tail l')
  83   | otherwise             = False
  84
  85
  86 -- | Does a list of ordered A contains an other list of ordered A
  87 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
  88 doesContainsOrd l l'
  89   | null l'          = False
  90   | last l < head l' = False
  91   | head l' `elem` l = True
  92   | otherwise        = doesContainsOrd l (tail l')
  93
  94
  95  -- | To filter the PhyloGroup of a Phylo according to a function and a value
  96 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> Phylo -> [PhyloGroup]
  97 filterGroups f x p = filter (\g -> (f g) == x) (getGroups p)
  98
  99
 100 -- | To filter nested Sets of a
 101 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
 102 filterNestedSets h l l'
 103   | null l                 = if doesAnySetContains h l l'
 104                              then l'
 105                              else h : l'
 106   | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
 107   | otherwise              = filterNestedSets (head l) (tail l) (h : l')
 108
 109
 110 -- | To get the id of a PhyloGroup
 111 getGroupId :: PhyloGroup -> PhyloGroupId
 112 getGroupId = _phylo_groupId
 113
 114
 115 -- | To get the level out of the id of a PhyloGroup
 116 getGroupLevel :: PhyloGroup -> Int
 117 getGroupLevel = snd . fst . getGroupId
 118
 119
 120 -- | To get the Ngrams of a PhyloGroup
 121 getGroupNgrams :: PhyloGroup -> [Int]
 122 getGroupNgrams =  _phylo_groupNgrams
 123
 124
 125 -- | To get the period out of the id of a PhyloGroup
 126 getGroupPeriod :: PhyloGroup -> (Date,Date)
 127 getGroupPeriod = fst . fst . getGroupId
 128
 129
 130 -- | To get all the PhyloGroup of a Phylo
 131 getGroups :: Phylo -> [PhyloGroup]
 132 getGroups = view ( phylo_periods
 133                  .  traverse
 134                  . phylo_periodLevels
 135                  .  traverse
 136                  . phylo_levelGroups
 137                  )
 138
 139
 140 -- | To get all the PhyloGroup of a Phylo with a given level and period
 141 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 142 getGroupsWithFilters lvl prd p = (filterGroups getGroupLevel lvl p)
 143                                  `intersect`
 144                                  (filterGroups getGroupPeriod prd p)
 145
 146
 147 -- | To get the index of an element of a Vector
 148 getIdx :: Eq a => a -> Vector a -> Int
 149 getIdx x v = case (elemIndex x v) of
 150               Nothing -> panic "[ERR][Viz.Phylo.Tools.getIndex] Nothing"
 151               Just i  -> i
 152
 153
 154 -- | To get the label of a Level
 155 getLevelLabel :: Level -> LevelLabel
 156 getLevelLabel lvl = _levelLabel lvl
 157
 158
 159 -- | To get the value of a Level
 160 getLevelValue :: Level -> Int
 161 getLevelValue lvl = _levelValue lvl
 162
 163
 164 -- | To get the label of a LevelLink based on a Direction
 165 getLevelLinkLabel :: Direction -> LevelLink -> LevelLabel
 166 getLevelLinkLabel dir link = case dir of
 167     From -> view (levelFrom . levelLabel) link
 168     To   -> view (levelTo   . levelLabel) link
 169     _    -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkLabel] Wrong direction"
 170
 171
 172 -- | To get the value of a LevelLink based on a Direction
 173 getLevelLinkValue :: Direction -> LevelLink -> Int
 174 getLevelLinkValue dir link = case dir of
 175     From -> view (levelFrom . levelValue) link
 176     To   -> view (levelTo   . levelValue) link
 177     _    -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkValue] Wrong direction"
 178
 179
 180 -- | To get all the Phylolevels of a given PhyloPeriod
 181 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 182 getPhyloLevels = view (phylo_periodLevels)
 183
 184
 185 -- | To get the Ngrams of a Phylo
 186 getPhyloNgrams :: Phylo -> PhyloNgrams
 187 getPhyloNgrams = _phylo_ngrams
 188
 189
 190 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
 191 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 192 initGroup ngrams lbl idx lvl from to p = PhyloGroup
 193   (((from, to), lvl), idx)
 194   lbl
 195   (sort $ map (\x -> ngramsToIdx x p) ngrams)
 196   (Map.empty)
 197   [] [] [] []
 198
 199
 200 -- | To create a Level
 201 initLevel :: Int -> LevelLabel -> Level
 202 initLevel lvl lbl = Level lbl lvl
 203
 204
 205 -- | To create a LevelLink
 206 initLevelLink :: Level -> Level -> LevelLink
 207 initLevelLink lvl lvl' = LevelLink lvl lvl'
 208
 209
 210 -- | To create a PhyloLevel
 211 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
 212 initPhyloLevel id groups = PhyloLevel id groups
 213
 214
 215 -- | To create a PhyloPeriod
 216 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 217 initPhyloPeriod id l = PhyloPeriod id l
 218
 219
 220 -- | To transform an Ngrams into its corresponding index in a Phylo
 221 ngramsToIdx :: Ngrams -> Phylo -> Int
 222 ngramsToIdx x p = getIdx x (_phylo_ngrams p)
 223
 224
 225 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
 226 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
 227 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
 228     = PhyloLevel (id, lvl') groups'
 229         where
 230             groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
 231
 232
 233 -- | To choose a LevelLink strategy based an a given Level
 234 shouldLink :: LevelLink -> [Int] -> [Int] -> Bool
 235 shouldLink lvl l l'
 236   | from <= 1 = doesContainsOrd l l'
 237   | from > 1  = undefined
 238   | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined")
 239   where
 240     --------------------------------------
 241     from :: Int
 242     from = getLevelLinkValue From lvl
 243     --------------------------------------