Skip to content

haskell-gargantext
haskell-gargantext
Commit ed5f22e1 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

add a json conf to Main.hs and fix issue between foundations, roots & termLists

parent 81094b10
Pipeline #371 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 111 additions and 185 deletions
    bin/gargantext-phylo/Main.hs
    View file @ ed5f22e1
    ...@@ -30,6 +30,7 @@ import Gargantext.Prelude ...@@ -30,6 +30,7 @@ import Gargantext.Prelude
    import Gargantext.Text.List.CSV (csvGraphTermList) import Gargantext.Text.List.CSV (csvGraphTermList)
    import Gargantext.Text.Parsers.CSV (readCsv, csv_title, csv_abstract, csv_publication_year) import Gargantext.Text.Parsers.CSV (readCsv, csv_title, csv_abstract, csv_publication_year)
    import Gargantext.Text.Terms.WithList import Gargantext.Text.Terms.WithList
    import Gargantext.Text.Context (TermList)
    import System.Environment import System.Environment
    ...@@ -46,17 +47,33 @@ import qualified Data.Text as DT ...@@ -46,17 +47,33 @@ import qualified Data.Text as DT
    import qualified Prelude as P import qualified Prelude as P
    import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
    ------------------------------------------------------------------------
    -- Format to produce the Phylo
    data TextsByYear =
    TextsByYear { year :: Int
    , texts :: [[Text]]
    } deriving (Show, Generic)
    instance ToJSON TextsByYear --------------
    -- | Conf | --
    --------------
    type ListPath = FilePath
    type CorpusPath = FilePath
    type Limit = Int
    data Conf =
    Conf { corpusPath :: CorpusPath
    , listPath :: ListPath
    , outputPath :: FilePath
    , limit :: Limit
    } deriving (Show,Generic)
    instance FromJSON Conf
    instance ToJSON Conf
    -- | Get the conf from a Json file
    getJson :: FilePath -> IO L.ByteString
    getJson path = L.readFile path
    ---------------
    -- | Parse | --
    ---------------
    instance ToJSON Document
    ------------------------------------------------------------------------
    filterTerms :: Patterns -> (a, Text) -> (a, [Text]) filterTerms :: Patterns -> (a, Text) -> (a, [Text])
    filterTerms patterns (year', doc) = (year',termsInText patterns doc) filterTerms patterns (year', doc) = (year',termsInText patterns doc)
    ...@@ -71,53 +88,49 @@ csvToCorpus limit csv = DV.toList ...@@ -71,53 +88,49 @@ csvToCorpus limit csv = DV.toList
    . DV.map (\n -> (csv_publication_year n, (csv_title n) <> " " <> (csv_abstract n))) . DV.map (\n -> (csv_publication_year n, (csv_title n) <> " " <> (csv_abstract n)))
    . snd <$> readCsv csv . snd <$> readCsv csv
    type ListPath = FilePath parse :: Limit -> CorpusPath -> TermList -> IO [Document]
    type CorpusPath = FilePath parse limit corpus lst = do
    type Limit = Int
    parse :: Limit -> CorpusPath -> ListPath -> IO [Document]
    parse limit corpus liste = do
    corpus' <- csvToCorpus limit corpus corpus' <- csvToCorpus limit corpus
    liste' <- csvGraphTermList liste let patterns = buildPatterns lst
    let patterns = buildPatterns liste'
    pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) corpus' pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) corpus'
    --------------
    -- | Main | --
    --------------
    main :: IO () main :: IO ()
    main = do main = do
    -- [corpusPath, termListPath, outputPath] <- getArgs
    let corpusPath = "/home/qlobbe/data/epique/corpus/cultural_evolution/texts/fullCorpus.csv" putStrLn $ show "--| Read the conf |--"
    let termListPath = "/home/qlobbe/data/epique/corpus/cultural_evolution/termList.csv"
    let outputPath = "/home/qlobbe/data/epique/output/cultural_evolution.dot"
    let query = PhyloQueryBuild "cultural_evolution" "" 5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.00001 10) [jsonPath] <- getArgs
    2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.5 10)
    let queryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
    putStrLn $ show "-- Start parsing the corpus" confJson <- (eitherDecode <$> getJson jsonPath) :: IO (P.Either P.String Conf)
    corpus <- parse 2000 corpusPath termListPath case confJson of
    P.Left err -> putStrLn err
    P.Right conf -> do
    let foundations = DL.nub $ DL.concat $ map text corpus putStrLn $ show "--| Parse the corpus |--"
    -- putStrLn $ show (map text corpus) termList <- csvGraphTermList (listPath conf)
    -- foundations <- DL.concat <$> DL.concat <$> map snd <$> csvGraphTermList termListPath corpus <- parse (limit conf) (corpusPath conf) termList
    -- putStrLn $ show foundations let roots = DL.nub $ DL.concat $ map text corpus
    -- a <- map snd <$> csvGraphTermList liste putStrLn $ show "--| Build the phylo |--"
    let query = PhyloQueryBuild "cultural_evolution" "" 5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.00001 10) 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.5 10)
    let phylo = toPhylo query corpus foundations [] let queryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
    let view = toPhyloView queryView phylo let phylo = toPhylo query corpus roots termList
    -- TODO Phylo here let view = toPhyloView queryView phylo
    P.writeFile outputPath $ dotToString $ viewToDot view
    -- L.writeFile outputPath $ encode corpus
    putStrLn $ show "--| Export the phylo as a dot graph |--"
    P.writeFile (outputPath conf) $ dotToString $ viewToDot view
    src/Gargantext/Viz/Phylo.hs
    View file @ ed5f22e1
    ...@@ -41,6 +41,7 @@ import Data.Vector (Vector) ...@@ -41,6 +41,7 @@ import Data.Vector (Vector)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    --import Gargantext.Database.Schema.Ngrams (NgramsId) --import Gargantext.Database.Schema.Ngrams (NgramsId)
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Text.Context (TermList)
    import Gargantext.Prelude import Gargantext.Prelude
    -------------------- --------------------
    ...@@ -74,23 +75,18 @@ data Software = ...@@ -74,23 +75,18 @@ data Software =
    -- Periods : list of all the periods of a Phylo -- Periods : list of all the periods of a Phylo
    data Phylo = data Phylo =
    Phylo { _phylo_duration :: (Start, End) Phylo { _phylo_duration :: (Start, End)
    , _phylo_foundations :: Vector Ngrams , _phylo_foundations :: PhyloFoundations
    , _phylo_foundationsRoots :: PhyloRoots
    , _phylo_periods :: [PhyloPeriod] , _phylo_periods :: [PhyloPeriod]
    , _phylo_param :: PhyloParam , _phylo_param :: PhyloParam
    } }
    deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
    -- | The PhyloRoots describe the aggregation of some foundations Ngrams behind a list of Ngrams trees (ie: a forest)
    -- PeaksLabels are the root labels of each Ngrams trees
    data PhyloRoots =
    PhyloRoots { _phylo_rootsLabels :: Vector Ngrams
    , _phylo_rootsForest :: [Tree Ngrams]
    }
    deriving (Generic, Show, Eq)
    -- | A Tree of Ngrams where each node is a label -- | The foundations of a phylomemy created from a given TermList
    data Tree a = Empty | Node a [Tree a] deriving (Generic, Show, Eq) data PhyloFoundations =
    PhyloFoundations { _phylo_foundationsRoots :: Vector Ngrams
    , _phylo_foundationsTermsList :: TermList
    } deriving (Generic, Show, Eq)
    -- | Date : a simple Integer -- | Date : a simple Integer
    ...@@ -443,7 +439,7 @@ makeLenses ''PhyloParam ...@@ -443,7 +439,7 @@ makeLenses ''PhyloParam
    makeLenses ''Software makeLenses ''Software
    -- --
    makeLenses ''Phylo makeLenses ''Phylo
    makeLenses ''PhyloRoots makeLenses ''PhyloFoundations
    makeLenses ''PhyloGroup makeLenses ''PhyloGroup
    makeLenses ''PhyloLevel makeLenses ''PhyloLevel
    makeLenses ''PhyloPeriod makeLenses ''PhyloPeriod
    ...@@ -468,8 +464,7 @@ makeLenses ''PhyloEdge ...@@ -468,8 +464,7 @@ makeLenses ''PhyloEdge
    $(deriveJSON (unPrefix "_phylo_" ) ''Phylo ) $(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
    $(deriveJSON (unPrefix "_phylo_roots" ) ''PhyloRoots ) $(deriveJSON (unPrefix "_phylo_foundations" ) ''PhyloFoundations )
    $(deriveJSON defaultOptions ''Tree )
    $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod ) $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
    $(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel ) $(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
    $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup ) $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
    ......
    src/Gargantext/Viz/Phylo/API.hs
    View file @ ed5f22e1
    ...@@ -103,7 +103,7 @@ postPhylo _n _lId q = do ...@@ -103,7 +103,7 @@ postPhylo _n _lId q = do
    vrs = Just ("1" :: Text) vrs = Just ("1" :: Text)
    sft = Just (Software "Gargantext" "4") sft = Just (Software "Gargantext" "4")
    prm = initPhyloParam vrs sft (Just q) prm = initPhyloParam vrs sft (Just q)
    pure (toPhyloBase q prm corpus actants actantsTrees) pure (toPhyloBase q prm corpus actants termList)
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    ...@@ -144,7 +144,7 @@ instance ToSchema PhyloGroup ...@@ -144,7 +144,7 @@ instance ToSchema PhyloGroup
    instance ToSchema PhyloLevel instance ToSchema PhyloLevel
    instance ToSchema PhyloNode instance ToSchema PhyloNode
    instance ToSchema PhyloParam instance ToSchema PhyloParam
    instance ToSchema PhyloRoots instance ToSchema PhyloFoundations
    instance ToSchema PhyloPeriod instance ToSchema PhyloPeriod
    instance ToSchema PhyloQueryBuild instance ToSchema PhyloQueryBuild
    instance ToSchema PhyloView instance ToSchema PhyloView
    ...@@ -186,10 +186,6 @@ instance FromHttpApiData Sort ...@@ -186,10 +186,6 @@ instance FromHttpApiData Sort
    parseUrlPiece = readTextData parseUrlPiece = readTextData
    instance ToParamSchema Sort instance ToParamSchema Sort
    instance (ToSchema a) => ToSchema (Tree a)
    where
    declareNamedSchema = genericDeclareNamedSchemaUnrestricted
    $ swaggerOptions ""
    instance ToSchema Proximity instance ToSchema Proximity
    where where
    ......
    src/Gargantext/Viz/Phylo/Aggregates/Document.hs
    View file @ ed5f22e1
    ...@@ -17,17 +17,14 @@ Portability : POSIX ...@@ -17,17 +17,14 @@ Portability : POSIX
    module Gargantext.Viz.Phylo.Aggregates.Document module Gargantext.Viz.Phylo.Aggregates.Document
    where where
    import Control.Lens hiding (both, Level) import Data.List (last)
    import Data.Map (Map)
    import Data.List (last,nub,(++))
    import Data.Map (Map,member)
    import Data.Text (Text) import Data.Text (Text)
    import Data.Tuple (fst, snd) import Data.Tuple (fst)
    import Data.Vector (Vector) import Data.Vector (Vector)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Text.Terms.Mono (monoTexts) import Gargantext.Text.Terms.Mono (monoTexts)
    import Gargantext.Viz.Phylo import Gargantext.Viz.Phylo
    import Gargantext.Viz.Phylo.Tools
    import qualified Data.List as List import qualified Data.List as List
    import qualified Data.Map as Map import qualified Data.Map as Map
    import qualified Data.Vector as Vector import qualified Data.Vector as Vector
    ...@@ -50,27 +47,11 @@ groupDocsByPeriod f pds es = Map.fromList $ zip pds $ map (inPeriode f es) pds ...@@ -50,27 +47,11 @@ groupDocsByPeriod f pds es = Map.fromList $ zip pds $ map (inPeriode f es) pds
    fst $ List.partition (\d -> f' d >= start && f' d <= end) h fst $ List.partition (\d -> f' d >= start && f' d <= end) h
    -------------------------------------- --------------------------------------
    -- | Reduce a list of foundations as a list of corresponding roots
    reduceByRoots :: Map Ngrams Ngrams -> [Ngrams] -> [Ngrams]
    reduceByRoots m ns = (\(f,s) -> f ++ (nub s))
    $ foldl (\mem n -> if member n m
    then (fst mem,(snd mem) ++ [m Map.! n])
    else ((fst mem) ++ [n],snd mem)
    ) ([],[]) ns
    -- | To parse a list of Documents by filtering on a Vector of Ngrams -- | To parse a list of Documents by filtering on a Vector of Ngrams
    parseDocs :: Vector Ngrams -> PhyloRoots -> [(Date,Text)] -> [Document] parseDocs :: Vector Ngrams -> [(Date,Text)] -> [Document]
    parseDocs fds roots c = map (\(d,t) parseDocs roots c = map (\(d,t)
    -> Document d ( reduceByRoots mRoots -> Document d ( filter (\x -> Vector.elem x roots)
    $ filter (\x -> Vector.elem x fds) $ monoTexts t)) c
    $ monoTexts t)) c
    where
    --------------------------------------
    mRoots :: Map Ngrams Ngrams
    mRoots = forestToMap (roots ^. phylo_rootsForest)
    --------------------------------------
    -- | To transform a Corpus of texts into a Map of aggregated Documents grouped by Periods
    src/Gargantext/Viz/Phylo/Example.hs
    View file @ ed5f22e1
    ...@@ -36,6 +36,7 @@ import Data.Tuple (fst) ...@@ -36,6 +36,7 @@ import Data.Tuple (fst)
    import Data.Tuple.Extra import Data.Tuple.Extra
    import Data.Vector (Vector) import Data.Vector (Vector)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Text.Context (TermList)
    import Gargantext.Viz.Phylo import Gargantext.Viz.Phylo
    import Gargantext.Viz.Phylo.Aggregates.Cluster import Gargantext.Viz.Phylo.Aggregates.Cluster
    import Gargantext.Viz.Phylo.Aggregates.Document import Gargantext.Viz.Phylo.Aggregates.Document
    ...@@ -85,7 +86,7 @@ phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] ...@@ -85,7 +86,7 @@ phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch]
    phyloFromQuery :: Phylo phyloFromQuery :: Phylo
    phyloFromQuery = toPhylo (queryParser queryEx) corpus actants actantsTrees phyloFromQuery = toPhylo (queryParser queryEx) corpus actants termList
    -- | To do : create a request handler and a query parser -- | To do : create a request handler and a query parser
    queryParser :: [Char] -> PhyloQueryBuild queryParser :: [Char] -> PhyloQueryBuild
    ...@@ -223,36 +224,27 @@ phyloDocs = corpusToDocs corpus phyloBase ...@@ -223,36 +224,27 @@ phyloDocs = corpusToDocs corpus phyloBase
    phyloBase :: Phylo phyloBase :: Phylo
    phyloBase = initPhyloBase periods foundations roots defaultPhyloParam phyloBase = initPhyloBase periods (PhyloFoundations foundationsRoots termList) defaultPhyloParam
    periods :: [(Date,Date)] periods :: [(Date,Date)]
    periods = initPeriods 5 3 periods = initPeriods 5 3
    $ both fst (head' "Example" corpus,last corpus) $ both fst (head' "Example" corpus,last corpus)
    foundationsRoots :: Vector Ngrams
    roots :: PhyloRoots foundationsRoots = initFoundationsRoots actants
    roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) actantsTrees) foundations
    foundations :: Vector Ngrams
    foundations = initFoundations actants
    -------------------------------------------- --------------------------------------------
    -- | STEP 0 | -- Let's start with an example -- | STEP 0 | -- Let's start with an example
    -------------------------------------------- --------------------------------------------
    actantsTrees :: [Tree Ngrams] termList :: TermList
    actantsTrees = [] termList = []
    -- actantsTrees = [Node "Cite antique" [(Node "Rome" []),(Node "Alexandrie" [])]]
    actants :: [Ngrams] actants :: [Ngrams]
    actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV" actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
    , "Marc-Antoine", "Cesar" , "Antoine" , "Octave" , "Rome" , "Marc-Antoine", "Cesar" , "Antoine" , "Octave" , "Rome"
    , "Alexandrie" , "Auguste" , "Pompee" , "Cassius" , "Brutus"] , "Alexandrie" , "Auguste" , "Pompee" , "Cassius" , "Brutus"]
    corpus :: [(Date, Text)] corpus :: [(Date, Text)]
    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")] 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")]
    src/Gargantext/Viz/Phylo/LevelMaker.hs
    View file @ ed5f22e1
    ...@@ -24,7 +24,6 @@ import Data.List ((++), sort, concat, nub, zip, last) ...@@ -24,7 +24,6 @@ import Data.List ((++), sort, concat, nub, zip, last)
    import Data.Map (Map, (!), empty, restrictKeys, filterWithKey, singleton, union) import Data.Map (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
    import Data.Text (Text) import Data.Text (Text)
    import Data.Tuple.Extra import Data.Tuple.Extra
    import Data.Vector (Vector)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Viz.Phylo import Gargantext.Viz.Phylo
    import Gargantext.Viz.Phylo.Aggregates.Cluster import Gargantext.Viz.Phylo.Aggregates.Cluster
    ...@@ -34,6 +33,7 @@ import Gargantext.Viz.Phylo.Aggregates.Fis ...@@ -34,6 +33,7 @@ import Gargantext.Viz.Phylo.Aggregates.Fis
    import Gargantext.Viz.Phylo.BranchMaker import Gargantext.Viz.Phylo.BranchMaker
    import Gargantext.Viz.Phylo.LinkMaker import Gargantext.Viz.Phylo.LinkMaker
    import Gargantext.Viz.Phylo.Tools import Gargantext.Viz.Phylo.Tools
    import Gargantext.Text.Context (TermList)
    import qualified Data.Set as Set import qualified Data.Set as Set
    ...@@ -190,14 +190,14 @@ toPhylo0 d p = addPhyloLevel 0 d p ...@@ -190,14 +190,14 @@ toPhylo0 d p = addPhyloLevel 0 d p
    class PhyloMaker corpus class PhyloMaker corpus
    where where
    toPhylo :: PhyloQueryBuild -> corpus -> [Ngrams] -> [Tree Ngrams] -> Phylo toPhylo :: PhyloQueryBuild -> corpus -> [Ngrams] -> TermList -> Phylo
    toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> [Tree Ngrams] -> Phylo toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> TermList -> Phylo
    corpusToDocs :: corpus -> Phylo -> Map (Date,Date) [Document] corpusToDocs :: corpus -> Phylo -> Map (Date,Date) [Document]
    instance PhyloMaker [(Date, Text)] instance PhyloMaker [(Date, Text)]
    where where
    -------------------------------------- --------------------------------------
    toPhylo q c a ts = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1 toPhylo q c roots termList = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
    where where
    -------------------------------------- --------------------------------------
    phylo1 :: Phylo phylo1 :: Phylo
    ...@@ -210,30 +210,27 @@ instance PhyloMaker [(Date, Text)] ...@@ -210,30 +210,27 @@ instance PhyloMaker [(Date, Text)]
    phyloDocs = corpusToDocs c phyloBase phyloDocs = corpusToDocs c phyloBase
    -------------------------------------- --------------------------------------
    phyloBase :: Phylo phyloBase :: Phylo
    phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c a ts phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList
    -------------------------------------- --------------------------------------
    -------------------------------------- --------------------------------------
    toPhyloBase q p c a ts = initPhyloBase periods foundations roots p toPhyloBase q p c roots termList = initPhyloBase periods foundations p
    where where
    -------------------------------------- --------------------------------------
    roots :: PhyloRoots foundations :: PhyloFoundations
    roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) ts) foundations foundations = PhyloFoundations (initFoundationsRoots roots) termList
    -------------------------------------- --------------------------------------
    periods :: [(Date,Date)] periods :: [(Date,Date)]
    periods = initPeriods (getPeriodGrain q) (getPeriodSteps q) periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
    $ both fst (head' "LevelMaker" c,last c) $ both fst (head' "LevelMaker" c,last c)
    -------------------------------------- --------------------------------------
    foundations :: Vector Ngrams
    foundations = initFoundations a
    --------------------------------------
    -------------------------------------- --------------------------------------
    corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p) $ parseDocs (getFoundations p) (getRoots p) c corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p) $ parseDocs (getFoundationsRoots p) c
    instance PhyloMaker [Document] instance PhyloMaker [Document]
    where where
    -------------------------------------- --------------------------------------
    toPhylo q c a ts = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1 toPhylo q c roots termList = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
    where where
    -------------------------------------- --------------------------------------
    phylo1 :: Phylo phylo1 :: Phylo
    ...@@ -246,21 +243,18 @@ instance PhyloMaker [Document] ...@@ -246,21 +243,18 @@ instance PhyloMaker [Document]
    phyloDocs = corpusToDocs c phyloBase phyloDocs = corpusToDocs c phyloBase
    -------------------------------------- --------------------------------------
    phyloBase :: Phylo phyloBase :: Phylo
    phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c a ts phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList
    -------------------------------------- --------------------------------------
    -------------------------------------- --------------------------------------
    toPhyloBase q p c a ts = initPhyloBase periods foundations roots p toPhyloBase q p c roots termList = initPhyloBase periods foundations p
    where where
    -------------------------------------- --------------------------------------
    roots :: PhyloRoots foundations :: PhyloFoundations
    roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) ts) foundations foundations = PhyloFoundations (initFoundationsRoots roots) termList
    -------------------------------------- --------------------------------------
    periods :: [(Date,Date)] periods :: [(Date,Date)]
    periods = initPeriods (getPeriodGrain q) (getPeriodSteps q) periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
    $ both date (head' "LevelMaker" c,last c) $ both date (head' "LevelMaker" c,last c)
    -------------------------------------- --------------------------------------
    foundations :: Vector Ngrams
    foundations = initFoundations a
    --------------------------------------
    -------------------------------------- --------------------------------------
    corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p) c corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p) c
    \ No newline at end of file
    src/Gargantext/Viz/Phylo/Tools.hs
    View file @ ed5f22e1
    ...@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.Tools ...@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.Tools
    where where
    import Control.Lens hiding (both, Level, Empty) import Control.Lens hiding (both, Level, Empty)
    import Data.List (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, concat, sortOn, nubBy) import Data.List (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy)
    import Data.Maybe (mapMaybe,fromMaybe) import Data.Maybe (mapMaybe,fromMaybe)
    import Data.Map (Map, mapKeys, member, (!)) import Data.Map (Map, mapKeys, member, (!))
    import Data.Set (Set) import Data.Set (Set)
    ...@@ -150,13 +150,13 @@ unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2 ...@@ -150,13 +150,13 @@ unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
    phyloAnalyzer :: Ngrams -> Ngrams phyloAnalyzer :: Ngrams -> Ngrams
    phyloAnalyzer n = toLower n phyloAnalyzer n = toLower n
    -- | To init the foundation of the Phylo as a Vector of Ngrams -- | To init the foundation roots of the Phylo as a Vector of Ngrams
    initFoundations :: [Ngrams] -> Vector Ngrams initFoundationsRoots :: [Ngrams] -> Vector Ngrams
    initFoundations l = Vector.fromList $ map phyloAnalyzer l initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
    -- | To init the base of a Phylo from a List of Periods and Foundations -- | To init the base of a Phylo from a List of Periods and Foundations
    initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloRoots -> PhyloParam -> Phylo initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> PhyloParam -> Phylo
    initPhyloBase pds fds pks prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds pks (map (\pd -> initPhyloPeriod pd []) pds) prm initPhyloBase pds fds prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) prm
    -- | To init the param of a Phylo -- | To init the param of a Phylo
    initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
    ...@@ -164,17 +164,6 @@ initPhyloParam (def defaultPhyloVersion -> v) ...@@ -164,17 +164,6 @@ initPhyloParam (def defaultPhyloVersion -> v)
    (def defaultSoftware -> s) (def defaultSoftware -> s)
    (def defaultQueryBuild -> q) = PhyloParam v s q (def defaultQueryBuild -> q) = PhyloParam v s q
    -- | To get the foundations of a Phylo
    getFoundations :: Phylo -> Vector Ngrams
    getFoundations = _phylo_foundations
    -- | To get the Index of a Ngrams in the Foundations of a Phylo
    getIdxInFoundations :: Ngrams -> Phylo -> Int
    getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
    Nothing -> panic "[ERR][Viz.Phylo.Tools.getIdxInFoundations] Ngrams not in Foundations"
    Just idx -> idx
    -- | To get the last computed Level in a Phylo -- | To get the last computed Level in a Phylo
    getLastLevel :: Phylo -> Level getLastLevel :: Phylo -> Level
    getLastLevel p = (last . sort) getLastLevel p = (last . sort)
    ...@@ -188,54 +177,20 @@ getLastLevel p = (last . sort) ...@@ -188,54 +177,20 @@ getLastLevel p = (last . sort)
    -- | PhyloRoots | -- -- | PhyloRoots | --
    -------------------- --------------------
    -- | To apply a fonction to each label of a Ngrams Tree -- | To get the foundations of a Phylo
    alterLabels :: (Ngrams -> Ngrams) -> Tree Ngrams -> Tree Ngrams getFoundations :: Phylo -> PhyloFoundations
    alterLabels f (Node lbl ns) = Node (f lbl) (map (\n -> alterLabels f n) ns) getFoundations = _phylo_foundations
    alterLabels _ Empty = panic "[ERR][Viz.Phylo.Tools.alterLabels] Empty"
    -- | To transform a forest of trees into a map (node,root)
    forestToMap :: [Tree Ngrams] -> Map Ngrams Ngrams
    forestToMap trees = Map.fromList $ concat $ map treeToTuples' trees
    where
    treeToTuples' (Node lbl ns) = treeToTuples (Node lbl ns) lbl
    treeToTuples' Empty = panic "[ERR][Viz.Phylo.Tools.forestToMap] Empty"
    -- | To get the foundationsRoots of a Phylo
    getRoots :: Phylo -> PhyloRoots
    getRoots = _phylo_foundationsRoots
    -- | To get the RootsLabels of a Phylo -- | To get the foundations roots of a Phylo
    getRootsLabels :: Phylo -> Vector Ngrams getFoundationsRoots :: Phylo -> Vector Ngrams
    getRootsLabels p = (getRoots p) ^. phylo_rootsLabels getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
    -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
    getIdxInRoots :: Ngrams -> Phylo -> Int getIdxInRoots :: Ngrams -> Phylo -> Int
    getIdxInRoots n p = case (elemIndex n (getRootsLabels p)) of getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
    Nothing -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots" Nothing -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
    Just idx -> idx Just idx -> idx
    -- | To init the PhyloRoots of a Phylo
    initRoots :: [Tree Ngrams] -> Vector Ngrams -> PhyloRoots
    initRoots trees ns = PhyloRoots labels trees
    where
    --------------------------------------
    labels :: Vector Ngrams
    labels = Vector.fromList
    $ nub
    $ Vector.toList
    $ map (\n -> if member n mTrees
    then mTrees Map.! n
    else n ) ns
    --------------------------------------
    mTrees :: Map Ngrams Ngrams
    mTrees = forestToMap trees
    --------------------------------------
    -- | To transform a Ngrams Tree into a list of (node,root)
    treeToTuples :: Tree Ngrams -> Ngrams -> [(Ngrams,Ngrams)]
    treeToTuples (Node lbl ns) root = [(lbl,root)] ++ (concat $ map (\n -> treeToTuples n root) ns)
    treeToTuples Empty _ = panic "[ERR][Viz.Phylo.Tools.treeToTuples] Empty"
    -------------------- --------------------
    -- | PhyloGroup | -- -- | PhyloGroup | --
    -------------------- --------------------
    ...@@ -355,7 +310,7 @@ getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g ...@@ -355,7 +310,7 @@ getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g
    -- | To get the roots labels of a list of group ngrams -- | To get the roots labels of a list of group ngrams
    getGroupText :: PhyloGroup -> Phylo -> [Text] getGroupText :: PhyloGroup -> Phylo -> [Text]
    getGroupText g p = ngramsToText (getRootsLabels p) (getGroupNgrams g) getGroupText g p = ngramsToText (getFoundationsRoots p) (getGroupNgrams g)
    -- | To get all the PhyloGroup of a Phylo -- | To get all the PhyloGroup of a Phylo
    ......
    src/Gargantext/Viz/Phylo/View/Taggers.hs
    View file @ ed5f22e1
    ...@@ -65,7 +65,7 @@ alterBranchPeak (id,lbl) v = over (pv_branches ...@@ -65,7 +65,7 @@ alterBranchPeak (id,lbl) v = over (pv_branches
    -- | To set the peak of a PhyloBranch as the nth most frequent terms of its PhyloNodes -- | To set the peak of a PhyloBranch as the nth most frequent terms of its PhyloNodes
    branchPeakFreq :: PhyloView -> Int -> Phylo -> PhyloView branchPeakFreq :: PhyloView -> Int -> Phylo -> PhyloView
    branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
    $ map (\(id,ns) -> (id, freqToLabel thr (getRootsLabels p) $ map (\(id,ns) -> (id, freqToLabel thr (getFoundationsRoots p)
    $ getGroupsFromNodes ns p)) $ getGroupsFromNodes ns p))
    $ getNodesByBranches v $ getNodesByBranches v
    ...@@ -74,7 +74,7 @@ branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v ...@@ -74,7 +74,7 @@ branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
    nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
    nodeLabelCooc v thr p = over (pv_nodes nodeLabelCooc v thr p = over (pv_nodes
    . traverse) . traverse)
    (\n -> let lbl = ngramsToLabel (getRootsLabels p) (\n -> let lbl = ngramsToLabel (getFoundationsRoots p)
    $ mostOccNgrams thr $ mostOccNgrams thr
    $ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p $ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
    in n & pn_label .~ lbl) v in n & pn_label .~ lbl) v
    ......
    src/Gargantext/Viz/Phylo/View/ViewMaker.hs
    View file @ ed5f22e1
    ...@@ -49,7 +49,7 @@ initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl ...@@ -49,7 +49,7 @@ initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl
    (getPhyloPeriods p) (getPhyloPeriods p)
    empty empty
    ([] ++ (phyloToBranches lvl p)) ([] ++ (phyloToBranches lvl p))
    ([] ++ (groupsToNodes True vb (getRootsLabels p) gs)) ([] ++ (groupsToNodes True vb (getFoundationsRoots p) gs))
    ([] ++ (groupsToEdges fl PeriodEdge gs)) ([] ++ (groupsToEdges fl PeriodEdge gs))
    where where
    -------------------------------------- --------------------------------------
    ...@@ -123,7 +123,7 @@ addChildNodes shouldDo lvl lvlMin vb fl p v = ...@@ -123,7 +123,7 @@ addChildNodes shouldDo lvl lvlMin vb fl p v =
    then v then v
    else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
    $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p)) $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
    & pv_nodes %~ (++ (groupsToNodes False vb (getRootsLabels p) gs')) & pv_nodes %~ (++ (groupsToNodes False vb (getFoundationsRoots p) gs'))
    & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs')) & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
    & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs )) & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
    & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge gs')) & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
    ......
    Markdown is supported
    0% or
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment