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