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, sortOn, reverse, splitAt, take)
  34 import Data.Map         (Map, elems, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
  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 13 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
  59
  60
  61 ------------------------------------------------------------------------
  62 -- | STEP 12 | -- Cluster the Fis
  63
  64
  65 ------------------------------------------------------------------------
  66 -- | STEP 11 | -- Link the PhyloGroups of level 1 through the Periods
  67
  68
  69 -- | To process the weightedLogJaccard between two PhyloGroups fields
  70 weightedLogJaccard :: Double -> PhyloGroupId -> Map (Int, Int) Double -> Map (Int, Int) Double -> (PhyloGroupId, Double)
  71 weightedLogJaccard s id f1 f2
  72   | null wUnion      = (id,0)
  73   | wUnion == wInter = (id,1)
  74   | s == 0           = (id,(fromIntegral $ length wInter)/(fromIntegral $ length wUnion))
  75   | s > 0            = (id,(sumInvLog wInter)/(sumInvLog wUnion))
  76   | otherwise        = (id,(sumLog wInter)/(sumLog wUnion))
  77   where
  78     --------------------------------------
  79     wInter :: [Double]
  80     wInter = elems $ intersectionWith (+) f1 f2
  81     --------------------------------------
  82     wUnion :: [Double]
  83     wUnion = elems $ unionWith (+) f1 f2
  84     --------------------------------------
  85     sumInvLog :: [Double] -> Double
  86     sumInvLog l = foldl (\mem x -> mem + (1 / log (s + x))) 0 l
  87     --------------------------------------
  88     sumLog :: [Double] -> Double
  89     sumLog l = foldl (\mem x -> mem + log (s + x)) 0 l
  90     --------------------------------------
  91
  92
  93 -- | To apply the corresponding proximity function based on a given Proximity
  94 getProximity :: Proximity -> Double -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
  95 getProximity prox s g1 g2 = case prox of
  96   WeightedLogJaccard -> weightedLogJaccard s (getGroupId g2) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1))
  97   Other              -> undefined
  98   _                  -> panic ("[ERR][Viz.Phylo.Example.getProximity] Proximity function not defined")
  99
 100
 101 -- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
 102 getNextPeriods :: PairTo -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
 103 getNextPeriods to id l = case to of
 104     Childs  -> unNested id ((tail . snd) next)
 105     Parents -> unNested id ((reverse . fst) next)
 106     _       -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PairTo type not defined")
 107     where
 108       --------------------------------------
 109       next :: ([PhyloPeriodId], [PhyloPeriodId])
 110       next = splitAt idx l
 111       --------------------------------------
 112       idx :: Int
 113       idx = case (List.elemIndex id l) of
 114         Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
 115         Just i  -> i
 116       --------------------------------------
 117       -- | To have an non-overlapping next period
 118       unNested :: PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
 119       unNested x l
 120         | null l                  = []
 121         | nested (fst $ head l) x = unNested x (tail l)
 122         | nested (snd $ head l) x = unNested x (tail l)
 123         | otherwise               = l
 124       --------------------------------------
 125       nested :: Date -> PhyloPeriodId -> Bool
 126       nested d prd = d >= fst prd && d <= snd prd
 127       --------------------------------------
 128
 129
 130 -- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )
 131 findBestCandidates :: PairTo -> Int -> Int -> Double -> Double -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
 132 findBestCandidates to depth max thr s group p
 133   | depth > max || (null . head) next = []
 134   | (not . null) best = take 2 best
 135   | otherwise = findBestCandidates to (depth + 1) max thr s group p
 136   where
 137     --------------------------------------
 138     next :: [PhyloPeriodId]
 139     next = getNextPeriods to (getGroupPeriod group) (getPhyloPeriods p)
 140     --------------------------------------
 141     candidates :: [PhyloGroup]
 142     candidates = getGroupsWithFilters (getGroupLevel group) (head next) p
 143     --------------------------------------
 144     scores :: [(PhyloGroupId, Double)]
 145     scores = map (\group' -> getProximity WeightedLogJaccard s group group') candidates
 146     --------------------------------------
 147     best :: [(PhyloGroupId, Double)]
 148     best = reverse
 149          $ sortOn snd
 150          $ filter (\(id,score) -> score >= thr) scores
 151     --------------------------------------
 152
 153
 154 -- | To add a new list of Pointers into an existing Childs/Parents list of Pointers
 155 makePair :: PairTo -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
 156 makePair to group ids = case to of
 157     Childs  -> over (phylo_groupPeriodChilds) addPointers group
 158     Parents -> over (phylo_groupPeriodParents) addPointers group
 159     _       -> panic ("[ERR][Viz.Phylo.Example.makePair] PairTo type not defined")
 160     where
 161       --------------------------------------
 162       addPointers :: [Pointer] -> [Pointer]
 163       addPointers l = nub $ (l ++ ids)
 164       --------------------------------------
 165
 166
 167 -- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
 168 pairGroupsToGroups :: PairTo -> Level -> Double -> Double -> Phylo -> Phylo
 169 pairGroupsToGroups to lvl thr s p = alterPhyloGroupsWith
 170                                     (\groups ->
 171                                       map (\group ->
 172                                             let
 173                                               --------------------------------------
 174                                               candidates :: [(PhyloGroupId, Double)]
 175                                               candidates = findBestCandidates to 1 5 thr s group p
 176                                               --------------------------------------
 177                                             in
 178                                               makePair to group candidates ) groups)
 179                                     getGroupLevel (getLevelValue lvl) p
 180
 181
 182 phyloWithPair_1_Childs :: Phylo
 183 phyloWithPair_1_Childs = pairGroupsToGroups Childs (initLevel 1 Level_1) 0.1 0.5 phyloWithPair_1_Parents
 184
 185
 186 phyloWithPair_1_Parents :: Phylo
 187 phyloWithPair_1_Parents = pairGroupsToGroups Parents (initLevel 1 Level_1) 0.1 0.5 phyloLinked_0_1
 188
 189
 190 ------------------------------------------------------------------------
 191 -- | STEP 10 | -- Build the coocurency Matrix of the Phylo
 192
 193
 194 -- | Are two PhyloGroups sharing at leats one Ngrams
 195 shareNgrams :: PhyloGroup -> PhyloGroup -> Bool
 196 shareNgrams g g' = (not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g')
 197
 198
 199 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
 200 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
 201 getKeyPair (x,y) m = case findPair (x,y) m of
 202                       Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
 203                       Just i  -> i
 204                      where
 205                       --------------------------------------
 206                       findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
 207                       findPair (x,y) m
 208                         | member (x,y) m = Just (x,y)
 209                         | member (y,x) m = Just (y,x)
 210                         | otherwise      = Nothing
 211                       --------------------------------------
 212
 213
 214 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 215 listToCombi :: forall a b. (a -> b) -> [a] -> [(b,b)]
 216 listToCombi f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 217
 218
 219 -- | To transform the Fis into a coocurency Matrix in a Phylo
 220 fisToCooc :: Map (Date, Date) Fis -> Phylo -> Map (Int, Int) Double
 221 fisToCooc m p = map   (/docs)
 222               $ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc
 223               $ concat
 224               $ map (\x -> listToCombi (\x -> ngramsToIdx x p) $ (Set.toList . fst) x) fis
 225   where
 226     --------------------------------------
 227     fis :: [(Clique,Support)]
 228     fis = concat $ map (\x -> Map.toList x) (elems m)
 229     --------------------------------------
 230     fisNgrams :: [Ngrams]
 231     fisNgrams = foldl (\mem x -> union mem $ (Set.toList . fst) x) [] fis
 232     --------------------------------------
 233     docs :: Double
 234     docs = fromIntegral $ foldl (\mem x -> mem + (snd x)) 0 fis
 235     --------------------------------------
 236     cooc :: Map (Int, Int) (Double)
 237     cooc = Map.fromList $ map (\x -> (x,0)) (listToCombi (\x -> ngramsToIdx x p) fisNgrams)
 238     --------------------------------------
 239
 240
 241 phyloCooc :: Map (Int, Int) Double
 242 phyloCooc = fisToCooc phyloFisFiltered phyloLinked_0_1
 243
 244
 245 ------------------------------------------------------------------------
 246 -- | STEP 9 | -- Build level 1 of the Phylo
 247
 248
 249 -- | To Cliques into Groups
 250 cliqueToGroup :: PhyloPeriodId -> Int -> Int -> Ngrams -> (Clique,Support) -> Map (Date, Date) Fis -> Phylo -> PhyloGroup
 251 cliqueToGroup period lvl idx label fis m p = PhyloGroup ((period, lvl), idx)
 252                                                     label
 253                                                     ngrams
 254                                                     (singleton "support" (fromIntegral $ snd fis))
 255                                                     cooc
 256                                                     [] [] [] []
 257   where
 258     --------------------------------------
 259     ngrams :: [Int]
 260     ngrams = sort $ map (\x -> ngramsToIdx x p)
 261                   $ Set.toList
 262                   $ fst fis
 263     --------------------------------------
 264     cooc :: Map (Int, Int) Double
 265     cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 266                           $ fisToCooc (restrictKeys m $ Set.fromList [period]) p
 267     --------------------------------------
 268
 269
 270 -- | To transform Fis into PhyloLevels
 271 fisToPhyloLevel :: Map (Date, Date) Fis -> Phylo -> Phylo
 272 fisToPhyloLevel m p = over (phylo_periods . traverse)
 273                            (\period ->
 274                               let periodId = _phylo_periodId period
 275                                   fisList  = zip [1..] (Map.toList (m ! periodId))
 276                               in  over (phylo_periodLevels)
 277                                        (\levels ->
 278                                           let groups = map (\fis -> cliqueToGroup periodId 1 (fst fis) "" (snd fis) m p) fisList
 279                                           in  levels ++ [PhyloLevel (periodId, 1) groups]
 280                                        ) period ) p
 281
 282
 283 phyloLinked_0_1 :: Phylo
 284 phyloLinked_0_1 = alterLevelLinks lvl_0_1  phyloLinked_1_0
 285
 286
 287 lvl_0_1 :: LevelLink
 288 lvl_0_1 = initLevelLink (initLevel 0 Level_0) (initLevel 1 Level_1)
 289
 290
 291 phyloLinked_1_0 :: Phylo
 292 phyloLinked_1_0 = alterLevelLinks lvl_1_0  phyloWithGroups1
 293
 294
 295 lvl_1_0 :: LevelLink
 296 lvl_1_0 = initLevelLink (initLevel 1 Level_1) (initLevel 0 Level_0)
 297
 298
 299 phyloWithGroups1 :: Phylo
 300 phyloWithGroups1 = updatePhyloByLevel (initLevel 1 Level_1) phyloLinked_m1_0
 301
 302
 303 ------------------------------------------------------------------------
 304 -- | STEP 8 | -- Create Frequent Items Sets by Period and filter them
 305
 306
 307 -- | To Filter Fis by support
 308 filterFisBySupport :: Bool -> Int -> Map (Date, Date) Fis -> Map (Date, Date) Fis
 309 filterFisBySupport empty min m = case empty of
 310   True  -> Map.map (\fis -> filterMinorFis min fis) m
 311   False -> Map.map (\fis -> filterMinorFisNonEmpty min fis) m
 312
 313
 314 -- | To filter Fis with small Support, to preserve nonempty periods please use : filterFisBySupport False
 315 filterMinorFis :: Int -> Fis -> Fis
 316 filterMinorFis min fis = Map.filter (\s -> s > min) fis
 317
 318
 319 -- | To filter Fis with small Support but by keeping non empty Periods
 320 filterMinorFisNonEmpty :: Int -> Fis -> Fis
 321 filterMinorFisNonEmpty min fis = if (Map.null fis') && (not $ Map.null fis)
 322                                  then filterMinorFisNonEmpty (min - 1) fis
 323                                  else fis'
 324   where
 325     --------------------------------------
 326     fis' :: Fis
 327     fis' = filterMinorFis min fis
 328     --------------------------------------
 329
 330
 331 -- | To filter nested Fis
 332 filterFisByNested :: Map (Date, Date) Fis -> Map (Date, Date) Fis
 333 filterFisByNested = map (\fis -> restrictKeys fis
 334                               $ Set.fromList
 335                               $ filterNestedSets (head (keys fis)) (keys fis) []
 336                             )
 337
 338
 339 -- | To transform a list of Documents into a Frequent Items Set
 340 docsToFis :: Map (Date, Date) [Document] -> Map (Date, Date) Fis
 341 docsToFis docs = map (\d -> fisWithSizePolyMap
 342                               (Segment 1 20)
 343                               1
 344                               (map (words . text) d)) docs
 345
 346
 347 phyloFisFiltered :: Map (Date, Date) Fis
 348 phyloFisFiltered = filterFisBySupport True 1 (filterFisByNested phyloFis)
 349
 350
 351 phyloFis :: Map (Date, Date) Fis
 352 phyloFis = docsToFis phyloPeriods
 353
 354
 355 ------------------------------------------------------------------------
 356 -- | STEP 7 | -- Link level -1 to level 0
 357
 358
 359 phyloLinked_m1_0 :: Phylo
 360 phyloLinked_m1_0 = alterLevelLinks lvl_m1_0  phyloLinked_0_m1
 361
 362
 363 lvl_m1_0 :: LevelLink
 364 lvl_m1_0 = initLevelLink (initLevel (-1) Level_m1) (initLevel 0 Level_0)
 365
 366
 367 ------------------------------------------------------------------------
 368 -- | STEP 6 | -- Link level 0 to level -1
 369
 370
 371 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
 372 linkGroupToGroups :: LevelLink -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
 373 linkGroupToGroups lvl current targets
 374   | getLevelLinkValue From lvl < getLevelLinkValue To lvl = setLevelParents current
 375   | getLevelLinkValue From lvl > getLevelLinkValue To lvl = setLevelChilds current
 376   | otherwise = current
 377   where
 378     --------------------------------------
 379     setLevelChilds :: PhyloGroup -> PhyloGroup
 380     setLevelChilds =  over (phylo_groupLevelChilds) addPointers
 381     --------------------------------------
 382     setLevelParents :: PhyloGroup -> PhyloGroup
 383     setLevelParents =  over (phylo_groupLevelParents) addPointers
 384     --------------------------------------
 385     addPointers :: [Pointer] -> [Pointer]
 386     addPointers lp = lp ++ Maybe.mapMaybe (\target ->
 387                                             if shouldLink lvl (_phylo_groupNgrams current)
 388                                                               (_phylo_groupNgrams target )
 389                                             then Just ((getGroupId target),1)
 390                                             else Nothing) targets
 391     --------------------------------------
 392
 393
 394 -- | To set the LevelLinks between two lists of PhyloGroups
 395 linkGroupsByLevel :: LevelLink -> Phylo -> [PhyloGroup] -> [PhyloGroup]
 396 linkGroupsByLevel lvl p groups  = map (\group ->
 397   if getGroupLevel group == getLevelLinkValue From lvl
 398   then linkGroupToGroups lvl group (getGroupsWithFilters (getLevelLinkValue To lvl) (getGroupPeriod group) p)
 399   else group ) groups
 400
 401
 402 -- | To set the LevelLink of all the PhyloGroups of a Phylo
 403 alterLevelLinks :: LevelLink -> Phylo -> Phylo
 404 alterLevelLinks lvl p = alterPhyloGroups (linkGroupsByLevel lvl p) p
 405
 406
 407 phyloLinked_0_m1 :: Phylo
 408 phyloLinked_0_m1 = alterLevelLinks lvl_0_m1  phyloWithGroups0
 409
 410
 411 lvl_0_m1 :: LevelLink
 412 lvl_0_m1 = initLevelLink (initLevel 0 Level_0) (initLevel (-1) Level_m1)
 413
 414
 415 ------------------------------------------------------------------------
 416 -- | STEP 5 | -- Build level 0 as a copy of level -1
 417
 418
 419 -- | To clone the last PhyloLevel of each PhyloPeriod and update it with a new LevelValue
 420 clonePhyloLevel :: Int -> Phylo -> Phylo
 421 clonePhyloLevel lvl p = alterPhyloLevels (\l -> addPhyloLevel
 422                                                (setPhyloLevelId lvl $ head l)
 423                                                l) p
 424
 425
 426 phyloWithGroups0 :: Phylo
 427 phyloWithGroups0 = updatePhyloByLevel (initLevel 0 Level_0) phyloWithGroupsm1
 428
 429
 430 ------------------------------------------------------------------------
 431 -- | STEP 4 | -- Build level -1
 432
 433
 434 -- | To transform a list of Documents into a PhyloLevel
 435 docsToPhyloLevel :: Int ->(Date, Date) -> [Document] -> Phylo -> PhyloLevel
 436 docsToPhyloLevel lvl (d, d') docs p = initPhyloLevel
 437                                         ((d, d'), lvl)
 438                                         (map (\(f,s) -> initGroup [s] s f lvl d d' p)
 439                                              $ zip [1..]
 440                                              $ (nub . concat)
 441                                              $ map (words . text) docs)
 442
 443
 444 -- | To transform a Map of Periods and Documents into a list of PhyloPeriods
 445 docsToPhyloPeriods :: Int -> Map (Date,Date) [Document] -> Phylo -> [PhyloPeriod]
 446 docsToPhyloPeriods lvl docs p = map (\(id,l) -> initPhyloPeriod id l)
 447                                     $ Map.toList levels
 448   where
 449     --------------------------------------
 450     levels :: Map (Date,Date) [PhyloLevel]
 451     levels = mapWithKey (\k v -> [docsToPhyloLevel lvl k v p]) docs
 452     --------------------------------------
 453
 454
 455 -- | To update a Phylo for a given Levels
 456 updatePhyloByLevel :: Level -> Phylo -> Phylo
 457 updatePhyloByLevel lvl p
 458   = case getLevelLabel lvl of
 459
 460     Level_m1 -> appendPhyloPeriods (docsToPhyloPeriods (getLevelValue lvl) lvlData p) p
 461       where
 462         --------------------------------------
 463         lvlData :: Map (Date,Date) [Document]
 464         lvlData = phyloPeriods
 465         --------------------------------------
 466
 467     Level_0  -> clonePhyloLevel (getLevelValue lvl) p
 468
 469     Level_1  -> fisToPhyloLevel lvlData p
 470       where
 471         --------------------------------------
 472         lvlData :: Map (Date, Date) Fis
 473         lvlData = phyloFisFiltered
 474         --------------------------------------
 475
 476     _        -> panic ("[ERR][Viz.Phylo.Example.updatePhyloByLevel] Level not defined")
 477
 478
 479 phyloWithGroupsm1 :: Phylo
 480 phyloWithGroupsm1 = updatePhyloByLevel (initLevel (-1) Level_m1) phylo
 481
 482
 483 ------------------------------------------------------------------------
 484 -- | STEP 3 | -- Parse the Documents and group them by Periods
 485
 486
 487 -- | To init a set of periods out of a given Grain and Step
 488 docsToPeriods :: (Ord date, Enum date) => (doc -> date)
 489      -> Grain -> Step -> [doc] -> Map (date, date) [doc]
 490 docsToPeriods _ _ _ [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
 491 docsToPeriods f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
 492   where
 493     --------------------------------------
 494     hs = steps g s $ both f (head es, last es)
 495     --------------------------------------
 496     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
 497     inPeriode f' h (start,end) =
 498       fst $ List.partition (\d -> f' d >= start && f' d <= end) h
 499     --------------------------------------
 500     steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
 501     steps s' o' (start,end) = map (\l -> (head l, last l))
 502                           $ chunkAlong s' o' [start .. end]
 503     --------------------------------------
 504
 505
 506 -- | To parse a list of Documents by filtering on a Vector of Ngrams
 507 parseDocs :: PhyloNgrams -> [Document] -> [Document]
 508 parseDocs l docs = map (\(Document d t) -> Document d (unwords
 509                                                       $ filter (\x -> Vector.elem x l)
 510                                                       $ monoTexts t)) docs
 511
 512
 513 -- | To group a list of Documents by fixed periods
 514 groupDocsByPeriod :: Grain -> Step -> [Document] -> Phylo -> Map (Date, Date) [Document]
 515 groupDocsByPeriod g s docs p = docsToPeriods date g s
 516                              $ parseDocs (getPhyloNgrams p) docs
 517
 518
 519 phyloPeriods :: Map (Date, Date) [Document]
 520 phyloPeriods = groupDocsByPeriod 5 3 phyloDocs phylo
 521
 522
 523 ------------------------------------------------------------------------
 524 -- | STEP 2 | -- Init an initial list of Ngrams and a Phylo
 525
 526
 527 -- | To init a Phylomemy
 528 initPhylo :: [Document] -> PhyloNgrams -> Phylo
 529 initPhylo docs ngrams = Phylo (both date $ (last &&& head) docs) ngrams []
 530
 531
 532 -- | To init a PhyloNgrams as a Vector of Ngrams
 533 initNgrams :: [Ngrams] -> PhyloNgrams
 534 initNgrams l = Vector.fromList $ map toLower l
 535
 536
 537 phylo :: Phylo
 538 phylo = initPhylo phyloDocs (initNgrams actants)
 539
 540
 541 ------------------------------------------------------------------------
 542 -- | STEP 1 | -- Get a list of Document
 543
 544
 545 -- | To transform a corpus of texts into a structured list of Documents
 546 corpusToDocs :: [(Date, Text)] -> [Document]
 547 corpusToDocs l = map (\(d,t) -> Document d t) l
 548
 549
 550 phyloDocs :: [Document]
 551 phyloDocs = corpusToDocs corpus
 552
 553
 554 ------------------------------------------------------------------------
 555 -- | STEP 0 | -- Let's start with an example
 556
 557
 558 actants :: [Ngrams]
 559 actants = [ "Cleopatre"   , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
 560           , "Marc-Antoine", "Cesar"   , "Antoine"      , "Octave"  , "Rome"
 561           , "Alexandrie"  , "Auguste" , "Pompee"       , "Cassius" , "Brutus"]
 562
 563
 564 corpus :: [(Date, Text)]
 565 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")]