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