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