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