From ed5f22e1a73c91ad10bf8ec1268db9451d20eaad Mon Sep 17 00:00:00 2001
From: qlobbe <quentin.lobbe@gmail.com>
Date: Mon, 6 May 2019 17:34:55 +0200
Subject: [PATCH] add a json conf to Main.hs and fix issue between foundations,
roots & termLists
---
bin/gargantext-phylo/Main.hs | 93 +++++++++++--------
src/Gargantext/Viz/Phylo.hs | 23 ++---
src/Gargantext/Viz/Phylo/API.hs | 8 +-
.../Viz/Phylo/Aggregates/Document.hs | 35 ++-----
src/Gargantext/Viz/Phylo/Example.hs | 22 ++---
src/Gargantext/Viz/Phylo/LevelMaker.hs | 34 +++----
src/Gargantext/Viz/Phylo/Tools.hs | 73 +++------------
src/Gargantext/Viz/Phylo/View/Taggers.hs | 4 +-
src/Gargantext/Viz/Phylo/View/ViewMaker.hs | 4 +-
9 files changed, 111 insertions(+), 185 deletions(-)
diff --git a/bin/gargantext-phylo/Main.hs b/bin/gargantext-phylo/Main.hs
index 758700e5..486bd70f 100644
--- a/bin/gargantext-phylo/Main.hs
+++ b/bin/gargantext-phylo/Main.hs
@@ -30,6 +30,7 @@ import Gargantext.Prelude
import Gargantext.Text.List.CSV (csvGraphTermList)
import Gargantext.Text.Parsers.CSV (readCsv, csv_title, csv_abstract, csv_publication_year)
import Gargantext.Text.Terms.WithList
+import Gargantext.Text.Context (TermList)
import System.Environment
@@ -46,17 +47,33 @@ import qualified Data.Text as DT
import qualified Prelude as P
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 (year', doc) = (year',termsInText patterns doc)
@@ -71,53 +88,49 @@ csvToCorpus limit csv = DV.toList
. DV.map (\n -> (csv_publication_year n, (csv_title n) <> " " <> (csv_abstract n)))
. snd <$> readCsv csv
-type ListPath = FilePath
-type CorpusPath = FilePath
-type Limit = Int
-
-parse :: Limit -> CorpusPath -> ListPath -> IO [Document]
-parse limit corpus liste = do
+parse :: Limit -> CorpusPath -> TermList -> IO [Document]
+parse limit corpus lst = do
corpus' <- csvToCorpus limit corpus
- liste' <- csvGraphTermList liste
- let patterns = buildPatterns liste'
+ let patterns = buildPatterns lst
pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) corpus'
+--------------
+-- | Main | --
+--------------
+
+
main :: IO ()
-main = do
-
-
- -- [corpusPath, termListPath, outputPath] <- getArgs
+main = do
- let corpusPath = "/home/qlobbe/data/epique/corpus/cultural_evolution/texts/fullCorpus.csv"
- let termListPath = "/home/qlobbe/data/epique/corpus/cultural_evolution/termList.csv"
- let outputPath = "/home/qlobbe/data/epique/output/cultural_evolution.dot"
+ putStrLn $ show "--| Read the conf |--"
- let query = PhyloQueryBuild "cultural_evolution" "" 5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.00001 10)
- 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
+ [jsonPath] <- getArgs
- 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
- P.writeFile outputPath $ dotToString $ viewToDot view
- -- L.writeFile outputPath $ encode corpus
+ let view = toPhyloView queryView phylo
+ putStrLn $ show "--| Export the phylo as a dot graph |--"
+ P.writeFile (outputPath conf) $ dotToString $ viewToDot view
diff --git a/src/Gargantext/Viz/Phylo.hs b/src/Gargantext/Viz/Phylo.hs
index 4e38ea73..77c6b440 100644
--- a/src/Gargantext/Viz/Phylo.hs
+++ b/src/Gargantext/Viz/Phylo.hs
@@ -41,6 +41,7 @@ import Data.Vector (Vector)
import GHC.Generics (Generic)
--import Gargantext.Database.Schema.Ngrams (NgramsId)
import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Text.Context (TermList)
import Gargantext.Prelude
--------------------
@@ -74,23 +75,18 @@ data Software =
-- Periods : list of all the periods of a Phylo
data Phylo =
Phylo { _phylo_duration :: (Start, End)
- , _phylo_foundations :: Vector Ngrams
- , _phylo_foundationsRoots :: PhyloRoots
+ , _phylo_foundations :: PhyloFoundations
, _phylo_periods :: [PhyloPeriod]
, _phylo_param :: PhyloParam
}
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
-data Tree a = Empty | Node a [Tree a] deriving (Generic, Show, Eq)
+-- | The foundations of a phylomemy created from a given TermList
+data PhyloFoundations =
+ PhyloFoundations { _phylo_foundationsRoots :: Vector Ngrams
+ , _phylo_foundationsTermsList :: TermList
+ } deriving (Generic, Show, Eq)
-- | Date : a simple Integer
@@ -443,7 +439,7 @@ makeLenses ''PhyloParam
makeLenses ''Software
--
makeLenses ''Phylo
-makeLenses ''PhyloRoots
+makeLenses ''PhyloFoundations
makeLenses ''PhyloGroup
makeLenses ''PhyloLevel
makeLenses ''PhyloPeriod
@@ -468,8 +464,7 @@ makeLenses ''PhyloEdge
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
-$(deriveJSON (unPrefix "_phylo_roots" ) ''PhyloRoots )
-$(deriveJSON defaultOptions ''Tree )
+$(deriveJSON (unPrefix "_phylo_foundations" ) ''PhyloFoundations )
$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
diff --git a/src/Gargantext/Viz/Phylo/API.hs b/src/Gargantext/Viz/Phylo/API.hs
index 6553b3b4..aa81140a 100644
--- a/src/Gargantext/Viz/Phylo/API.hs
+++ b/src/Gargantext/Viz/Phylo/API.hs
@@ -103,7 +103,7 @@ postPhylo _n _lId q = do
vrs = Just ("1" :: Text)
sft = Just (Software "Gargantext" "4")
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
instance ToSchema PhyloLevel
instance ToSchema PhyloNode
instance ToSchema PhyloParam
-instance ToSchema PhyloRoots
+instance ToSchema PhyloFoundations
instance ToSchema PhyloPeriod
instance ToSchema PhyloQueryBuild
instance ToSchema PhyloView
@@ -186,10 +186,6 @@ instance FromHttpApiData Sort
parseUrlPiece = readTextData
instance ToParamSchema Sort
-instance (ToSchema a) => ToSchema (Tree a)
- where
- declareNamedSchema = genericDeclareNamedSchemaUnrestricted
- $ swaggerOptions ""
instance ToSchema Proximity
where
diff --git a/src/Gargantext/Viz/Phylo/Aggregates/Document.hs b/src/Gargantext/Viz/Phylo/Aggregates/Document.hs
index 7f3730fa..25fa96fd 100644
--- a/src/Gargantext/Viz/Phylo/Aggregates/Document.hs
+++ b/src/Gargantext/Viz/Phylo/Aggregates/Document.hs
@@ -17,17 +17,14 @@ Portability : POSIX
module Gargantext.Viz.Phylo.Aggregates.Document
where
-import Control.Lens hiding (both, Level)
-
-import Data.List (last,nub,(++))
-import Data.Map (Map,member)
+import Data.List (last)
+import Data.Map (Map)
import Data.Text (Text)
-import Data.Tuple (fst, snd)
+import Data.Tuple (fst)
import Data.Vector (Vector)
import Gargantext.Prelude
-import Gargantext.Text.Terms.Mono (monoTexts)
+import Gargantext.Text.Terms.Mono (monoTexts)
import Gargantext.Viz.Phylo
-import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Vector as Vector
@@ -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
--------------------------------------
--- | 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
-parseDocs :: Vector Ngrams -> PhyloRoots -> [(Date,Text)] -> [Document]
-parseDocs fds roots c = map (\(d,t)
- -> Document d ( reduceByRoots mRoots
- $ filter (\x -> Vector.elem x fds)
- $ 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
+parseDocs :: Vector Ngrams -> [(Date,Text)] -> [Document]
+parseDocs roots c = map (\(d,t)
+ -> Document d ( filter (\x -> Vector.elem x roots)
+ $ monoTexts t)) c
diff --git a/src/Gargantext/Viz/Phylo/Example.hs b/src/Gargantext/Viz/Phylo/Example.hs
index f3d02f5f..9f1e967e 100644
--- a/src/Gargantext/Viz/Phylo/Example.hs
+++ b/src/Gargantext/Viz/Phylo/Example.hs
@@ -36,6 +36,7 @@ import Data.Tuple (fst)
import Data.Tuple.Extra
import Data.Vector (Vector)
import Gargantext.Prelude
+import Gargantext.Text.Context (TermList)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Aggregates.Cluster
import Gargantext.Viz.Phylo.Aggregates.Document
@@ -85,7 +86,7 @@ phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch]
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
queryParser :: [Char] -> PhyloQueryBuild
@@ -223,36 +224,27 @@ phyloDocs = corpusToDocs corpus phyloBase
phyloBase :: Phylo
-phyloBase = initPhyloBase periods foundations roots defaultPhyloParam
-
+phyloBase = initPhyloBase periods (PhyloFoundations foundationsRoots termList) defaultPhyloParam
periods :: [(Date,Date)]
periods = initPeriods 5 3
$ both fst (head' "Example" corpus,last corpus)
-
-roots :: PhyloRoots
-roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) actantsTrees) foundations
-
-
-foundations :: Vector Ngrams
-foundations = initFoundations actants
+foundationsRoots :: Vector Ngrams
+foundationsRoots = initFoundationsRoots actants
--------------------------------------------
-- | STEP 0 | -- Let's start with an example
--------------------------------------------
-actantsTrees :: [Tree Ngrams]
-actantsTrees = []
--- actantsTrees = [Node "Cite antique" [(Node "Rome" []),(Node "Alexandrie" [])]]
-
+termList :: TermList
+termList = []
actants :: [Ngrams]
actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
, "Marc-Antoine", "Cesar" , "Antoine" , "Octave" , "Rome"
, "Alexandrie" , "Auguste" , "Pompee" , "Cassius" , "Brutus"]
-
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")]
diff --git a/src/Gargantext/Viz/Phylo/LevelMaker.hs b/src/Gargantext/Viz/Phylo/LevelMaker.hs
index 65d8cc80..03ebbfeb 100644
--- a/src/Gargantext/Viz/Phylo/LevelMaker.hs
+++ b/src/Gargantext/Viz/Phylo/LevelMaker.hs
@@ -24,7 +24,6 @@ import Data.List ((++), sort, concat, nub, zip, last)
import Data.Map (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
import Data.Text (Text)
import Data.Tuple.Extra
-import Data.Vector (Vector)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Aggregates.Cluster
@@ -34,6 +33,7 @@ import Gargantext.Viz.Phylo.Aggregates.Fis
import Gargantext.Viz.Phylo.BranchMaker
import Gargantext.Viz.Phylo.LinkMaker
import Gargantext.Viz.Phylo.Tools
+import Gargantext.Text.Context (TermList)
import qualified Data.Set as Set
@@ -190,14 +190,14 @@ toPhylo0 d p = addPhyloLevel 0 d p
class PhyloMaker corpus
where
- toPhylo :: PhyloQueryBuild -> corpus -> [Ngrams] -> [Tree Ngrams] -> Phylo
- toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> [Tree Ngrams] -> Phylo
+ toPhylo :: PhyloQueryBuild -> corpus -> [Ngrams] -> TermList -> Phylo
+ toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> TermList -> Phylo
corpusToDocs :: corpus -> Phylo -> Map (Date,Date) [Document]
instance PhyloMaker [(Date, Text)]
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
--------------------------------------
phylo1 :: Phylo
@@ -210,30 +210,27 @@ instance PhyloMaker [(Date, Text)]
phyloDocs = corpusToDocs c phyloBase
--------------------------------------
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
--------------------------------------
- roots :: PhyloRoots
- roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) ts) foundations
+ foundations :: PhyloFoundations
+ foundations = PhyloFoundations (initFoundationsRoots roots) termList
--------------------------------------
periods :: [(Date,Date)]
periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
$ 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]
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
--------------------------------------
phylo1 :: Phylo
@@ -246,21 +243,18 @@ instance PhyloMaker [Document]
phyloDocs = corpusToDocs c phyloBase
--------------------------------------
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
--------------------------------------
- roots :: PhyloRoots
- roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) ts) foundations
+ foundations :: PhyloFoundations
+ foundations = PhyloFoundations (initFoundationsRoots roots) termList
--------------------------------------
periods :: [(Date,Date)]
periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
$ both date (head' "LevelMaker" c,last c)
--------------------------------------
- foundations :: Vector Ngrams
- foundations = initFoundations a
- --------------------------------------
--------------------------------------
corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p) c
\ No newline at end of file
diff --git a/src/Gargantext/Viz/Phylo/Tools.hs b/src/Gargantext/Viz/Phylo/Tools.hs
index c09f2b14..64de952c 100644
--- a/src/Gargantext/Viz/Phylo/Tools.hs
+++ b/src/Gargantext/Viz/Phylo/Tools.hs
@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.Tools
where
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.Map (Map, mapKeys, member, (!))
import Data.Set (Set)
@@ -150,13 +150,13 @@ unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
phyloAnalyzer :: Ngrams -> Ngrams
phyloAnalyzer n = toLower n
--- | To init the foundation of the Phylo as a Vector of Ngrams
-initFoundations :: [Ngrams] -> Vector Ngrams
-initFoundations l = Vector.fromList $ map phyloAnalyzer l
+-- | To init the foundation roots of the Phylo as a Vector of Ngrams
+initFoundationsRoots :: [Ngrams] -> Vector Ngrams
+initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
-- | To init the base of a Phylo from a List of Periods and Foundations
-initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloRoots -> PhyloParam -> Phylo
-initPhyloBase pds fds pks prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds pks (map (\pd -> initPhyloPeriod pd []) pds) prm
+initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> PhyloParam -> Phylo
+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
initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
@@ -164,17 +164,6 @@ initPhyloParam (def defaultPhyloVersion -> v)
(def defaultSoftware -> s)
(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
getLastLevel :: Phylo -> Level
getLastLevel p = (last . sort)
@@ -188,54 +177,20 @@ getLastLevel p = (last . sort)
-- | PhyloRoots | --
--------------------
--- | To apply a fonction to each label of a Ngrams Tree
-alterLabels :: (Ngrams -> Ngrams) -> Tree Ngrams -> Tree Ngrams
-alterLabels f (Node lbl ns) = Node (f lbl) (map (\n -> alterLabels f n) ns)
-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 foundations of a Phylo
+getFoundations :: Phylo -> PhyloFoundations
+getFoundations = _phylo_foundations
--- | To get the RootsLabels of a Phylo
-getRootsLabels :: Phylo -> Vector Ngrams
-getRootsLabels p = (getRoots p) ^. phylo_rootsLabels
+-- | To get the foundations roots of a Phylo
+getFoundationsRoots :: Phylo -> Vector Ngrams
+getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
-- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
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"
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 | --
--------------------
@@ -355,7 +310,7 @@ getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g
-- | To get the roots labels of a list of group ngrams
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
diff --git a/src/Gargantext/Viz/Phylo/View/Taggers.hs b/src/Gargantext/Viz/Phylo/View/Taggers.hs
index 563e38b9..6927eb06 100644
--- a/src/Gargantext/Viz/Phylo/View/Taggers.hs
+++ b/src/Gargantext/Viz/Phylo/View/Taggers.hs
@@ -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
branchPeakFreq :: PhyloView -> Int -> Phylo -> PhyloView
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))
$ getNodesByBranches v
@@ -74,7 +74,7 @@ branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
nodeLabelCooc v thr p = over (pv_nodes
. traverse)
- (\n -> let lbl = ngramsToLabel (getRootsLabels p)
+ (\n -> let lbl = ngramsToLabel (getFoundationsRoots p)
$ mostOccNgrams thr
$ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
in n & pn_label .~ lbl) v
diff --git a/src/Gargantext/Viz/Phylo/View/ViewMaker.hs b/src/Gargantext/Viz/Phylo/View/ViewMaker.hs
index a94aebc0..6feb2bf7 100644
--- a/src/Gargantext/Viz/Phylo/View/ViewMaker.hs
+++ b/src/Gargantext/Viz/Phylo/View/ViewMaker.hs
@@ -49,7 +49,7 @@ initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl
(getPhyloPeriods p)
empty
([] ++ (phyloToBranches lvl p))
- ([] ++ (groupsToNodes True vb (getRootsLabels p) gs))
+ ([] ++ (groupsToNodes True vb (getFoundationsRoots p) gs))
([] ++ (groupsToEdges fl PeriodEdge gs))
where
--------------------------------------
@@ -123,7 +123,7 @@ addChildNodes shouldDo lvl lvlMin vb fl p v =
then v
else addChildNodes shouldDo (lvl - 1) lvlMin vb fl 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 Descendant LevelEdge gs ))
& pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
--
2.21.0