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
  41 import Data.Set (Set)
  42 import qualified Data.Set as DS
  43 import qualified Data.Matrix as DM'
  44
  45 import Gargantext.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
  46 import Gargantext.Text.Terms.Mono (monoTexts)
  47 import Gargantext.Prelude
  48 import Gargantext.Viz.Phylo
  49
  50 ------------------------------------------------------------------------
  51 -- | Types | --
  52
  53
  54 -- | Date : a simple Integer
  55 type Date = Int
  56 -- | Document : a piece of Text linked to a Date
  57 data Document = Document
  58       { date :: Date
  59       , text :: Text
  60       } deriving (Show)
  61 -- | Corpus : a list of Documents
  62 type Corpus   = [Document]
  63
  64
  65 type MapList = [Ngrams]
  66 type PeriodeSize = Int
  67 -- data Periodes b a = Map (b,b) a
  68 type Occurrences = Int
  69
  70 data Levels = Level_m1 | Level_0 | Level_1 | Level_2 | Level_N
  71   deriving (Show, Eq, Enum, Bounded)
  72
  73 data LinkLevels = Link_m1To0 | Link_0To1 | Link_mxTox
  74   deriving (Show, Eq, Enum, Bounded)
  75
  76 data PhyloError = LevelDoesNotExist
  77                 | LevelUnassigned
  78           deriving (Show)
  79
  80
  81 --------------------------------------------------------------------
  82 phyloExampleFinal :: Phylo
  83 phyloExampleFinal = undefined
  84
  85 --------------------------------------------------------------------
  86 appariement :: Map (Date, Date) (Map (Set Ngrams) Int)
  87 appariement = undefined
  88
  89 ------------------------------------------------------------------------
  90 -- | STEP 10 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
  91
  92
  93 ------------------------------------------------------------------------
  94 -- | STEP 9 | -- Link the PhyloGroups of level 1 through the Periods
  95
  96
  97 ------------------------------------------------------------------------
  98 -- | STEP 8 | -- Cluster the Fis and buil level 1 of the Phylo
  99
 100
 101 ------------------------------------------------------------------------
 102 -- | STEP 7 | -- Find the Fis out of Documents and Ngrams and build level 1 of the Phylo
 103
 104
 105 phyloFis :: Map (Date, Date) Fis
 106 phyloFis = termsToFis phyloTerms
 107
 108 termsToFis :: Map (Date, Date) [Document]
 109     -> Map (Date, Date) Fis
 110 termsToFis = corpusToFis (words . text)
 111
 112 -- | TODO: parameters has to be checked
 113 -- | TODO FIS on monotexts
 114 corpusToFis :: (Document -> [Ngrams])
 115       -> Map (Date, Date) [Document]
 116       -> Map (Date, Date) (Map (Set Ngrams) Int)
 117 corpusToFis f = Map.map (\d -> fisWithSizePolyMap (Segment 1 20) 1 (map f d))
 118
 119
 120 ------------------------------------------------------------------------
 121 -- | STEP 6 | -- Link level 0 to level -1
 122
 123
 124 addPointer :: Semigroup field
 125            => ASetter current target identity (field -> field)
 126            -> field -> current -> target
 127 addPointer field targetPointer current =
 128   set field (<> targetPointer) current
 129
 130 containsIdx :: [Int] -> [Int] -> Bool
 131 containsIdx l l'
 132   | List.null l' = False
 133   | List.last l < List.head l' = False
 134   | List.head l' `List.elem` l = True
 135   | otherwise = containsIdx l (List.tail l')
 136
 137 shouldLink :: LinkLevels -> PhyloGroup -> PhyloGroup -> Bool
 138 shouldLink lvl current target = case lvl of
 139   Link_m1To0  -> containsIdx (_phylo_groupNgrams target) (_phylo_groupNgrams current)
 140   Link_0To1   -> containsIdx (_phylo_groupNgrams target) (_phylo_groupNgrams current)
 141   Link_mxTox  -> undefined
 142   _           -> panic ("error link level to be defined")
 143
 144
 145 ------------------------------------------------------------------------
 146 -- | STEP 5 | -- Build level 0 (for the moment it's just a durty copy of level -1)
 147
 148
 149 setGroupIdLvl :: Int -> PhyloGroup -> PhyloGroup
 150 setGroupIdLvl lvl (PhyloGroup ((period, lvl'), idx) gLabel gNgrams gPP gPC gLP gLC)
 151   = PhyloGroup ((period, lvl), idx) gLabel gNgrams gPP gPC gLP gLC
 152
 153 setPhyloLevel :: Int -> PhyloLevel -> PhyloLevel
 154 setPhyloLevel lvl (PhyloLevel (periodId, lvl') lvlGroups)
 155   = PhyloLevel (periodId, lvl) lvlGroups'
 156     where
 157       lvlGroups' = map (\g -> setGroupIdLvl lvl g) lvlGroups
 158
 159 copyPhyloLevel :: Int -> [PhyloLevel] -> [PhyloLevel]
 160 copyPhyloLevel lvl l = (setPhyloLevel lvl (List.head l)) : l
 161
 162 alterLvl :: Int -> [PhyloPeriod] -> [PhyloPeriod]
 163 alterLvl lvl l = map (\p -> PhyloPeriod (_phylo_periodId p) (copyPhyloLevel lvl $ _phylo_periodLevels p)) l
 164
 165 phyloWithGroups0 :: Phylo
 166 phyloWithGroups0 = updatePhyloByLevel Level_0 phyloWithGroupsm1
 167
 168
 169 ------------------------------------------------------------------------
 170 -- | STEP 4 | -- Build level -1
 171
 172
 173 findIdx :: Ngrams -> Int
 174 findIdx n = case (Vector.elemIndex n (_phylo_ngrams phylo)) of
 175               Nothing -> panic "PhyloError"
 176               Just i  -> i
 177
 178 ngramsToGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> PhyloGroup
 179 ngramsToGroup terms label idx lvl from to = PhyloGroup (((from, to), lvl), idx) label (List.sort (map (\x -> findIdx x) terms)) [] [] [] []
 180
 181 docsToLevel :: (Date, Date) -> Corpus -> PhyloLevel
 182 docsToLevel k v = PhyloLevel (k,(-1)) (map (\x ->
 183                           ngramsToGroup [Tuple.snd x] (Tuple.snd x) (Tuple.fst x) (-1) (Tuple.fst k) (Tuple.snd k)
 184                        ) $ zip [1..] $ (List.nub . List.concat) $ map (words . text) v)
 185
 186 corpusToPhyloPeriod :: Map (Date,Date) Corpus -> [PhyloPeriod]
 187 corpusToPhyloPeriod corpus = map (\x -> PhyloPeriod (Tuple.fst x) [(Tuple.snd x)]) $ zip (Map.keys mapLvl) (Map.elems mapLvl)
 188     where
 189       mapLvl :: Map (Date,Date) PhyloLevel
 190       mapLvl = Map.mapWithKey docsToLevel corpus
 191
 192 updatePhyloByLevel :: Levels -> Phylo -> Phylo
 193 updatePhyloByLevel lvl (Phylo pDuration pNgrams pPeriods)
 194   = case lvl of
 195
 196     Level_m1 -> Phylo pDuration pNgrams pPeriods'
 197       where pPeriods' = (corpusToPhyloPeriod phyloTerms) List.++ pPeriods
 198
 199     Level_0  -> Phylo pDuration pNgrams pPeriods'
 200       where pPeriods' = alterLvl 0 pPeriods
 201
 202     _        -> panic ("error level to be defined")
 203
 204 phyloWithGroupsm1 :: Phylo
 205 phyloWithGroupsm1 = updatePhyloByLevel Level_m1 phylo
 206
 207
 208 ------------------------------------------------------------------------
 209 -- | STEP 3 | -- Split the Corpus into Periods and reduce each Document as a list of Ngrams
 210
 211
 212 phyloTerms :: Map (Date, Date) [Document]
 213 phyloTerms = toPeriodes date 5 3 $ cleanCorpus cleanedActants phyloCorpus
 214
 215 toPeriodes :: (Ord date, Enum date) => (doc -> date)
 216      -> Grain -> Step -> [doc] -> Map (date, date) [doc]
 217 toPeriodes _ _ _ [] = panic "Empty corpus can not have any periods"
 218 toPeriodes f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
 219   where
 220     hs = steps g s $ both f (List.head es, List.last es)
 221     --------------------------------------------------------------------
 222     -- | Define overlapping periods of time by following regular steps
 223     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
 224     inPeriode f' h (start,end) =
 225       fst $ List.partition (\d -> f' d >= start && f' d <= end) h
 226     --------------------------------------------------------------------
 227     -- | Find steps of linear and homogenous time of integer
 228     steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
 229     steps s' o' (start,end) = map (\l -> (List.head l, List.last l))
 230                           $ chunkAlong s' o' [start .. end]
 231
 232 cleanCorpus :: MapList -> Corpus -> Corpus
 233 cleanCorpus ml = map (\(Document d t) -> Document d (unwords $ filter (\x -> elem  x ml) $ monoTexts t))
 234
 235
 236 ------------------------------------------------------------------------
 237 -- | STEP 2 | -- Find some Ngrams (ie: phyloGroup of level -1) out of the Corpus & init the phylo
 238
 239
 240 phylo = Phylo (both date $ (List.last &&& List.head) phyloCorpus) phyloNgrams []
 241
 242 phyloNgrams :: PhyloNgrams
 243 phyloNgrams = Vector.fromList cleanedActants
 244
 245 cleanedActants :: [Ngrams]
 246 cleanedActants = map toLower actants
 247
 248 actants :: [Ngrams]
 249 actants = [ "Cleopatre"   , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
 250           , "Marc-Antoine", "Cesar"   , "Antoine"      , "Octave"  , "Rome"
 251           , "Alexandrie"  , "Auguste" , "Pompee"       , "Cassius" , "Brutus"]
 252
 253
 254 ------------------------------------------------------------------------
 255 -- | STEP 1 | -- Get a corpus of Documents
 256
 257
 258 phyloCorpus :: Corpus
 259 phyloCorpus = map (\(d,t) -> Document d t) exampleDocuments
 260
 261 exampleDocuments :: [(Date, Text)]
 262 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")]
 263