src/Gargantext/Viz/Phylo/Example.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Example
   3 Description : Phylomemy example based on history of Cleopatre.
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -- | Cesar et Cleôpatre
  11 -- Exemple de phylomemie
  12 -- French without accents
  13
  14
  15 TODO:
  16 - split the functions : RAW -> Document -> Ngrams
  17
  18 -- reverse history: antechronologique
  19 -- metrics support
  20
  21
  22 -}
  23
  24 {-# LANGUAGE NoImplicitPrelude #-}
  25 {-# LANGUAGE FlexibleContexts  #-}
  26 {-# LANGUAGE OverloadedStrings #-}
  27
  28 module Gargantext.Viz.Phylo.Example where
  29
  30 import Control.Lens     hiding (makeLenses, both, Level)
  31
  32 import Data.Bool        (Bool, not)
  33 import Data.List        (concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), nub)
  34 import Data.Map         (Map, elems, member, adjust, singleton, (!), keys, restrictKeys, mapWithKey)
  35 import Data.Semigroup   (Semigroup)
  36 import Data.Set         (Set)
  37 import Data.Text        (Text, unwords, toLower, words)
  38 import Data.Tuple       (fst, snd)
  39 import Data.Tuple.Extra
  40 import Data.Vector      (Vector, fromList, elemIndex)
  41
  42 import Gargantext.Prelude                      hiding (head)
  43 import Gargantext.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
  44 import Gargantext.Text.Terms.Mono              (monoTexts)
  45 import Gargantext.Viz.Phylo
  46 import Gargantext.Viz.Phylo.Tools
  47
  48 import qualified Data.Bool   as Bool
  49 import qualified Data.List   as List
  50 import qualified Data.Map    as Map
  51 import qualified Data.Maybe  as Maybe
  52 import qualified Data.Set    as Set
  53 import qualified Data.Tuple  as Tuple
  54 import qualified Data.Vector as Vector
  55
  56
  57 ------------------------------------------------------------------------
  58 -- | STEP 12 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
  59
  60
  61 ------------------------------------------------------------------------
  62 -- | STEP 11 | -- Cluster the Fis
  63
  64
  65 ------------------------------------------------------------------------
  66 -- | STEP 10 | -- Link the PhyloGroups of level 1 through the Periods
  67
  68
  69 -- | To pair two PhyloGroups sharing at leats one Ngrams
  70 shouldPair :: PhyloGroup -> PhyloGroup -> Bool
  71 shouldPair g g' = (not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g')
  72
  73
  74 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
  75 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
  76 getKeyPair (x,y) m = case findPair (x,y) m of
  77                       Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
  78                       Just i  -> i
  79                      where
  80                       --------------------------------------
  81                       findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
  82                       findPair (x,y) m
  83                         | member (x,y) m = Just (x,y)
  84                         | member (y,x) m = Just (y,x)
  85                         | otherwise      = Nothing
  86                       --------------------------------------
  87
  88
  89 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
  90 listToCombi :: forall a b. (a -> b) -> [a] -> [(b,b)]
  91 listToCombi f l = [ (f x, f y) | (x:rest) <- tails l
  92                                ,  y       <- rest ]
  93
  94
  95 -- | To transform the Fis into a coocurency Matrix in a Phylo
  96 fisToCooc :: Map (Date, Date) Fis -> Phylo -> Map (Int, Int) Double
  97 fisToCooc m p = map   (/docs)
  98               $ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc
  99               $ concat
 100               $ map (\x -> listToCombi (\x -> ngramsToIdx x p) $ (Set.toList . fst) x) fis
 101   where
 102     --------------------------------------
 103     fis :: [(Clique,Support)]
 104     fis = concat $ map (\x -> Map.toList x) (elems m)
 105     --------------------------------------
 106     fisNgrams :: [Ngrams]
 107     fisNgrams = foldl (\mem x -> union mem $ (Set.toList . fst) x) [] fis
 108     --------------------------------------
 109     docs :: Double
 110     docs = fromIntegral $ foldl (\mem x -> mem + (snd x)) 0 fis
 111     --------------------------------------
 112     cooc :: Map (Int, Int) (Double)
 113     cooc = Map.fromList $ map (\x -> (x,0)) (listToCombi (\x -> ngramsToIdx x p) fisNgrams)
 114     --------------------------------------
 115
 116
 117 phyloWithAppariement1 :: Phylo
 118 phyloWithAppariement1 = phyloLinked_0_1
 119
 120
 121 ------------------------------------------------------------------------
 122 -- | STEP 9 | -- Build level 1 of the Phylo
 123
 124
 125 -- | To Cliques into Groups
 126 cliqueToGroup :: PhyloPeriodId -> Int -> Int -> Ngrams -> (Clique,Support) -> Phylo -> PhyloGroup
 127 cliqueToGroup period lvl idx label fis p = PhyloGroup ((period, lvl), idx)
 128                                                     label
 129                                                     (sort $ map (\x -> ngramsToIdx x p)
 130                                                           $ Set.toList
 131                                                           $ fst fis
 132                                                           )
 133                                                     (singleton "support" (fromIntegral $ snd fis))
 134                                                     [] [] [] []
 135
 136
 137 -- | To transform Fis into PhyloLevels
 138 fisToPhyloLevel :: Map (Date, Date) Fis -> Phylo -> Phylo
 139 fisToPhyloLevel m p = over (phylo_periods . traverse)
 140                            (\period ->
 141                               let periodId = _phylo_periodId period
 142                                   fisList  = zip [1..] (Map.toList (m ! periodId))
 143                               in  over (phylo_periodLevels)
 144                                        (\levels ->
 145                                           let groups = map (\fis -> cliqueToGroup periodId 1 (fst fis) "" (snd fis) p) fisList
 146                                           in  levels ++ [PhyloLevel (periodId, 1) groups]
 147                                        ) period ) p
 148
 149
 150 phyloLinked_0_1 :: Phylo
 151 phyloLinked_0_1 = alterLevelLinks lvl_0_1  phyloLinked_1_0
 152
 153
 154 lvl_0_1 :: LevelLink
 155 lvl_0_1 = initLevelLink (initLevel 0 Level_0) (initLevel 1 Level_1)
 156
 157
 158 phyloLinked_1_0 :: Phylo
 159 phyloLinked_1_0 = alterLevelLinks lvl_1_0  phyloWithGroups1
 160
 161
 162 lvl_1_0 :: LevelLink
 163 lvl_1_0 = initLevelLink (initLevel 1 Level_1) (initLevel 0 Level_0)
 164
 165
 166 phyloWithGroups1 :: Phylo
 167 phyloWithGroups1 = updatePhyloByLevel (initLevel 1 Level_1) phyloLinked_m1_0
 168
 169
 170 ------------------------------------------------------------------------
 171 -- | STEP 8 | -- Create Frequent Items Sets by Period and filter them
 172
 173
 174 -- | To Filter Fis by support
 175 filterFisBySupport :: Bool -> Int -> Map (Date, Date) Fis -> Map (Date, Date) Fis
 176 filterFisBySupport empty min m = case empty of
 177   True  -> Map.map (\fis -> filterMinorFis min fis) m
 178   False -> Map.map (\fis -> filterMinorFisNonEmpty min fis) m
 179
 180
 181 -- | To filter Fis with small Support, to preserve nonempty periods please use : filterFisBySupport False
 182 filterMinorFis :: Int -> Fis -> Fis
 183 filterMinorFis min fis = Map.filter (\s -> s > min) fis
 184
 185
 186 -- | To filter Fis with small Support but by keeping non empty Periods
 187 filterMinorFisNonEmpty :: Int -> Fis -> Fis
 188 filterMinorFisNonEmpty min fis = if (Map.null fis') && (not $ Map.null fis)
 189                                  then filterMinorFisNonEmpty (min - 1) fis
 190                                  else fis'
 191   where
 192     --------------------------------------
 193     fis' :: Fis
 194     fis' = filterMinorFis min fis
 195     --------------------------------------
 196
 197
 198 -- | To filter nested Fis
 199 filterFisByNested :: Map (Date, Date) Fis -> Map (Date, Date) Fis
 200 filterFisByNested = map (\fis -> restrictKeys fis
 201                               $ Set.fromList
 202                               $ filterNestedSets (head (keys fis)) (keys fis) []
 203                             )
 204
 205
 206 -- | To transform a list of Documents into a Frequent Items Set
 207 docsToFis :: Map (Date, Date) [Document] -> Map (Date, Date) Fis
 208 docsToFis docs = map (\d -> fisWithSizePolyMap
 209                               (Segment 1 20)
 210                               1
 211                               (map (words . text) d)) docs
 212
 213
 214 phyloFisFiltered :: Map (Date, Date) Fis
 215 phyloFisFiltered = filterFisBySupport True 1 (filterFisByNested phyloFis)
 216
 217
 218 phyloFis :: Map (Date, Date) Fis
 219 phyloFis = docsToFis phyloPeriods
 220
 221
 222 ------------------------------------------------------------------------
 223 -- | STEP 7 | -- Link level -1 to level 0
 224
 225
 226 phyloLinked_m1_0 :: Phylo
 227 phyloLinked_m1_0 = alterLevelLinks lvl_m1_0  phyloLinked_0_m1
 228
 229
 230 lvl_m1_0 :: LevelLink
 231 lvl_m1_0 = initLevelLink (initLevel (-1) Level_m1) (initLevel 0 Level_0)
 232
 233
 234 ------------------------------------------------------------------------
 235 -- | STEP 6 | -- Link level 0 to level -1
 236
 237
 238 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
 239 linkGroupToGroups :: LevelLink -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
 240 linkGroupToGroups lvl current targets
 241   | getLevelLinkValue From lvl < getLevelLinkValue To lvl = setLevelParents current
 242   | getLevelLinkValue From lvl > getLevelLinkValue To lvl = setLevelChilds current
 243   | otherwise = current
 244   where
 245     --------------------------------------
 246     setLevelChilds :: PhyloGroup -> PhyloGroup
 247     setLevelChilds =  over (phylo_groupLevelChilds) addPointers
 248     --------------------------------------
 249     setLevelParents :: PhyloGroup -> PhyloGroup
 250     setLevelParents =  over (phylo_groupLevelParents) addPointers
 251     --------------------------------------
 252     addPointers :: [Pointer] -> [Pointer]
 253     addPointers lp = lp ++ Maybe.mapMaybe (\target ->
 254                                             if shouldLink lvl (_phylo_groupNgrams current)
 255                                                               (_phylo_groupNgrams target )
 256                                             then Just ((getGroupId target),1)
 257                                             else Nothing) targets
 258     --------------------------------------
 259
 260
 261 -- | To set the LevelLinks between two lists of PhyloGroups
 262 linkGroupsByLevel :: LevelLink -> Phylo -> [PhyloGroup] -> [PhyloGroup]
 263 linkGroupsByLevel lvl p groups  = map (\group ->
 264   if getGroupLevel group == getLevelLinkValue From lvl
 265   then linkGroupToGroups lvl group (getGroupsWithFilters (getLevelLinkValue To lvl) (getGroupPeriod group) p)
 266   else group ) groups
 267
 268
 269 -- | To set the LevelLink of all the PhyloGroups of a Phylo
 270 alterLevelLinks :: LevelLink -> Phylo -> Phylo
 271 alterLevelLinks lvl p = alterPhyloGroups (linkGroupsByLevel lvl p) p
 272
 273
 274 phyloLinked_0_m1 :: Phylo
 275 phyloLinked_0_m1 = alterLevelLinks lvl_0_m1  phyloWithGroups0
 276
 277
 278 lvl_0_m1 :: LevelLink
 279 lvl_0_m1 = initLevelLink (initLevel 0 Level_0) (initLevel (-1) Level_m1)
 280
 281
 282 ------------------------------------------------------------------------
 283 -- | STEP 5 | -- Build level 0 as a copy of level -1
 284
 285
 286 -- | To clone the last PhyloLevel of each PhyloPeriod and update it with a new LevelValue
 287 clonePhyloLevel :: Int -> Phylo -> Phylo
 288 clonePhyloLevel lvl p = alterPhyloLevels (\l -> addPhyloLevel
 289                                                (setPhyloLevelId lvl $ head l)
 290                                                l) p
 291
 292
 293 phyloWithGroups0 :: Phylo
 294 phyloWithGroups0 = updatePhyloByLevel (initLevel 0 Level_0) phyloWithGroupsm1
 295
 296
 297 ------------------------------------------------------------------------
 298 -- | STEP 4 | -- Build level -1
 299
 300
 301 -- | To transform a list of Documents into a PhyloLevel
 302 docsToPhyloLevel :: Int ->(Date, Date) -> [Document] -> Phylo -> PhyloLevel
 303 docsToPhyloLevel lvl (d, d') docs p = initPhyloLevel
 304                                         ((d, d'), lvl)
 305                                         (map (\(f,s) -> initGroup [s] s f lvl d d' p)
 306                                              $ zip [1..]
 307                                              $ (nub . concat)
 308                                              $ map (words . text) docs)
 309
 310
 311 -- | To transform a Map of Periods and Documents into a list of PhyloPeriods
 312 docsToPhyloPeriods :: Int -> Map (Date,Date) [Document] -> Phylo -> [PhyloPeriod]
 313 docsToPhyloPeriods lvl docs p = map (\(id,l) -> initPhyloPeriod id l)
 314                                     $ Map.toList levels
 315   where
 316     --------------------------------------
 317     levels :: Map (Date,Date) [PhyloLevel]
 318     levels = mapWithKey (\k v -> [docsToPhyloLevel lvl k v p]) docs
 319     --------------------------------------
 320
 321
 322 -- | To update a Phylo for a given Levels
 323 updatePhyloByLevel :: Level -> Phylo -> Phylo
 324 updatePhyloByLevel lvl p
 325   = case getLevelLabel lvl of
 326
 327     Level_m1 -> appendPhyloPeriods (docsToPhyloPeriods (getLevelValue lvl) lvlData p) p
 328       where
 329         --------------------------------------
 330         lvlData :: Map (Date,Date) [Document]
 331         lvlData = phyloPeriods
 332         --------------------------------------
 333
 334     Level_0  -> clonePhyloLevel (getLevelValue lvl) p
 335
 336     Level_1  -> fisToPhyloLevel lvlData p
 337       where
 338         --------------------------------------
 339         lvlData :: Map (Date, Date) Fis
 340         lvlData = phyloFisFiltered
 341         --------------------------------------
 342
 343     _        -> panic ("[ERR][Viz.Phylo.Example.updatePhyloByLevel] Level not defined")
 344
 345
 346 phyloWithGroupsm1 :: Phylo
 347 phyloWithGroupsm1 = updatePhyloByLevel (initLevel (-1) Level_m1) phylo
 348
 349
 350 ------------------------------------------------------------------------
 351 -- | STEP 3 | -- Parse the Documents and group them by Periods
 352
 353
 354 -- | To init a set of periods out of a given Grain and Step
 355 docsToPeriods :: (Ord date, Enum date) => (doc -> date)
 356      -> Grain -> Step -> [doc] -> Map (date, date) [doc]
 357 docsToPeriods _ _ _ [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
 358 docsToPeriods f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
 359   where
 360     --------------------------------------
 361     hs = steps g s $ both f (head es, last es)
 362     --------------------------------------
 363     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
 364     inPeriode f' h (start,end) =
 365       fst $ List.partition (\d -> f' d >= start && f' d <= end) h
 366     --------------------------------------
 367     steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
 368     steps s' o' (start,end) = map (\l -> (head l, last l))
 369                           $ chunkAlong s' o' [start .. end]
 370     --------------------------------------
 371
 372
 373 -- | To parse a list of Documents by filtering on a Vector of Ngrams
 374 parseDocs :: PhyloNgrams -> [Document] -> [Document]
 375 parseDocs l docs = map (\(Document d t) -> Document d (unwords
 376                                                       $ filter (\x -> Vector.elem x l)
 377                                                       $ monoTexts t)) docs
 378
 379
 380 -- | To group a list of Documents by fixed periods
 381 groupDocsByPeriod :: Grain -> Step -> [Document] -> Phylo -> Map (Date, Date) [Document]
 382 groupDocsByPeriod g s docs p = docsToPeriods date g s
 383                              $ parseDocs (getPhyloNgrams p) docs
 384
 385
 386 phyloPeriods :: Map (Date, Date) [Document]
 387 phyloPeriods = groupDocsByPeriod 5 3 phyloDocs phylo
 388
 389
 390 ------------------------------------------------------------------------
 391 -- | STEP 2 | -- Init an initial list of Ngrams and a Phylo
 392
 393
 394 -- | To init a Phylomemy
 395 initPhylo :: [Document] -> PhyloNgrams -> Phylo
 396 initPhylo docs ngrams = Phylo (both date $ (last &&& head) docs) ngrams []
 397
 398
 399 -- | To init a PhyloNgrams as a Vector of Ngrams
 400 initNgrams :: [Ngrams] -> PhyloNgrams
 401 initNgrams l = Vector.fromList $ map toLower l
 402
 403
 404 phylo :: Phylo
 405 phylo = initPhylo phyloDocs (initNgrams actants)
 406
 407
 408 ------------------------------------------------------------------------
 409 -- | STEP 1 | -- Get a list of Document
 410
 411
 412 -- | To transform a corpus of texts into a structured list of Documents
 413 corpusToDocs :: [(Date, Text)] -> [Document]
 414 corpusToDocs l = map (\(d,t) -> Document d t) l
 415
 416
 417 phyloDocs :: [Document]
 418 phyloDocs = corpusToDocs corpus
 419
 420
 421 ------------------------------------------------------------------------
 422 -- | STEP 0 | -- Let's start with an example
 423
 424
 425 actants :: [Ngrams]
 426 actants = [ "Cleopatre"   , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
 427           , "Marc-Antoine", "Cesar"   , "Antoine"      , "Octave"  , "Rome"
 428           , "Alexandrie"  , "Auguste" , "Pompee"       , "Cassius" , "Brutus"]
 429
 430
 431 corpus :: [(Date, Text)]
 432 corpus = List.sortOn fst [ (-51,"Cleopatre règne sur l’egypte entre 51 et 30 av. J.-C. avec ses frères-epoux Ptolemee-XIII et Ptolemee-XIV, puis aux côtes du general romain Marc-Antoine. Elle est celèbre pour avoir ete la compagne de Jules Cesar puis d'Antoine, avec lesquels elle a eu plusieurs enfants. Partie prenante dans la guerre civile opposant Antoine à Octave, elle est vaincue à la bataille d'Actium en 31 av. J.-C. Sa defaite va permettre aux Romains de mener à bien la conquête de l’egypte, evenement qui marquera la fin de l'epoque hellenistique."), (-40,"Il existe relativement peu d'informations sur son sejour à Rome, au lendemain de l'assassinat de Cesar, ou sur la periode passee à Alexandrie durant l'absence d'Antoine, entre -40 et -37."), (-48,"L'historiographie antique lui est globalement defavorable car inspiree par son vainqueur, l'empereur Auguste, et par son entourage, dont l'interêt est de la noircir, afin d'en faire l'adversaire malfaisant de Rome et le mauvais genie d'Antoine. On observe par ailleurs que Cesar ne fait aucune mention de sa liaison avec elle dans les Commentaires sur la Guerre civile"), (-69,"Cleopatre est nee au cours de l'hiver -69/-686 probablement à Alexandrie."), (-48,"Pompee a en effet ete le protecteur de Ptolemee XII, le père de Cleopatre et de Ptolemee-XIII dont il se considère comme le tuteur."), (-48,"Ptolemee-XIII et Cleopatre auraient d'ailleurs aide Pompee par l'envoi d'une flotte de soixante navires."), (-48,"Mais le jeune roi Ptolemee-XIII et ses conseillers jugent sa cause perdue et pensent s'attirer les bonnes graces du vainqueur en le faisant assassiner à peine a-t-il pose le pied sur le sol egyptien, près de Peluse, le 30 juillet 48 av. J.-C., sous les yeux de son entourage."), (-48,"Cesar fait enterrer la tête de Pompee dans le bosquet de Nemesis en bordure du mur est de l'enceinte d'Alexandrie. Pour autant la mort de Pompee est une aubaine pour Cesar qui tente par ailleurs de profiter des querelles dynastiques pour annexer l’egypte."), (-48,"Il est difficile de se prononcer clairement sur les raisons qui ont pousse Cesar à s'attarder à Alexandrie. Il y a des raisons politiques, mais aussi des raisons plus sentimentales (Cleopatre ?). Il tente d'abord d'obtenir le remboursement de dettes que Ptolemee XII"), (-46,"Les deux souverains sont convoques par Cesar au palais royal d'Alexandrie. Ptolemee-XIII s'y rend après diverses tergiversations ainsi que Cleopatre."), (-47,"A Rome, Cleopatre epouse alors un autre de ses frères cadets, à Alexandrie, Ptolemee-XIV, sur l'injonction de Jules Cesar"), (-46,"Cesar a-t-il comme objectif de montrer ce qu'il en coûte de se revolter contre Rome en faisant figurer dans son triomphe la sœur de Cleopatre et de Ptolemee-XIV, Arsinoe, qui s'est fait reconnaître reine par les troupes de Ptolemee-XIII ?"), (-44,"Au debut de l'annee -44, Cesar est assassine par Brutus. Profitant de la situation confuse qui s'ensuit, Cleopatre quitte alors Rome à la mi-avril, faisant escale en Grèce. Elle parvient à Alexandrie en juillet -44."), (-44,"La guerre que se livrent les assassins de Cesar, Cassius et Brutus et ses heritiers, Octave et Marc-Antoine, oblige Cleopatre à des contorsions diplomatiques."), (-41,"Nous ignorons depuis quand Cleopatre, agee de 29 ans en -41, et Marc-Antoine, qui a une quarantaine d'annees, se connaissent. Marc-Antoine est l'un des officiers qui ont participe au retablissement de Ptolemee XII.  Il est plus vraisemblable qu'ils se soient frequentes lors du sejour à Rome de Cleopatre."), (-42,"Brutus tient la Grèce tandis que Cassius s'installe en Syrie. Le gouverneur de Cleopatre à Chypre, Serapion, vient en aide à Cassius."), (-42,"Cassius aurait envisage de s'emparer d'Alexandrie quand le 'debarquement' en Grèce d'Antoine et d'Octave l'oblige à renoncer à ses projets")]