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, tails, delete, nub)
  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 filter some PhyloEdges with a given threshold
 121 filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
 122 filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges
 123
 124
 125 -- | To get the PhyloGroups Childs of a PhyloGroup
 126 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
 127 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
 128
 129
 130 -- | To get the id of a PhyloGroup
 131 getGroupId :: PhyloGroup -> PhyloGroupId
 132 getGroupId = _phylo_groupId
 133
 134
 135 -- | To get the Cooc Matrix of a PhyloGroup
 136 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
 137 getGroupCooc = _phylo_groupCooc
 138
 139
 140 -- | To get the level out of the id of a PhyloGroup
 141 getGroupLevel :: PhyloGroup -> Int
 142 getGroupLevel = snd . fst . getGroupId
 143
 144
 145 -- | To get the Ngrams of a PhyloGroup
 146 getGroupNgrams :: PhyloGroup -> [Int]
 147 getGroupNgrams =  _phylo_groupNgrams
 148
 149
 150 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
 151 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
 152 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
 153
 154
 155 -- | To get the PhyloGroups Parents of a PhyloGroup
 156 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
 157 getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
 158
 159
 160 -- | To get the period out of the id of a PhyloGroup
 161 getGroupPeriod :: PhyloGroup -> (Date,Date)
 162 getGroupPeriod = fst . fst . getGroupId
 163
 164
 165 -- | To get all the PhyloGroup of a Phylo
 166 getGroups :: Phylo -> [PhyloGroup]
 167 getGroups = view ( phylo_periods
 168                  .  traverse
 169                  . phylo_periodLevels
 170                  .  traverse
 171                  . phylo_levelGroups
 172                  )
 173
 174
 175 -- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
 176 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 177 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 178
 179
 180 -- | To get all the PhyloGroup of a Phylo with a given level and period
 181 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 182 getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
 183                                  `intersect`
 184                                  (getGroupsWithPeriod prd p)
 185
 186
 187 -- | To get all the PhyloGroup of a Phylo with a given Level
 188 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
 189 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
 190
 191
 192 -- | To get all the PhyloGroup of a Phylo with a given Period
 193 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
 194 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
 195
 196
 197 -- | To get the index of an element of a Vector
 198 getIdx :: Eq a => a -> Vector a -> Int
 199 getIdx x v = case (elemIndex x v) of
 200               Nothing -> panic "[ERR][Viz.Phylo.Tools.getIndex] Nothing"
 201               Just i  -> i
 202
 203
 204 -- | To get the label of a Level
 205 getLevelLabel :: Level -> LevelLabel
 206 getLevelLabel lvl = _levelLabel lvl
 207
 208
 209 -- | To get the value of a Level
 210 getLevelValue :: Level -> Int
 211 getLevelValue lvl = _levelValue lvl
 212
 213
 214 -- | To get the label of a LevelLink based on a Direction
 215 getLevelLinkLabel :: Direction -> LevelLink -> LevelLabel
 216 getLevelLinkLabel dir link = case dir of
 217     From -> view (levelFrom . levelLabel) link
 218     To   -> view (levelTo   . levelLabel) link
 219     _    -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkLabel] Wrong direction"
 220
 221
 222 -- | To get the value of a LevelLink based on a Direction
 223 getLevelLinkValue :: Direction -> LevelLink -> Int
 224 getLevelLinkValue dir link = case dir of
 225     From -> view (levelFrom . levelValue) link
 226     To   -> view (levelTo   . levelValue) link
 227     _    -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkValue] Wrong direction"
 228
 229
 230 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges
 231 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
 232 getNeighbours directed g e = case directed of
 233   True  -> map (\((s,t),w) -> t)
 234              $ filter (\((s,t),w) -> s == g) e
 235   False -> map (\((s,t),w) -> head $ delete g $ nub [s,t,g])
 236              $ filter (\((s,t),w) -> s == g || t == g) e
 237
 238
 239 -- | To get the Branches of a Phylo
 240 getPhyloBranches :: Phylo -> [PhyloBranch]
 241 getPhyloBranches = _phylo_branches
 242
 243
 244 -- | To get all the Phylolevels of a given PhyloPeriod
 245 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 246 getPhyloLevels = view (phylo_periodLevels)
 247
 248
 249 -- | To get the Ngrams of a Phylo
 250 getPhyloNgrams :: Phylo -> PhyloNgrams
 251 getPhyloNgrams = _phylo_ngrams
 252
 253
 254 -- | To get all the PhyloPeriodIds of a Phylo
 255 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
 256 getPhyloPeriods p = map _phylo_periodId
 257                   $ view (phylo_periods) p
 258
 259
 260 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
 261 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 262 initGroup ngrams lbl idx lvl from to p = PhyloGroup
 263   (((from, to), lvl), idx)
 264   lbl
 265   (sort $ map (\x -> ngramsToIdx x p) ngrams)
 266   (Map.empty)
 267   (Map.empty)
 268   [] [] [] []
 269
 270
 271 -- | To create a Level
 272 initLevel :: Int -> LevelLabel -> Level
 273 initLevel lvl lbl = Level lbl lvl
 274
 275
 276 -- | To create a LevelLink
 277 initLevelLink :: Level -> Level -> LevelLink
 278 initLevelLink lvl lvl' = LevelLink lvl lvl'
 279
 280
 281 -- | To create a PhyloLevel
 282 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
 283 initPhyloLevel id groups = PhyloLevel id groups
 284
 285
 286 -- | To create a PhyloPeriod
 287 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 288 initPhyloPeriod id l = PhyloPeriod id l
 289
 290
 291 -- | To get all combinations of a list
 292 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 293 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 294
 295
 296 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 297 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 298 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 299
 300
 301 -- | To get all combinations of a list with no repetition
 302 listToUnDirectedCombi :: [a] -> [(a,a)]
 303 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 304
 305
 306 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 307 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 308 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 309
 310
 311 -- | To transform an Ngrams into its corresponding index in a Phylo
 312 ngramsToIdx :: Ngrams -> Phylo -> Int
 313 ngramsToIdx x p = getIdx x (_phylo_ngrams p)
 314
 315
 316 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
 317 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
 318 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
 319     = PhyloLevel (id, lvl') groups'
 320         where
 321             groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
 322
 323
 324 -- | To choose a LevelLink strategy based an a given Level
 325 shouldLink :: LevelLink -> [Int] -> [Int] -> Bool
 326 shouldLink lvl l l'
 327   | from <= 1 = doesContainsOrd l l'
 328   | from > 1  = undefined
 329   | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined")
 330   where
 331     --------------------------------------
 332     from :: Int
 333     from = getLevelLinkValue From lvl
 334     --------------------------------------
 335
 336
 337 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 338 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 339 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 340                                            then (y,x)
 341                                            else (x,y) ) m1