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 foundations of a Phylo
 122 getFoundations :: Phylo -> Vector Ngrams
 123 getFoundations = _phylo_foundations
 124
 125
 126 -- | To get the Index of a Ngrams in the Foundations of a Phylo
 127 getIdxInFoundations :: Ngrams -> Phylo -> Int
 128 getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
 129     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getFoundationIdx] Ngrams not in Foundations"
 130     Just idx -> idx
 131
 132
 133 -- | To get the PhyloGroups Childs of a PhyloGroup
 134 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
 135 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
 136
 137
 138 -- | To get the id of a PhyloGroup
 139 getGroupId :: PhyloGroup -> PhyloGroupId
 140 getGroupId = _phylo_groupId
 141
 142
 143 -- | To get the Cooc Matrix of a PhyloGroup
 144 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
 145 getGroupCooc = _phylo_groupCooc
 146
 147
 148 -- | To get the level out of the id of a PhyloGroup
 149 getGroupLevel :: PhyloGroup -> Int
 150 getGroupLevel = snd . fst . getGroupId
 151
 152
 153 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
 154 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
 155 getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
 156
 157
 158 -- | To get the Ngrams of a PhyloGroup
 159 getGroupNgrams :: PhyloGroup -> [Int]
 160 getGroupNgrams =  _phylo_groupNgrams
 161
 162
 163 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
 164 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
 165 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
 166
 167
 168 -- | To get the PhyloGroups Parents of a PhyloGroup
 169 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
 170 getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
 171
 172
 173 -- | To get the period out of the id of a PhyloGroup
 174 getGroupPeriod :: PhyloGroup -> (Date,Date)
 175 getGroupPeriod = fst . fst . getGroupId
 176
 177
 178 -- | To get all the PhyloGroup of a Phylo
 179 getGroups :: Phylo -> [PhyloGroup]
 180 getGroups = view ( phylo_periods
 181                  .  traverse
 182                  . phylo_periodLevels
 183                  .  traverse
 184                  . phylo_levelGroups
 185                  )
 186
 187
 188 -- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
 189 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 190 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 191
 192
 193 -- | To get all the PhyloGroup of a Phylo with a given level and period
 194 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 195 getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
 196                                  `intersect`
 197                                  (getGroupsWithPeriod prd p)
 198
 199
 200 -- | To get all the PhyloGroup of a Phylo with a given Level
 201 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
 202 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
 203
 204
 205 -- | To get all the PhyloGroup of a Phylo with a given Period
 206 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
 207 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
 208
 209
 210 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
 211 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
 212 getKeyPair (x,y) m = case findPair (x,y) m of
 213                       Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
 214                       Just i  -> i
 215                      where
 216                       --------------------------------------
 217                       findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
 218                       findPair (x,y) m
 219                         | member (x,y) m = Just (x,y)
 220                         | member (y,x) m = Just (y,x)
 221                         | otherwise      = Nothing
 222                       --------------------------------------
 223
 224
 225 -- | To get the last computed Level in a Phylo
 226 getLastLevel :: Phylo -> Level
 227 getLastLevel p = (last . sort)
 228                $ map (snd . getPhyloLevelId)
 229                $ view ( phylo_periods
 230                       .  traverse
 231                       . phylo_periodLevels ) p
 232
 233
 234 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges
 235 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
 236 getNeighbours directed g e = case directed of
 237   True  -> map (\((s,t),w) -> t)
 238              $ filter (\((s,t),w) -> s == g) e
 239   False -> map (\((s,t),w) -> head $ delete g $ nub [s,t,g])
 240              $ filter (\((s,t),w) -> s == g || t == g) e
 241
 242
 243 -- | To get the Branches of a Phylo
 244 -- getPhyloBranches :: Phylo -> [PhyloBranch]
 245 -- getPhyloBranches = _phylo_branches
 246
 247
 248 -- | To get the PhylolevelId of a given PhyloLevel
 249 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
 250 getPhyloLevelId = _phylo_levelId
 251
 252
 253 -- | To get all the Phylolevels of a given PhyloPeriod
 254 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 255 getPhyloLevels = view (phylo_periodLevels)
 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 init the foundation of the Phylo as a Vector of Ngrams
 270 initFoundations :: [Ngrams] -> Vector Ngrams
 271 initFoundations l = Vector.fromList $ map toLower l
 272
 273
 274 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
 275 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 276 initGroup ngrams lbl idx lvl from to p = PhyloGroup
 277   (((from, to), lvl), idx)
 278   lbl
 279   (sort $ map (\x -> getIdxInFoundations x p) ngrams)
 280   (Map.empty)
 281   (Map.empty)
 282   [] [] [] []
 283
 284
 285 -- | To init the Base of a Phylo from a List of Periods and Foundations
 286 initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> Phylo
 287 initPhyloBase pds fds = Phylo ((fst . head) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds)
 288
 289
 290 -- | To create a PhyloLevel
 291 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
 292 initPhyloLevel id groups = PhyloLevel id groups
 293
 294
 295 -- | To create a PhyloPeriod
 296 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 297 initPhyloPeriod id l = PhyloPeriod id l
 298
 299
 300 -- | To filter Fis with small Support but by keeping non empty Periods
 301 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
 302 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
 303                      then keepFilled f (thr - 1) l
 304                      else f thr l
 305
 306
 307 -- | To get all combinations of a list
 308 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 309 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 310
 311
 312 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 313 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 314 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 315
 316
 317 -- | To get all combinations of a list with no repetition
 318 listToUnDirectedCombi :: [a] -> [(a,a)]
 319 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 320
 321
 322 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 323 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 324 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 325
 326
 327 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
 328 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
 329 setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
 330     = PhyloLevel (id, lvl') groups'
 331         where
 332             groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
 333
 334
 335 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 336 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 337 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 338                                            then (y,x)
 339                                            else (x,y) ) m1