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 (both)
  31 import qualified Data.List as List
  32 import Data.Text (Text, unwords, toLower, words)
  33 import Data.Tuple.Extra
  34 import Data.Semigroup (Semigroup)
  35 import Data.Map (Map)
  36 import qualified Data.Map as Map
  37 import qualified Data.Vector as Vector
  38 import qualified Data.Maybe as Maybe
  39 import qualified Data.Tuple as Tuple
  40 import qualified Data.Bool as Bool
  41
  42 import Data.Set (Set)
  43 import qualified Data.Set as Set
  44 import qualified Data.Matrix as DM'
  45
  46 import Gargantext.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
  47 import Gargantext.Text.Terms.Mono (monoTexts)
  48 import Gargantext.Prelude
  49 import Gargantext.Viz.Phylo
  50
  51 ------------------------------------------------------------------------
  52 -- | Types | --
  53
  54
  55 -- | Date : a simple Integer
  56 type Date = Int
  57 -- | Document : a piece of Text linked to a Date
  58 data Document = Document
  59       { date :: Date
  60       , text :: Text
  61       } deriving (Show)
  62 -- | Corpus : a list of Documents
  63 type Corpus   = [Document]
  64
  65
  66 type MapList = [Ngrams]
  67 type PeriodeSize = Int
  68 -- data Periodes b a = Map (b,b) a
  69 type Occurrences = Int
  70
  71 data Levels = Level_m1 | Level_0 | Level_1 | Level_2 | Level_N
  72   deriving (Show, Eq, Enum, Bounded)
  73
  74
  75
  76
  77 data LinkLvlLabel = Link_m1_0 | Link_0_m1 | Link_1_0 | Link_0_1 | Link_x_y
  78   deriving (Show, Eq, Enum, Bounded)
  79
  80 data LinkLvl = LinkLvl
  81   { linkLvlLabel :: LinkLvlLabel
  82   , linkLvlFrom  :: Int
  83   , linkLvlTo    :: Int
  84   } deriving (Show)
  85
  86
  87 data PhyloError = LevelDoesNotExist
  88                 | LevelUnassigned
  89           deriving (Show)
  90
  91
  92 --------------------------------------------------------------------
  93 phyloExampleFinal :: Phylo
  94 phyloExampleFinal = undefined
  95
  96 --------------------------------------------------------------------
  97 appariement :: Map (Date, Date) (Map (Set Ngrams) Int)
  98 appariement = undefined
  99
 100 ------------------------------------------------------------------------
 101 -- | STEP 10 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
 102
 103
 104 ------------------------------------------------------------------------
 105 -- | STEP 8 | -- Cluster the Fis
 106
 107 ------------------------------------------------------------------------
 108 -- | STEP 9 | -- Link the PhyloGroups of level 1 through the Periods
 109
 110 ------------------------------------------------------------------------
 111 -- | STEP 8 | -- Find the Fis out of Documents and Ngrams and build level 1 of the Phylo
 112
 113 phyloLinked_0_1 :: Phylo
 114 phyloLinked_0_1 = phyloToLinks lvl_0_1  phyloLinked_1_0
 115
 116 lvl_0_1 :: LinkLvl
 117 lvl_0_1 = (LinkLvl Link_0_1 0 1)
 118
 119 phyloLinked_1_0 :: Phylo
 120 phyloLinked_1_0 = phyloToLinks lvl_1_0  phyloWithGroups1
 121
 122 lvl_1_0 :: LinkLvl
 123 lvl_1_0 = (LinkLvl Link_1_0 1 0)
 124
 125 phyloWithGroups1 :: Phylo
 126 phyloWithGroups1 = updatePhyloByLevel Level_1 phyloLinked_m1_0
 127
 128 -- | Doit-on conserver le support dans les phylogroups ? Oui (faire un champ groups quality ...)
 129
 130 cliqueToGroup :: PhyloPeriodId -> Int -> Int -> Ngrams -> (Clique,Support) -> PhyloGroup
 131 cliqueToGroup period lvl idx label fis = PhyloGroup ((period, lvl), idx) label (List.sort (map (\x -> findIdx x) (Set.toList $ Tuple.fst fis))) [] [] [] []
 132
 133 fisToPhyloLevel :: Map (Date, Date) Fis -> Phylo -> Phylo
 134 fisToPhyloLevel m p = over (phylo_periods . traverse)
 135                            (\period ->
 136                                     let periodId = _phylo_periodId period
 137                                         fisList  = zip [1..] (Map.toList (m Map.! periodId))
 138                                     in  over (phylo_periodLevels)
 139                                              (\levels ->
 140                                                 let groups = map (\fis -> cliqueToGroup periodId 1 (Tuple.fst fis) "" (Tuple.snd fis)) fisList
 141                                                 in (PhyloLevel (periodId, 1) groups) : levels
 142                                              ) period
 143                            ) p
 144
 145 -- | Doit-on mettre une rêgle pour éviter que les filtres ne suppriment tous les Fis d'une période ? Oui : en fonction de ce qu'il reste après les nested on peut mettre une optrion (pas forcément par défaut) pour descendre le seuil de support jusqu'à trouver un ensemble non nul de Fis
 146
 147 phyloFisFiltered :: Map (Date, Date) Fis
 148 phyloFisFiltered = filterFisByNested $ filterFisBySupport 1 phyloFis
 149
 150 filterFisBySupport :: Int -> Map (Date, Date) Fis -> Map (Date, Date) Fis
 151 filterFisBySupport minSupport m = Map.map (\fis -> Map.filter (\s -> s > minSupport) fis) m
 152
 153 doesContains :: [Ngrams] -> [Ngrams] -> Bool
 154 doesContains l l'
 155   | List.null l'                   = True
 156   | List.length l' > List.length l = False
 157   | List.elem (List.head l') l     = doesContains l (List.tail l')
 158   | otherwise                      = False
 159
 160 doesAnyContains :: Set Ngrams -> [Set Ngrams] -> [Set Ngrams] -> Bool
 161 doesAnyContains h l l' = List.any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' List.++ l)
 162
 163 filterNestedCliques :: Set Ngrams -> [Set Ngrams] -> [Set Ngrams] -> [Set Ngrams]
 164 filterNestedCliques h l l'
 165   | List.null l            = if doesAnyContains h l l'
 166                              then l'
 167                              else h : l'
 168   | doesAnyContains h l l' = filterNestedCliques (List.head l) (List.tail l) l'
 169   | otherwise              = filterNestedCliques (List.head l) (List.tail l) (h : l')
 170
 171
 172 filterFisByNested :: Map (Date, Date) Fis -> Map (Date, Date) Fis
 173 filterFisByNested m = Map.map(\fis -> Map.restrictKeys fis (Set.fromList (filterNestedCliques (List.head (Map.keys fis)) (Map.keys fis) []))) m
 174
 175 phyloFis :: Map (Date, Date) Fis
 176 phyloFis = termsToFis phyloTerms
 177
 178 termsToFis :: Map (Date, Date) [Document]
 179     -> Map (Date, Date) Fis
 180 termsToFis = corpusToFis (words . text)
 181
 182 -- | TODO: parameters has to be checked
 183 -- | TODO FIS on monotexts
 184 corpusToFis :: (Document -> [Ngrams])
 185       -> Map (Date, Date) [Document]
 186       -> Map (Date, Date) (Map (Set Ngrams) Int)
 187 corpusToFis f = Map.map (\d -> fisWithSizePolyMap (Segment 1 20) 1 (map f d))
 188
 189
 190 ------------------------------------------------------------------------
 191 -- | STEP 7 | -- Link level -1 to level 0
 192
 193
 194 phyloLinked_m1_0 :: Phylo
 195 phyloLinked_m1_0 = phyloToLinks lvl_m1_0  phyloLinked_0_m1
 196
 197 lvl_m1_0 :: LinkLvl
 198 lvl_m1_0 = (LinkLvl Link_m1_0 (-1) 0)
 199
 200
 201 ------------------------------------------------------------------------
 202 -- | STEP 6 | -- Link level 0 to level -1
 203
 204
 205 addPointer :: Semigroup field
 206            => ASetter current target identity (field -> field)
 207            -> field -> current -> target
 208 addPointer field targetPointer current =
 209   set field (<> targetPointer) current
 210
 211 getGroups :: Phylo -> [PhyloGroup]
 212 getGroups = view (phylo_periods . traverse . phylo_periodLevels . traverse . phylo_levelGroups)
 213
 214 getGroupId :: PhyloGroup -> PhyloGroupId
 215 getGroupId = view (phylo_groupId)
 216
 217 getGroupLvl :: PhyloGroup -> Int
 218 getGroupLvl group = Tuple.snd $ Tuple.fst $ getGroupId group
 219
 220 getGroupPeriod :: PhyloGroup -> (Date,Date)
 221 getGroupPeriod group = Tuple.fst $ Tuple.fst $ getGroupId group
 222
 223 getGroupsByLevelAndPeriod :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 224 getGroupsByLevelAndPeriod lvl period p = List.filter (\group -> (getGroupLvl group == lvl) && (getGroupPeriod group == period)) (getGroups p)
 225
 226 containsIdx :: [Int] -> [Int] -> Bool
 227 containsIdx l l'
 228   | List.null l' = False
 229   | List.last l < List.head l' = False
 230   | List.head l' `List.elem` l = True
 231   | otherwise = containsIdx l (List.tail l')
 232
 233 shouldLink :: LinkLvl -> [Int] -> [Int] -> Bool
 234 shouldLink lvl current target = case linkLvlLabel lvl of
 235   Link_0_m1  -> containsIdx target current
 236   Link_m1_0  -> containsIdx target current
 237   Link_0_1   -> containsIdx target current
 238   Link_1_0   -> containsIdx target current
 239   Link_x_y   -> undefined
 240   _          -> panic ("error link level to be defined")
 241
 242 linkGroupToGroups :: LinkLvl -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
 243 linkGroupToGroups lvl current targets
 244   | linkLvlFrom lvl < linkLvlTo lvl = setLevelParents current
 245   | linkLvlFrom lvl > linkLvlTo lvl = setLevelChilds current
 246   | otherwise = current
 247   where
 248     setLevelChilds :: PhyloGroup -> PhyloGroup
 249     setLevelChilds =  over (phylo_groupLevelChilds) addPointers
 250
 251     setLevelParents :: PhyloGroup -> PhyloGroup
 252     setLevelParents =  over (phylo_groupLevelParents) addPointers
 253
 254     addPointers :: [Pointer] -> [Pointer]
 255     addPointers lp = lp List.++ Maybe.mapMaybe (\target -> if shouldLink lvl (_phylo_groupNgrams current) (_phylo_groupNgrams target)
 256                                                            then Just ((getGroupId target),1)
 257                                                            else Nothing
 258                                                ) targets
 259
 260     addPointers' :: [Pointer] -> [Pointer]
 261     addPointers' lp = lp List.++ map (\target -> ((getGroupId target),1)) targets
 262
 263 linkGroupsByLevel :: LinkLvl -> Phylo -> [PhyloGroup] -> [PhyloGroup]
 264 linkGroupsByLevel lvl p groups  = map (\group ->
 265   if getGroupLvl group == linkLvlFrom lvl
 266   then linkGroupToGroups lvl group (getGroupsByLevelAndPeriod (linkLvlTo lvl) (getGroupPeriod group) p)
 267   else group ) groups
 268
 269 phyloToLinks :: LinkLvl -> Phylo -> Phylo
 270 phyloToLinks lvl p = over (phylo_periods . traverse . phylo_periodLevels . traverse . phylo_levelGroups) (\groups -> linkGroupsByLevel lvl p groups) p
 271
 272 phyloLinked_0_m1 :: Phylo
 273 phyloLinked_0_m1 = phyloToLinks lvl_0_m1  phyloWithGroups0
 274
 275 lvl_0_m1 :: LinkLvl
 276 lvl_0_m1 = (LinkLvl Link_0_m1 0 (-1))
 277
 278
 279 ------------------------------------------------------------------------
 280 -- | STEP 5 | -- Build level 0 (for the moment it's just a durty copy of level -1)
 281
 282
 283 setGroupIdLvl :: Int -> PhyloGroup -> PhyloGroup
 284 setGroupIdLvl lvl (PhyloGroup ((period, lvl'), idx) gLabel gNgrams gPP gPC gLP gLC)
 285   = PhyloGroup ((period, lvl), idx) gLabel gNgrams gPP gPC gLP gLC
 286
 287 setPhyloLevel :: Int -> PhyloLevel -> PhyloLevel
 288 setPhyloLevel lvl (PhyloLevel (periodId, lvl') lvlGroups)
 289   = PhyloLevel (periodId, lvl) lvlGroups'
 290     where
 291       lvlGroups' = map (\g -> setGroupIdLvl lvl g) lvlGroups
 292
 293 copyPhyloLevel :: Int -> [PhyloLevel] -> [PhyloLevel]
 294 copyPhyloLevel lvl l = (setPhyloLevel lvl (List.head l)) : l
 295
 296 alterLvl :: Int -> [PhyloPeriod] -> [PhyloPeriod]
 297 alterLvl lvl l = map (\p -> PhyloPeriod (_phylo_periodId p) (copyPhyloLevel lvl $ _phylo_periodLevels p)) l
 298
 299 phyloWithGroups0 :: Phylo
 300 phyloWithGroups0 = updatePhyloByLevel Level_0 phyloWithGroupsm1
 301
 302
 303 ------------------------------------------------------------------------
 304 -- | STEP 4 | -- Build level -1
 305
 306
 307 findIdx :: Ngrams -> Int
 308 findIdx n = case (Vector.elemIndex n (_phylo_ngrams phylo)) of
 309               Nothing -> panic "PhyloError"
 310               Just i  -> i
 311
 312 ngramsToGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> PhyloGroup
 313 ngramsToGroup terms label idx lvl from to = PhyloGroup (((from, to), lvl), idx) label (List.sort (map (\x -> findIdx x) terms)) [] [] [] []
 314
 315 docsToLevel :: (Date, Date) -> Corpus -> PhyloLevel
 316 docsToLevel k v = PhyloLevel (k,(-1)) (map (\x ->
 317                           ngramsToGroup [Tuple.snd x] (Tuple.snd x) (Tuple.fst x) (-1) (Tuple.fst k) (Tuple.snd k)
 318                        ) $ zip [1..] $ (List.nub . List.concat) $ map (words . text) v)
 319
 320 corpusToPhyloPeriod :: Map (Date,Date) Corpus -> [PhyloPeriod]
 321 corpusToPhyloPeriod corpus = map (\x -> PhyloPeriod (Tuple.fst x) [(Tuple.snd x)]) $ zip (Map.keys mapLvl) (Map.elems mapLvl)
 322     where
 323       mapLvl :: Map (Date,Date) PhyloLevel
 324       mapLvl = Map.mapWithKey docsToLevel corpus
 325
 326 updatePhyloByLevel :: Levels -> Phylo -> Phylo
 327 updatePhyloByLevel lvl (Phylo pDuration pNgrams pPeriods)
 328   = case lvl of
 329
 330     Level_m1 -> Phylo pDuration pNgrams pPeriods'
 331       where pPeriods' = (corpusToPhyloPeriod phyloTerms) List.++ pPeriods
 332
 333     Level_0  -> Phylo pDuration pNgrams pPeriods'
 334       where pPeriods' = alterLvl 0 pPeriods
 335
 336     Level_1  -> fisToPhyloLevel phyloFisFiltered (Phylo pDuration pNgrams pPeriods)
 337
 338     _        -> panic ("error level to be defined")
 339
 340 phyloWithGroupsm1 :: Phylo
 341 phyloWithGroupsm1 = updatePhyloByLevel Level_m1 phylo
 342
 343
 344 ------------------------------------------------------------------------
 345 -- | STEP 3 | -- Split the Corpus into Periods and reduce each Document as a list of Ngrams
 346
 347
 348 phyloTerms :: Map (Date, Date) [Document]
 349 phyloTerms = toPeriodes date 5 3 $ cleanCorpus cleanedActants phyloCorpus
 350
 351 toPeriodes :: (Ord date, Enum date) => (doc -> date)
 352      -> Grain -> Step -> [doc] -> Map (date, date) [doc]
 353 toPeriodes _ _ _ [] = panic "Empty corpus can not have any periods"
 354 toPeriodes f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
 355   where
 356     hs = steps g s $ both f (List.head es, List.last es)
 357     --------------------------------------------------------------------
 358     -- | Define overlapping periods of time by following regular steps
 359     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
 360     inPeriode f' h (start,end) =
 361       fst $ List.partition (\d -> f' d >= start && f' d <= end) h
 362     --------------------------------------------------------------------
 363     -- | Find steps of linear and homogenous time of integer
 364     steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
 365     steps s' o' (start,end) = map (\l -> (List.head l, List.last l))
 366                           $ chunkAlong s' o' [start .. end]
 367
 368 cleanCorpus :: MapList -> Corpus -> Corpus
 369 cleanCorpus ml = map (\(Document d t) -> Document d (unwords $ filter (\x -> elem  x ml) $ monoTexts t))
 370
 371
 372 ------------------------------------------------------------------------
 373 -- | STEP 2 | -- Find some Ngrams (ie: phyloGroup of level -1) out of the Corpus & init the phylo
 374
 375
 376 phylo = Phylo (both date $ (List.last &&& List.head) phyloCorpus) phyloNgrams []
 377
 378 phyloNgrams :: PhyloNgrams
 379 phyloNgrams = Vector.fromList cleanedActants
 380
 381 cleanedActants :: [Ngrams]
 382 cleanedActants = map toLower actants
 383
 384 actants :: [Ngrams]
 385 actants = [ "Cleopatre"   , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
 386           , "Marc-Antoine", "Cesar"   , "Antoine"      , "Octave"  , "Rome"
 387           , "Alexandrie"  , "Auguste" , "Pompee"       , "Cassius" , "Brutus"]
 388
 389
 390 ------------------------------------------------------------------------
 391 -- | STEP 1 | -- Get a corpus of Documents
 392
 393
 394 phyloCorpus :: Corpus
 395 phyloCorpus = map (\(d,t) -> Document d t) exampleDocuments
 396
 397 exampleDocuments :: [(Date, Text)]
 398 exampleDocuments = 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")]
 399