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, concat, union)
  22 import Data.Map             (Map, mapKeys, member, elems, adjust)
  23 import Data.Set             (Set)
  24 import Data.Text            (Text, toLower)
  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 import qualified Data.Vector as Vector
  34
  35
  36 ------------------------------------------------------------------------
  37 -- | Tools | --
  38
  39
  40 -- | To add a new PhyloGroupId to a PhyloBranch
  41 addGroupIdToBranch :: PhyloGroupId -> PhyloBranch -> PhyloBranch
  42 addGroupIdToBranch id b = over (phylo_branchGroups) (++ [id]) b
  43
  44
  45 -- | To alter each list of PhyloGroups following a given function
  46 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
  47 alterPhyloGroups f p = over ( phylo_periods
  48                             .  traverse
  49                             . phylo_periodLevels
  50                             .  traverse
  51                             . phylo_levelGroups
  52                             ) f p
  53
  54
  55 -- | To alter each PhyloPeriod of a Phylo following a given function
  56 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
  57 alterPhyloPeriods f p = over ( phylo_periods
  58                              .  traverse) f p
  59
  60
  61 -- | To alter the list of PhyloBranches of a Phylo
  62 alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
  63 alterPhyloBranches f p = over ( phylo_branches ) f p
  64
  65
  66 -- | To alter a list of PhyloLevels following a given function
  67 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
  68 alterPhyloLevels f p = over ( phylo_periods
  69                             .  traverse
  70                             . phylo_periodLevels) f p
  71
  72
  73 -- | To append a list of PhyloPeriod to a Phylo
  74 appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
  75 appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
  76
  77
  78 -- | Does a List of Sets contains at least one Set of an other List
  79 doesAnySetContains :: Eq a =>  Set a -> [Set a] -> [Set a] -> Bool
  80 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
  81
  82
  83 -- | Does a list of A contains an other list of A
  84 doesContains :: Eq a => [a] -> [a] -> Bool
  85 doesContains l l'
  86   | null l'               = True
  87   | length l' > length l  = False
  88   | elem (head l') l      = doesContains l (tail l')
  89   | otherwise             = False
  90
  91
  92 -- | Does a list of ordered A contains an other list of ordered A
  93 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
  94 doesContainsOrd l l'
  95   | null l'          = False
  96   | last l < head l' = False
  97   | head l' `elem` l = True
  98   | otherwise        = doesContainsOrd l (tail l')
  99
 100
 101  -- | To filter the PhyloGroup of a Phylo according to a function and a value
 102 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
 103 filterGroups f x l = filter (\g -> (f g) == x) l
 104
 105
 106 -- | To filter nested Sets of a
 107 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
 108 filterNestedSets h l l'
 109   | null l                 = if doesAnySetContains h l l'
 110                              then l'
 111                              else h : l'
 112   | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
 113   | otherwise              = filterNestedSets (head l) (tail l) (h : l')
 114
 115
 116 -- | To filter some PhyloEdges with a given threshold
 117 filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
 118 filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges
 119
 120
 121 -- | To get the PhyloGroups Childs of a PhyloGroup
 122 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
 123 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
 124
 125
 126 -- | To get the id of a PhyloGroup
 127 getGroupId :: PhyloGroup -> PhyloGroupId
 128 getGroupId = _phylo_groupId
 129
 130
 131 -- | To get the Cooc Matrix of a PhyloGroup
 132 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
 133 getGroupCooc = _phylo_groupCooc
 134
 135
 136 -- | To get the level out of the id of a PhyloGroup
 137 getGroupLevel :: PhyloGroup -> Int
 138 getGroupLevel = snd . fst . getGroupId
 139
 140
 141 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
 142 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
 143 getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
 144
 145
 146 -- | To get the Ngrams of a PhyloGroup
 147 getGroupNgrams :: PhyloGroup -> [Int]
 148 getGroupNgrams =  _phylo_groupNgrams
 149
 150
 151 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
 152 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
 153 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
 154
 155
 156 -- | To get the PhyloGroups Parents of a PhyloGroup
 157 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
 158 getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
 159
 160
 161 -- | To get the period out of the id of a PhyloGroup
 162 getGroupPeriod :: PhyloGroup -> (Date,Date)
 163 getGroupPeriod = fst . fst . getGroupId
 164
 165
 166 -- | To get all the PhyloGroup of a Phylo
 167 getGroups :: Phylo -> [PhyloGroup]
 168 getGroups = view ( phylo_periods
 169                  .  traverse
 170                  . phylo_periodLevels
 171                  .  traverse
 172                  . phylo_levelGroups
 173                  )
 174
 175
 176 -- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
 177 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 178 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 179
 180
 181 -- | To get all the PhyloGroup of a Phylo with a given level and period
 182 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 183 getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
 184                                  `intersect`
 185                                  (getGroupsWithPeriod prd p)
 186
 187
 188 -- | To get all the PhyloGroup of a Phylo with a given Level
 189 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
 190 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
 191
 192
 193 -- | To get all the PhyloGroup of a Phylo with a given Period
 194 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
 195 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
 196
 197
 198 -- | To get the index of an element of a Vector
 199 getIdx :: Eq a => a -> Vector a -> Int
 200 getIdx x v = case (elemIndex x v) of
 201               Nothing -> panic "[ERR][Viz.Phylo.Tools.getIndex] Nothing"
 202               Just i  -> i
 203
 204
 205 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
 206 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
 207 getKeyPair (x,y) m = case findPair (x,y) m of
 208                       Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
 209                       Just i  -> i
 210                      where
 211                       --------------------------------------
 212                       findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
 213                       findPair (x,y) m
 214                         | member (x,y) m = Just (x,y)
 215                         | member (y,x) m = Just (y,x)
 216                         | otherwise      = Nothing
 217                       --------------------------------------
 218
 219
 220 -- | To get the last computed Level in a Phylo
 221 getLastLevel :: Phylo -> Level
 222 getLastLevel p = (last . sort)
 223                $ map (snd . getPhyloLevelId)
 224                $ view ( phylo_periods
 225                       .  traverse
 226                       . phylo_periodLevels ) p
 227
 228
 229 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges
 230 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
 231 getNeighbours directed g e = case directed of
 232   True  -> map (\((s,t),w) -> t)
 233              $ filter (\((s,t),w) -> s == g) e
 234   False -> map (\((s,t),w) -> head $ delete g $ nub [s,t,g])
 235              $ filter (\((s,t),w) -> s == g || t == g) e
 236
 237
 238 -- | To get the Branches of a Phylo
 239 getPhyloBranches :: Phylo -> [PhyloBranch]
 240 getPhyloBranches = _phylo_branches
 241
 242
 243 -- | To get the PhylolevelId of a given PhyloLevel
 244 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
 245 getPhyloLevelId = _phylo_levelId
 246
 247
 248 -- | To get all the Phylolevels of a given PhyloPeriod
 249 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 250 getPhyloLevels = view (phylo_periodLevels)
 251
 252
 253 -- | To get the Ngrams of a Phylo
 254 getPhyloNgrams :: Phylo -> PhyloNgrams
 255 getPhyloNgrams = _phylo_ngrams
 256
 257
 258 -- | To get all the PhyloPeriodIds of a Phylo
 259 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
 260 getPhyloPeriods p = map _phylo_periodId
 261                   $ view (phylo_periods) p
 262
 263
 264 -- | To get the id of a given PhyloPeriod
 265 getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
 266 getPhyloPeriodId prd = _phylo_periodId prd
 267
 268
 269 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
 270 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 271 initGroup ngrams lbl idx lvl from to p = PhyloGroup
 272   (((from, to), lvl), idx)
 273   lbl
 274   (sort $ map (\x -> ngramsToIdx x p) ngrams)
 275   (Map.empty)
 276   (Map.empty)
 277   [] [] [] []
 278
 279
 280 -- | To init a PhyloNgrams as a Vector of Ngrams
 281 initNgrams :: [Ngrams] -> PhyloNgrams
 282 initNgrams l = Vector.fromList $ map toLower l
 283
 284
 285 -- | To create a Phylo from a list of PhyloPeriods and Ngrams
 286 initPhylo :: [(Date, Date)] -> PhyloNgrams -> Phylo
 287 initPhylo l ngrams = Phylo ((fst . head) l, (snd . last) l) ngrams (map (\prd -> initPhyloPeriod prd []) l) []
 288
 289 -- | To create a PhyloLevel
 290 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
 291 initPhyloLevel id groups = PhyloLevel id groups
 292
 293
 294 -- | To create a PhyloPeriod
 295 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 296 initPhyloPeriod id l = PhyloPeriod id l
 297
 298
 299 -- | To filter Fis with small Support but by keeping non empty Periods
 300 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
 301 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
 302                      then keepFilled f (thr - 1) l
 303                      else f thr l
 304
 305
 306 -- | To get all combinations of a list
 307 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 308 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 309
 310
 311 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 312 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 313 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 314
 315
 316 -- | To get all combinations of a list with no repetition
 317 listToUnDirectedCombi :: [a] -> [(a,a)]
 318 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 319
 320
 321 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 322 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 323 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 324
 325
 326 -- | To transform an Ngrams into its corresponding index in a Phylo
 327 ngramsToIdx :: Ngrams -> Phylo -> Int
 328 ngramsToIdx x p = getIdx x (_phylo_ngrams p)
 329
 330
 331 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
 332 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
 333 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
 334     = PhyloLevel (id, lvl') groups'
 335         where
 336             groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
 337
 338
 339 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 340 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 341 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 342                                            then (y,x)
 343                                            else (x,y) ) m1