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