Skip to content

H
haskell-gargantext
Commit 6b566317 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

Add the PhyloParam to the Phylo constructor

parent 0b69015c
Hide whitespace changes
Inline Side-by-side
Showing with 444 additions and 321 deletions
src/Gargantext/Viz/Phylo.hs
View file @ 6b566317
...@@ -42,30 +42,31 @@ import Gargantext.Database.Schema.Ngrams (NgramsId) ...@@ -42,30 +42,31 @@ import Gargantext.Database.Schema.Ngrams (NgramsId)
import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude import Gargantext.Prelude
------------------------------------------------------------------------
data PhyloExport =
PhyloExport { _phyloExport_param :: PhyloParam
, _phyloExport_data :: Phylo
} deriving (Generic, Show)
-- | .phylo parameters --------------------
-- | PhyloParam | --
--------------------
-- | Global parameters of a Phylo
data PhyloParam = data PhyloParam =
PhyloParam { _phyloParam_version :: Text -- Double ? PhyloParam { _phyloParam_version :: Text -- Double ?
, _phyloParam_software :: Software , _phyloParam_software :: Software
, _phyloParam_params :: Hash , _phyloParam_query :: PhyloQuery
, _phyloParam_query :: Maybe PhyloQuery
} deriving (Generic, Show) } deriving (Generic, Show)
type Hash = Text
-- | Software -- | Software parameters
-- TODO move somewhere since it is generic
data Software = data Software =
Software { _software_name :: Text Software { _software_name :: Text
, _software_version :: Text , _software_version :: Text
} deriving (Generic, Show) } deriving (Generic, Show)
------------------------------------------------------------------------
---------------
-- | Phylo | --
---------------
-- | Phylo datatype of a phylomemy -- | Phylo datatype of a phylomemy
-- Duration : time Segment of the whole Phylo -- Duration : time Segment of the whole Phylo
...@@ -75,6 +76,7 @@ data Phylo = ...@@ -75,6 +76,7 @@ data Phylo =
Phylo { _phylo_duration :: (Start, End) Phylo { _phylo_duration :: (Start, End)
, _phylo_foundations :: Vector Ngrams , _phylo_foundations :: Vector Ngrams
, _phylo_periods :: [PhyloPeriod] , _phylo_periods :: [PhyloPeriod]
, _phylo_param :: PhyloParam
} }
deriving (Generic, Show) deriving (Generic, Show)
...@@ -88,6 +90,12 @@ type Date = Int ...@@ -88,6 +90,12 @@ type Date = Int
type Start = Date type Start = Date
type End = Date type End = Date
---------------------
-- | PhyloPeriod | --
---------------------
-- | PhyloStep : steps of phylomemy on temporal axis -- | PhyloStep : steps of phylomemy on temporal axis
-- Period: tuple (start date, end date) of the step of the phylomemy -- Period: tuple (start date, end date) of the step of the phylomemy
-- Levels: levels of granularity -- Levels: levels of granularity
...@@ -98,6 +106,11 @@ data PhyloPeriod = ...@@ -98,6 +106,11 @@ data PhyloPeriod =
deriving (Generic, Show) deriving (Generic, Show)
--------------------
-- | PhyloLevel | --
--------------------
-- | PhyloLevel : levels of phylomemy on level axis -- | PhyloLevel : levels of phylomemy on level axis
-- Levels description: -- Levels description:
-- Level -1: Ngram equals itself (by identity) == _phylo_Ngrams -- Level -1: Ngram equals itself (by identity) == _phylo_Ngrams
...@@ -111,6 +124,11 @@ data PhyloLevel = ...@@ -111,6 +124,11 @@ data PhyloLevel =
deriving (Generic, Show) deriving (Generic, Show)
--------------------
-- | PhyloGroup | --
--------------------
-- | PhyloGroup : group of ngrams at each level and step -- | PhyloGroup : group of ngrams at each level and step
-- Label : maybe has a label as text -- Label : maybe has a label as text
-- Ngrams: set of terms that build the group -- Ngrams: set of terms that build the group
...@@ -155,7 +173,9 @@ type Pointer = (PhyloGroupId, Weight) ...@@ -155,7 +173,9 @@ type Pointer = (PhyloGroupId, Weight)
type Ngrams = Text type Ngrams = Text
--------------------
-- | Aggregates | -- -- | Aggregates | --
--------------------
-- | Document : a piece of Text linked to a Date -- | Document : a piece of Text linked to a Date
...@@ -189,14 +209,17 @@ type GroupGraph = (GroupNodes,GroupEdges) ...@@ -189,14 +209,17 @@ type GroupGraph = (GroupNodes,GroupEdges)
-- | Error | -- -- | Error | --
--------------- ---------------
data PhyloError = LevelDoesNotExist data PhyloError = LevelDoesNotExist
| LevelUnassigned | LevelUnassigned
deriving (Show) deriving (Show)
----------------- -----------------
-- | Cluster | -- -- | Cluster | --
----------------- -----------------
-- | Cluster constructors -- | Cluster constructors
data Cluster = Fis FisParams data Cluster = Fis FisParams
| RelatedComponents RCParams | RelatedComponents RCParams
...@@ -218,10 +241,12 @@ data RCParams = RCParams ...@@ -218,10 +241,12 @@ data RCParams = RCParams
data LouvainParams = LouvainParams data LouvainParams = LouvainParams
{ _louvain_proximity :: Proximity } deriving (Show) { _louvain_proximity :: Proximity } deriving (Show)
------------------- -------------------
-- | Proximity | -- -- | Proximity | --
------------------- -------------------
-- | Proximity constructors -- | Proximity constructors
data Proximity = WeightedLogJaccard WLJParams data Proximity = WeightedLogJaccard WLJParams
| Hamming HammingParams | Hamming HammingParams
...@@ -238,10 +263,12 @@ data WLJParams = WLJParams ...@@ -238,10 +263,12 @@ data WLJParams = WLJParams
data HammingParams = HammingParams data HammingParams = HammingParams
{ _hamming_threshold :: Double } deriving (Show) { _hamming_threshold :: Double } deriving (Show)
---------------- ----------------
-- | Filter | -- -- | Filter | --
---------------- ----------------
-- | Filter constructors -- | Filter constructors
data Filter = LonelyBranch LBParams deriving (Show) data Filter = LonelyBranch LBParams deriving (Show)
...@@ -251,36 +278,44 @@ data LBParams = LBParams ...@@ -251,36 +278,44 @@ data LBParams = LBParams
, _lb_periodsSup :: Int , _lb_periodsSup :: Int
, _lb_minNodes :: Int } deriving (Show) , _lb_minNodes :: Int } deriving (Show)
---------------- ----------------
-- | Metric | -- -- | Metric | --
---------------- ----------------
-- | Metric constructors -- | Metric constructors
data Metric = BranchAge deriving (Show) data Metric = BranchAge deriving (Show)
---------------- ----------------
-- | Tagger | -- -- | Tagger | --
---------------- ----------------
-- | Tagger constructors -- | Tagger constructors
data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics deriving (Show) data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics deriving (Show)
-------------- --------------
-- | Sort | -- -- | Sort | --
-------------- --------------
-- | Sort constructors -- | Sort constructors
data Sort = ByBranchAge deriving (Show) data Sort = ByBranchAge deriving (Show)
data Order = Asc | Desc deriving (Show) data Order = Asc | Desc deriving (Show)
-------------------- --------------------
-- | PhyloQuery | -- -- | PhyloQuery | --
-------------------- --------------------
-- | A Phyloquery describes a phylomemic reconstruction -- | A Phyloquery describes a phylomemic reconstruction
data PhyloQuery = PhyloQuery data PhyloQuery = PhyloQuery
{ _q_phyloName :: Text { _q_phyloTitle :: Text
, _q_phyloDesc :: Text , _q_phyloDesc :: Text
-- Grain and Steps for the PhyloPeriods -- Grain and Steps for the PhyloPeriods
, _q_periodGrain :: Int , _q_periodGrain :: Int
...@@ -301,14 +336,16 @@ data PhyloQuery = PhyloQuery ...@@ -301,14 +336,16 @@ data PhyloQuery = PhyloQuery
data Filiation = Ascendant | Descendant | Complete deriving (Show) data Filiation = Ascendant | Descendant | Complete deriving (Show)
data EdgeType = PeriodEdge | LevelEdge deriving (Show) data EdgeType = PeriodEdge | LevelEdge deriving (Show)
------------------- -------------------
-- | PhyloView | -- -- | PhyloView | --
------------------- -------------------
-- | A PhyloView is the output type of a Phylo -- | A PhyloView is the output type of a Phylo
data PhyloView = PhyloView data PhyloView = PhyloView
{ _phylo_viewParam :: PhyloParam { _phylo_viewParam :: PhyloParam
, _phylo_viewLabel :: Text , _phylo_viewTitle :: Text
, _phylo_viewDescription :: Text , _phylo_viewDescription :: Text
, _phylo_viewFiliation :: Filiation , _phylo_viewFiliation :: Filiation
, _phylo_viewMeta :: Map Text Double , _phylo_viewMeta :: Map Text Double
...@@ -342,10 +379,12 @@ data PhyloNode = PhyloNode ...@@ -342,10 +379,12 @@ data PhyloNode = PhyloNode
, _phylo_nodeChilds :: [PhyloNode] , _phylo_nodeChilds :: [PhyloNode]
} deriving (Show) } deriving (Show)
------------------------ ------------------------
-- | PhyloQueryView | -- -- | PhyloQueryView | --
------------------------ ------------------------
data DisplayMode = Flat | Nested data DisplayMode = Flat | Nested
-- | A PhyloQueryView describes a Phylo as an output view -- | A PhyloQueryView describes a Phylo as an output view
...@@ -373,12 +412,13 @@ data PhyloQueryView = PhyloQueryView ...@@ -373,12 +412,13 @@ data PhyloQueryView = PhyloQueryView
, _qv_verbose :: Bool , _qv_verbose :: Bool
} }
---------------- ----------------
-- | Lenses | -- -- | Lenses | --
---------------- ----------------
makeLenses ''PhyloParam makeLenses ''PhyloParam
makeLenses ''PhyloExport
makeLenses ''Software makeLenses ''Software
-- --
makeLenses ''Phylo makeLenses ''Phylo
...@@ -398,10 +438,12 @@ makeLenses ''PhyloBranch ...@@ -398,10 +438,12 @@ makeLenses ''PhyloBranch
makeLenses ''PhyloNode makeLenses ''PhyloNode
makeLenses ''PhyloEdge makeLenses ''PhyloEdge
------------------------ ------------------------
-- | JSON instances | -- -- | JSON instances | --
------------------------ ------------------------
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo ) $(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod ) $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel ) $(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
...@@ -409,7 +451,6 @@ $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup ) ...@@ -409,7 +451,6 @@ $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
-- --
$(deriveJSON (unPrefix "_software_" ) ''Software ) $(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam ) $(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_phyloExport_" ) ''PhyloExport )
-- --
$(deriveJSON defaultOptions ''Cluster ) $(deriveJSON defaultOptions ''Cluster )
$(deriveJSON defaultOptions ''Proximity ) $(deriveJSON defaultOptions ''Proximity )
...@@ -422,6 +463,7 @@ $(deriveJSON (unPrefix "_wlj_" ) ''WLJParams ) ...@@ -422,6 +463,7 @@ $(deriveJSON (unPrefix "_wlj_" ) ''WLJParams )
-- --
$(deriveJSON (unPrefix "_q_" ) ''PhyloQuery ) $(deriveJSON (unPrefix "_q_" ) ''PhyloQuery )
---------------------------- ----------------------------
-- | TODO XML instances | -- -- | TODO XML instances | --
---------------------------- ----------------------------
......
src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs
View file @ 6b566317
...@@ -49,4 +49,8 @@ fisToCooc m p = map (/docs) ...@@ -49,4 +49,8 @@ fisToCooc m p = map (/docs)
-------------------------------------- --------------------------------------
cooc :: Map (Int, Int) (Double) cooc :: Map (Int, Int) (Double)
cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\x -> getIdxInFoundations x p) fisNgrams) cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\x -> getIdxInFoundations x p) fisNgrams)
-------------------------------------- --------------------------------------
\ No newline at end of file
-- phyloCooc :: Map (Int, Int) Double
-- phyloCooc = fisToCooc phyloFis phylo1_0_1
\ No newline at end of file
src/Gargantext/Viz/Phylo/Example.hs
View file @ 6b566317
...@@ -74,62 +74,62 @@ import qualified Data.Tuple as Tuple ...@@ -74,62 +74,62 @@ import qualified Data.Tuple as Tuple
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
------------------------------------------------------------------------ ------------------------------------------------------
-- | STEP 13 | -- Create a Phylo from a Rest request -- | STEP 12 | -- Create a PhyloView from a user Query
------------------------------------------------------
phylo' :: Phylo
phylo' = toPhylo phyloQuery corpus actants
urlPhyloQuery :: [Char]
urlPhyloQuery = "title=Cesar et Cleôpatre&description=An example of Phylomemy (french without accent)"
++ "grain=5&step=3"
++ "fstCluster=FrequentItemSet&fstClusterParam=supportInf:1&fstClusterParam=filterFis:True&fstClusterParam=emptyFis:False"
++ "timeMatching=WeightedLogJaccard&timeMatchingParam=sensibility:0&timeMatchingThreshold:0.01"
++ "levelMax=2"
++ "cluster=RelatedComponents&clusterProximity=Filiation"
phyloView :: PhyloView
phyloView = toPhyloView (queryParser' queryViewEx) phyloFromQuery
phyloQuery :: PhyloQuery -- | To do : create an other request handler and an other query parser
phyloQuery = PhyloQuery "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)" queryParser' :: [Char] -> PhyloQueryView
5 3 queryParser' q = phyloQueryView
defaultFis
defaultWeightedLogJaccard
2
defaultRelatedComponents
queryViewEx :: [Char]
------------------------------------------------------------------------ queryViewEx = "level=3"
-- | STEP 12 | -- Return a Phylo as a View for upcomming visiualization tasks ++ "&childs=false"
++ "&filter=LonelyBranchFilter"
++ "&metric=BranchAge"
++ "&tagger=BranchLabelFreq"
++ "&tagger=GroupLabelCooc"
-- | To do : add a queryParser from an URL and then update the defaultQuery phyloQueryView :: PhyloQueryView
urlToQuery :: Text -> PhyloQueryView phyloQueryView = PhyloQueryView 3 Descendant False 1 [BranchAge] [defaultLonelyBranch] [BranchLabelFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Flat True
urlToQuery url = defaultQuery
& qv_metrics %~ (++ [BranchAge])
& qv_filters %~ (++ [defaultLonelyBranch])
& qv_taggers %~ (++ [BranchLabelFreq,GroupLabelCooc])
defaultQuery :: PhyloQueryView --------------------------------------------------
defaultQuery = PhyloQueryView 3 Descendant False 1 [] [] [] (Just (ByBranchAge,Asc)) Flat True -- | STEP 11 | -- Create a Phylo from a user Query
--------------------------------------------------
urlQuery :: Text phyloFromQuery :: Phylo
urlQuery = "level=3&childs=false&filter=LonelyBranchFilter(2,2,1):true&metric=BranchAge&tagger=BranchLabelFreq&tagger=GroupLabelCooc" phyloFromQuery = toPhylo (queryParser queryEx) corpus actants
-- | To do : create a request handler and a query parser
queryParser :: [Char] -> PhyloQuery
queryParser q = phyloQuery
toPhyloView :: Text -> Phylo -> PhyloView queryEx :: [Char]
toPhyloView url p = queryToView (urlToQuery url) p queryEx = "title=Cesar et Cleôpatre"
++ "&desc=An example of Phylomemy (french without accent)"
++ "grain=5&steps=3"
++ "cluster=FrequentItemSet"
++ "interTemporalMatching=WeightedLogJaccard"
++ "nthLevel=2"
++ "nthCluster=RelatedComponents"
++ "nthProximity=Filiation"
phyloQuery :: PhyloQuery
phyloQuery = PhyloQuery "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
5 3 defaultFis defaultWeightedLogJaccard 3 defaultRelatedComponents
phyloView :: PhyloView
phyloView = toPhyloView urlQuery phylo6
------------------------------------------------------------------------ ----------------------------------------------------------------------------------------------------------------------------
-- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo -- | STEP 10 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
----------------------------------------------------------------------------------------------------------------------------
phylo6 :: Phylo phylo6 :: Phylo
...@@ -146,8 +146,10 @@ phylo3 = setPhyloBranches 3 ...@@ -146,8 +146,10 @@ phylo3 = setPhyloBranches 3
phyloBranch2 phyloBranch2
------------------------------------------------------------------------ --------------------------------
-- | STEP 10 | -- Cluster the Fis -- | STEP 9 | -- Cluster the Fis
--------------------------------
phyloBranch2 :: Phylo phyloBranch2 :: Phylo
phyloBranch2 = setPhyloBranches 2 phylo2_c phyloBranch2 = setPhyloBranches 2 phylo2_c
...@@ -174,16 +176,18 @@ phyloCluster :: Map (Date,Date) [PhyloCluster] ...@@ -174,16 +176,18 @@ phyloCluster :: Map (Date,Date) [PhyloCluster]
phyloCluster = phyloToClusters 1 defaultWeightedLogJaccard defaultRelatedComponents phyloBranch1 phyloCluster = phyloToClusters 1 defaultWeightedLogJaccard defaultRelatedComponents phyloBranch1
------------------------------------------------------------------------ ----------------------------------
-- | STEP 9 | -- Find the Branches -- | STEP 8 | -- Find the Branches
----------------------------------
phyloBranch1 :: Phylo phyloBranch1 :: Phylo
phyloBranch1 = setPhyloBranches 1 phylo1_c phyloBranch1 = setPhyloBranches 1 phylo1_c
------------------------------------------------------------------------ --------------------------------------------------------------------
-- | STEP 8 | -- Link the PhyloGroups of level 1 through the Periods -- | STEP 7 | -- Link the PhyloGroups of level 1 through the Periods
--------------------------------------------------------------------
phylo1_c :: Phylo phylo1_c :: Phylo
...@@ -194,16 +198,9 @@ phylo1_p :: Phylo ...@@ -194,16 +198,9 @@ phylo1_p :: Phylo
phylo1_p = interTempoMatching Ascendant 1 defaultWeightedLogJaccard phylo1_0_1 phylo1_p = interTempoMatching Ascendant 1 defaultWeightedLogJaccard phylo1_0_1
------------------------------------------------------------------------ -----------------------------------------------
-- | STEP 7 | -- Build the coocurency Matrix of the Phylo -- | STEP 6 | -- Build the level 1 of the Phylo
-----------------------------------------------
phyloCooc :: Map (Int, Int) Double
phyloCooc = fisToCooc phyloFis phylo1_0_1
------------------------------------------------------------------------
-- | STEP 6 | -- Build the level 1 of the Phylo
phylo1_0_1 :: Phylo phylo1_0_1 :: Phylo
...@@ -218,20 +215,18 @@ phylo1 :: Phylo ...@@ -218,20 +215,18 @@ phylo1 :: Phylo
phylo1 = addPhyloLevel (1) phyloFis phylo phylo1 = addPhyloLevel (1) phyloFis phylo
------------------------------------------------------------------------ -------------------------------------------------------------------
-- | STEP 5 | -- Create lists of Frequent Items Set and filter them -- | STEP 5 | -- Create lists of Frequent Items Set and filter them
-------------------------------------------------------------------
phyloFis :: Map (Date, Date) [PhyloFis] phyloFis :: Map (Date, Date) [PhyloFis]
phyloFis = filterFisBySupport False 1 (filterFisByNested (docsToFis phyloDocs)) phyloFis = filterFisBySupport False 1 (filterFisByNested (docsToFis phyloDocs))
------------------------------------------------------------------------ ----------------------------------------
-- | STEP 2 | -- Init a Phylo of level 0 -- | STEP 2 | -- Init a Phylo of level 0
----------------------------------------
-- phylo' :: Phylo
-- phylo' = initPhylo 5 3 corpus actants groupNgramsWithTrees
phylo :: Phylo phylo :: Phylo
...@@ -244,10 +239,11 @@ phyloDocs = corpusToDocs groupNgramsWithTrees corpus phyloBase ...@@ -244,10 +239,11 @@ phyloDocs = corpusToDocs groupNgramsWithTrees corpus phyloBase
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | STEP 1 | -- Init the Base of the Phylo from Periods and Foundations -- | STEP 1 | -- Init the Base of the Phylo from Periods and Foundations
------------------------------------------------------------------------
phyloBase :: Phylo phyloBase :: Phylo
phyloBase = initPhyloBase periods foundations phyloBase = initPhyloBase periods foundations defaultPhyloParam
periods :: [(Date,Date)] periods :: [(Date,Date)]
...@@ -259,8 +255,9 @@ foundations :: Vector Ngrams ...@@ -259,8 +255,9 @@ foundations :: Vector Ngrams
foundations = initFoundations actants foundations = initFoundations actants
------------------------------------------------------------------------ --------------------------------------------
-- | STEP 0 | -- Let's start with an example -- | STEP 0 | -- Let's start with an example
--------------------------------------------
actants :: [Ngrams] actants :: [Ngrams]
...@@ -270,4 +267,6 @@ actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV" ...@@ -270,4 +267,6 @@ actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
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")]
\ No newline at end of file
src/Gargantext/Viz/Phylo/LevelMaker.hs
View file @ 6b566317
...@@ -144,16 +144,6 @@ toPhyloLevel lvl m p = alterPhyloPeriods ...@@ -144,16 +144,6 @@ toPhyloLevel lvl m p = alterPhyloPeriods
) period) p ) period) p
-- | To init a Phylo
initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
where
--------------------------------------
base :: Phylo
base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
--------------------------------------
-- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
toNthLevel :: Level -> Proximity -> Cluster -> Phylo -> Phylo toNthLevel :: Level -> Proximity -> Cluster -> Phylo -> Phylo
toNthLevel lvlMax prox clus p toNthLevel lvlMax prox clus p
...@@ -198,8 +188,8 @@ toPhylo0 d p = addPhyloLevel 0 d p ...@@ -198,8 +188,8 @@ toPhylo0 d p = addPhyloLevel 0 d p
-- | To reconstruct the Base of a Phylo -- | To reconstruct the Base of a Phylo
toPhyloBase :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo toPhyloBase :: PhyloQuery -> PhyloParam -> [(Date, Text)] -> [Ngrams] -> Phylo
toPhyloBase q c a = initPhyloBase periods foundations toPhyloBase q p c a = initPhyloBase periods foundations p
where where
-------------------------------------- --------------------------------------
periods :: [(Date,Date)] periods :: [(Date,Date)]
...@@ -226,5 +216,5 @@ toPhylo q c a = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthC ...@@ -226,5 +216,5 @@ toPhylo q c a = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthC
phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase
-------------------------------------- --------------------------------------
phyloBase :: Phylo phyloBase :: Phylo
phyloBase = toPhyloBase q c a phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c a
-------------------------------------- --------------------------------------
\ No newline at end of file
src/Gargantext/Viz/Phylo/Tools.hs
View file @ 6b566317
...@@ -35,49 +35,14 @@ import qualified Data.Set as Set ...@@ -35,49 +35,14 @@ import qualified Data.Set as Set
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
------------------------------------------------------------------------ --------------
-- | Tools | -- -- | Misc | --
--------------
-- | To alter a PhyloGroup matching a given Level -- | Define a default value
alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo def :: a -> Maybe a -> a
alterGroupWithLevel f lvl p = over ( phylo_periods def = fromMaybe
. traverse
. phylo_periodLevels
. traverse
. phylo_levelGroups
. traverse
) (\g -> if getGroupLevel g == lvl
then f g
else g ) p
-- | To alter each list of PhyloGroups following a given function
alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
alterPhyloGroups f p = over ( phylo_periods
. traverse
. phylo_periodLevels
. traverse
. phylo_levelGroups
) f p
-- | To alter each PhyloPeriod of a Phylo following a given function
alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
alterPhyloPeriods f p = over ( phylo_periods
. traverse) f p
-- | To alter a list of PhyloLevels following a given function
alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
alterPhyloLevels f p = over ( phylo_periods
. traverse
. phylo_periodLevels) f p
-- | To append a list of PhyloPeriod to a Phylo
appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
-- | Does a List of Sets contains at least one Set of an other List -- | Does a List of Sets contains at least one Set of an other List
...@@ -103,11 +68,6 @@ doesContainsOrd l l' ...@@ -103,11 +68,6 @@ doesContainsOrd l l'
| otherwise = doesContainsOrd l (tail l') | otherwise = doesContainsOrd l (tail l')
-- | To filter the PhyloGroup of a Phylo according to a function and a value
filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
filterGroups f x l = filter (\g -> (f g) == x) l
-- | To filter nested Sets of a -- | To filter nested Sets of a
filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a] filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
filterNestedSets h l l' filterNestedSets h l l'
...@@ -115,34 +75,75 @@ filterNestedSets h l l' ...@@ -115,34 +75,75 @@ filterNestedSets h l l'
then l' then l'
else h : l' else h : l'
| doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l' | doesAnySetContains h l l' = filterNestedSets (head l) (tail l) l'
| otherwise = filterNestedSets (head l) (tail l) (h : l') | otherwise = filterNestedSets (head l) (tail l) (h : l')
-- | To filter some GroupEdges with a given threshold
filterGroupEdges :: Double -> GroupEdges -> GroupEdges -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
filterGroupEdges thr edges = filter (\((s,t),w) -> w > thr) edges getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
getKeyPair (x,y) m = case findPair (x,y) m of
Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
Just i -> i
where
--------------------------------------
findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
findPair (x,y) m
| member (x,y) m = Just (x,y)
| member (y,x) m = Just (y,x)
| otherwise = Nothing
--------------------------------------
-- | To get the PhyloBranchId of a PhyloBranch -- | To filter Fis with small Support but by keeping non empty Periods
getBranchId :: PhyloBranch -> PhyloBranchId keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
getBranchId b = b ^. phylo_branchId keepFilled f thr l = if (null $ f thr l) && (not $ null l)
then keepFilled f (thr - 1) l
else f thr l
-- | To get a list of PhyloBranchIds given a Level in a Phylo -- | To get all combinations of a list
getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId] listToDirectedCombi :: Eq a => [a] -> [(a,a)]
getBranchIdsWith lvl p = sortOn snd listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
$ mapMaybe getGroupBranchId
$ getGroupsWithLevel lvl p
-- | To get the Meta value of a PhyloBranch -- | To get all combinations of a list and apply a function to the resulting list of pairs
getBranchMeta :: Text -> PhyloBranch -> Double listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
getBranchMeta k b = (b ^. phylo_branchMeta) ! k listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
-- | To get the first clustering method to apply to get the level 1 of a Phylo -- | To get all combinations of a list with no repetition
getFstCluster :: PhyloQuery -> Cluster listToUnDirectedCombi :: [a] -> [(a,a)]
getFstCluster q = q ^. q_cluster listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l, y <- rest ]
-- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
-- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
then (y,x)
else (x,y) ) m1
---------------
-- | Phylo | --
---------------
-- | To init the foundation of the Phylo as a Vector of Ngrams
initFoundations :: [Ngrams] -> Vector Ngrams
initFoundations l = Vector.fromList $ map toLower l
-- | To init the base of a Phylo from a List of Periods and Foundations
initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloParam -> Phylo
initPhyloBase pds fds prm = Phylo ((fst . head) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) prm
-- | To init the param of a Phylo
initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQuery -> PhyloParam
initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQuery -> q) = PhyloParam v s q
-- | To get the foundations of a Phylo -- | To get the foundations of a Phylo
...@@ -157,6 +158,48 @@ getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of ...@@ -157,6 +158,48 @@ getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
Just idx -> idx Just idx -> idx
-- | To get the last computed Level in a Phylo
getLastLevel :: Phylo -> Level
getLastLevel p = (last . sort)
$ map (snd . getPhyloLevelId)
$ view ( phylo_periods
. traverse
. phylo_periodLevels ) p
--------------------
-- | PhyloGroup | --
--------------------
-- | To alter a PhyloGroup matching a given Level
alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
alterGroupWithLevel f lvl p = over ( phylo_periods
. traverse
. phylo_periodLevels
. traverse
. phylo_levelGroups
. traverse
) (\g -> if getGroupLevel g == lvl
then f g
else g ) p
-- | To alter each list of PhyloGroups following a given function
alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
alterPhyloGroups f p = over ( phylo_periods
. traverse
. phylo_periodLevels
. traverse
. phylo_levelGroups
) f p
-- | To filter the PhyloGroup of a Phylo according to a function and a value
filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
filterGroups f x l = filter (\g -> (f g) == x) l
-- | To maybe get the PhyloBranchId of a PhyloGroup -- | To maybe get the PhyloBranchId of a PhyloGroup
getGroupBranchId :: PhyloGroup -> Maybe PhyloBranchId getGroupBranchId :: PhyloGroup -> Maybe PhyloBranchId
getGroupBranchId = _phylo_groupBranchId getGroupBranchId = _phylo_groupBranchId
...@@ -277,32 +320,96 @@ getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p) ...@@ -277,32 +320,96 @@ getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
-- | To get all the PhyloGroup of a Phylo with a given Period -- | To get all the PhyloGroup of a Phylo with a given Period
getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup] getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p) getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
-- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
getKeyPair (x,y) m = case findPair (x,y) m of
Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
Just i -> i
where
--------------------------------------
findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
findPair (x,y) m
| member (x,y) m = Just (x,y)
| member (y,x) m = Just (y,x)
| otherwise = Nothing
--------------------------------------
-- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
initGroup ngrams lbl idx lvl from to p = PhyloGroup
(((from, to), lvl), idx)
lbl
(sort $ map (\x -> getIdxInFoundations x p) ngrams)
(Map.empty)
(Map.empty)
Nothing
[] [] [] []
-- | To get the last computed Level in a Phylo
getLastLevel :: Phylo -> Level ---------------------
getLastLevel p = (last . sort) -- | PhyloPeriod | --
$ map (snd . getPhyloLevelId) ---------------------
$ view ( phylo_periods
. traverse
. phylo_periodLevels ) p
-- | To alter each PhyloPeriod of a Phylo following a given function
alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
alterPhyloPeriods f p = over ( phylo_periods
. traverse) f p
-- | To append a list of PhyloPeriod to a Phylo
appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
-- | To get all the PhyloPeriodIds of a Phylo
getPhyloPeriods :: Phylo -> [PhyloPeriodId]
getPhyloPeriods p = map _phylo_periodId
$ view (phylo_periods) p
-- | To get the id of a given PhyloPeriod
getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
getPhyloPeriodId prd = _phylo_periodId prd
-- | To create a PhyloPeriod
initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
initPhyloPeriod id l = PhyloPeriod id l
--------------------
-- | PhyloLevel | --
--------------------
-- | To alter a list of PhyloLevels following a given function
alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
alterPhyloLevels f p = over ( phylo_periods
. traverse
. phylo_periodLevels) f p
-- | To get the PhylolevelId of a given PhyloLevel
getPhyloLevelId :: PhyloLevel -> PhyloLevelId
getPhyloLevelId = _phylo_levelId
-- | To get all the Phylolevels of a given PhyloPeriod
getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
getPhyloLevels = view (phylo_periodLevels)
-- | To create a PhyloLevel
initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
initPhyloLevel id groups = PhyloLevel id groups
-- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
= PhyloLevel (id, lvl') groups'
where
groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
----------------------------
-- | PhyloNodes & Edges | --
----------------------------
-- | To filter some GroupEdges with a given threshold
filterGroupEdges :: Double -> GroupEdges -> GroupEdges
filterGroupEdges thr edges = filter (\((s,t),w) -> w > thr) edges
-- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup] getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup]
...@@ -361,45 +468,61 @@ getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId) ...@@ -361,45 +468,61 @@ getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId)
$ v ^. phylo_viewNodes $ v ^. phylo_viewNodes
-- | To get the cluster methods to apply to the Nths levels of a Phylo -- | To get the PhyloGroupId of the Source of a PhyloEdge
getNthCluster :: PhyloQuery -> Cluster getSourceId :: PhyloEdge -> PhyloGroupId
getNthCluster q = q ^. q_nthCluster getSourceId e = e ^. phylo_edgeSource
-- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery -- | To get the PhyloGroupId of the Target of a PhyloEdge
getNthLevel :: PhyloQuery -> Level getTargetId :: PhyloEdge -> PhyloGroupId
getNthLevel q = q ^. q_nthLevel getTargetId e = e ^. phylo_edgeTarget
-- | To get the PhylolevelId of a given PhyloLevel ---------------------
getPhyloLevelId :: PhyloLevel -> PhyloLevelId -- | PhyloBranch | --
getPhyloLevelId = _phylo_levelId ---------------------
-- | To get all the Phylolevels of a given PhyloPeriod -- | To get the PhyloBranchId of a PhyloBranch
getPhyloLevels :: PhyloPeriod -> [PhyloLevel] getBranchId :: PhyloBranch -> PhyloBranchId
getPhyloLevels = view (phylo_periodLevels) getBranchId b = b ^. phylo_branchId
-- | To get all the PhyloPeriodIds of a Phylo -- | To get a list of PhyloBranchIds given a Level in a Phylo
getPhyloPeriods :: Phylo -> [PhyloPeriodId] getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
getPhyloPeriods p = map _phylo_periodId getBranchIdsWith lvl p = sortOn snd
$ view (phylo_periods) p $ mapMaybe getGroupBranchId
$ getGroupsWithLevel lvl p
-- | To get the id of a given PhyloPeriod -- | To get the Meta value of a PhyloBranch
getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId getBranchMeta :: Text -> PhyloBranch -> Double
getPhyloPeriodId prd = _phylo_periodId prd getBranchMeta k b = (b ^. phylo_branchMeta) ! k
-- | To get the PhyloGroupId of the Source of a PhyloEdge -- | To get all the PhyloBranchIds of a PhyloView
getSourceId :: PhyloEdge -> PhyloGroupId getViewBranchIds :: PhyloView -> [PhyloBranchId]
getSourceId e = e ^. phylo_edgeSource getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches
-- | To get the PhyloGroupId of the Target of a PhyloEdge --------------------------------
getTargetId :: PhyloEdge -> PhyloGroupId -- | PhyloQuery & QueryView | --
getTargetId e = e ^. phylo_edgeTarget --------------------------------
-- | To get the first clustering method to apply to get the level 1 of a Phylo
getFstCluster :: PhyloQuery -> Cluster
getFstCluster q = q ^. q_cluster
-- | To get the cluster methods to apply to the Nths levels of a Phylo
getNthCluster :: PhyloQuery -> Cluster
getNthCluster q = q ^. q_nthCluster
-- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
getNthLevel :: PhyloQuery -> Level
getNthLevel q = q ^. q_nthLevel
-- | To get the Grain of the PhyloPeriods from a PhyloQuery -- | To get the Grain of the PhyloPeriods from a PhyloQuery
...@@ -417,150 +540,111 @@ getPeriodSteps :: PhyloQuery -> Int ...@@ -417,150 +540,111 @@ getPeriodSteps :: PhyloQuery -> Int
getPeriodSteps q = q ^. q_periodSteps getPeriodSteps q = q ^. q_periodSteps
-- | To get all the PhyloBranchIds of a PhyloView --------------------------------------------------
getViewBranchIds :: PhyloView -> [PhyloBranchId] -- | PhyloQuery & PhyloQueryView Constructors | --
getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches --------------------------------------------------
-- | To init the foundation of the Phylo as a Vector of Ngrams
initFoundations :: [Ngrams] -> Vector Ngrams
initFoundations l = Vector.fromList $ map toLower l
-- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
initGroup ngrams lbl idx lvl from to p = PhyloGroup
(((from, to), lvl), idx)
lbl
(sort $ map (\x -> getIdxInFoundations x p) ngrams)
(Map.empty)
(Map.empty)
Nothing
[] [] [] []
-- | To init the Base of a Phylo from a List of Periods and Foundations -- | To get the Proximity associated to a given Clustering method
initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> Phylo getProximity :: Cluster -> Proximity
initPhyloBase pds fds = Phylo ((fst . head) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) getProximity cluster = case cluster of
Louvain (LouvainParams proxi) -> proxi
RelatedComponents (RCParams proxi) -> proxi
_ -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
-- | To create a PhyloLevel -- | To initialize all the Cluster / Proximity with their default parameters
initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel initFis :: Maybe Bool -> Maybe Bool -> Maybe Support -> FisParams
initPhyloLevel id groups = PhyloLevel id groups initFis (def True -> flt) (def True -> kmf) (def 1 -> min) = FisParams flt kmf min
initHamming :: Maybe Double -> HammingParams
initHamming (def 0.01 -> sens) = HammingParams sens
-- | To create a PhyloPeriod initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod initLonelyBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
initPhyloPeriod id l = PhyloPeriod id l
initLouvain :: Maybe Proximity -> LouvainParams
initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
-- | To filter Fis with small Support but by keeping non empty Periods initRelatedComponents :: Maybe Proximity -> RCParams
keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a] initRelatedComponents (def Filiation -> proxi) = RCParams proxi
keepFilled f thr l = if (null $ f thr l) && (not $ null l)
then keepFilled f (thr - 1) l
else f thr l
initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
-- | To get all combinations of a list
listToDirectedCombi :: Eq a => [a] -> [(a,a)]
listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
-- | To initialize a PhyloQuery from given and default parameters
initPhyloQuery :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQuery
initPhyloQuery name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster)
(def defaultWeightedLogJaccard -> matching) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
PhyloQuery name desc grain steps cluster matching nthLevel nthCluster
-- | To get all combinations of a list and apply a function to the resulting list of pairs
listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
-- | To initialize a PhyloQueryView default parameters
initPhyloQueryView :: Maybe Level -> Maybe Filiation -> Maybe Bool -> Maybe Level -> Maybe [Metric] -> Maybe [Filter] -> Maybe [Tagger] -> Maybe (Sort, Order) -> Maybe DisplayMode -> Maybe Bool -> PhyloQueryView
initPhyloQueryView (def 2 -> lvl) (def Descendant -> f) (def False -> c) (def 1 -> d) (def [] -> ms) (def [] -> fs) (def [] -> ts) s (def Flat -> dm) (def True -> v) =
PhyloQueryView lvl f c d ms fs ts s dm v
-- | To get all combinations of a list with no repetition
listToUnDirectedCombi :: [a] -> [(a,a)]
listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l, y <- rest ]
-- | To define some obvious boolean getters
shouldFilterFis :: FisParams -> Bool
shouldFilterFis = _fis_filtered
-- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs shouldKeepMinorFis :: FisParams -> Bool
listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)] shouldKeepMinorFis = _fis_keepMinorFis
listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
----------------------------
-- | Default ressources | --
----------------------------
-- | To set the LevelId of a PhyloLevel and of all its PhyloGroups -- Clusters
setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
= PhyloLevel (id, lvl') groups'
where
groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups
defaultFis :: Cluster
defaultFis = Fis (initFis Nothing Nothing Nothing)
-- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x) defaultLouvain :: Cluster
unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b defaultLouvain = Louvain (initLouvain Nothing)
unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
then (y,x)
else (x,y) ) m1
defaultRelatedComponents :: Cluster
defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
-- Filters
-------------------------------------------------- defaultLonelyBranch :: Filter
-- | PhyloQuery & PhyloQueryView Constructors | -- defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
-- Params
-- | Define a default value for each Proximity / Cluster defaultPhyloParam :: PhyloParam
dft :: a -> Maybe a -> a defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
dft = fromMaybe
defaultFis :: Cluster -- Proximities
defaultFis = Fis (initFis Nothing Nothing Nothing)
defaultHamming :: Proximity defaultHamming :: Proximity
defaultHamming = Hamming (initHamming Nothing) defaultHamming = Hamming (initHamming Nothing)
defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
defaultLouvain :: Cluster
defaultLouvain = Louvain (initLouvain Nothing)
defaultRelatedComponents :: Cluster
defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
defaultWeightedLogJaccard :: Proximity defaultWeightedLogJaccard :: Proximity
defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing) defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
-- Queries
-- | To get the Proximity associated to a given Clustering method defaultQuery :: PhyloQuery
getProximity :: Cluster -> Proximity defaultQuery = initPhyloQuery "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
getProximity cluster = case cluster of Nothing Nothing Nothing Nothing Nothing Nothing
Louvain (LouvainParams proxi) -> proxi
RelatedComponents (RCParams proxi) -> proxi
_ -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
defaultQueryView :: PhyloQueryView
defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-- | To initialize all the Cluster / Proximity with their default parameters -- Software
initFis :: Maybe Bool -> Maybe Bool -> Maybe Support -> FisParams
initFis (dft True -> flt) (dft True -> kmf) (dft 1 -> min) = FisParams flt kmf min
initHamming :: Maybe Double -> HammingParams defaultSoftware :: Software
initHamming (dft 0.01 -> sens) = HammingParams sens defaultSoftware = Software "Gargantext" "v4"
initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams -- Version
initLonelyBranch (dft 2 -> periodsInf) (dft 2 -> periodsSup) (dft 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
initLouvain :: Maybe Proximity -> LouvainParams defaultPhyloVersion :: Text
initLouvain (dft defaultWeightedLogJaccard -> proxi) = LouvainParams proxi defaultPhyloVersion = "v1"
initRelatedComponents :: Maybe Proximity -> RCParams
initRelatedComponents (dft Filiation -> proxi) = RCParams proxi
initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
initWeightedLogJaccard (dft 0 -> thr) (dft 0.01 -> sens) = WLJParams thr sens
-- | To initialize a PhyloQuery from given and default parameters
initPhyloQuery :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQuery
initPhyloQuery name desc (dft 5 -> grain) (dft 3 -> steps) (dft defaultFis -> cluster)
(dft defaultWeightedLogJaccard -> matching) (dft 2 -> nthLevel) (dft defaultRelatedComponents -> nthCluster) =
PhyloQuery name desc grain steps cluster matching nthLevel nthCluster
-- | To define some obvious boolean getters
shouldFilterFis :: FisParams -> Bool
shouldFilterFis = _fis_filtered
shouldKeepMinorFis :: FisParams -> Bool
shouldKeepMinorFis = _fis_keepMinorFis
\ No newline at end of file
src/Gargantext/Viz/Phylo/View/ViewMaker.hs
View file @ 6b566317
...@@ -125,21 +125,25 @@ addChildNodes shouldDo lvl lvlMin vb fl p v = ...@@ -125,21 +125,25 @@ addChildNodes shouldDo lvl lvlMin vb fl p v =
-- | To transform a PhyloQuery into a PhyloView -- | To transform a PhyloQuery into a PhyloView
queryToView :: PhyloQueryView -> Phylo -> PhyloView toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
queryToView q p = processDisplay (q ^. qv_display) toPhyloView q p = processDisplay (q ^. qv_display)
$ processSort (q ^. qv_sort) p $ processSort (q ^. qv_sort) p
$ processTaggers (q ^. qv_taggers) p $ processTaggers (q ^. qv_taggers) p
$ processFilters (q ^. qv_filters) p $ processFilters (q ^. qv_filters) p
$ processMetrics (q ^. qv_metrics) p $ processMetrics (q ^. qv_metrics) p
$ addChildNodes (q ^. qv_childs) (q ^. qv_lvl) (q ^. qv_childsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p $ addChildNodes (q ^. qv_childs) (q ^. qv_lvl) (q ^. qv_childsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
$ initPhyloView (q ^. qv_lvl) "Phylo2000" "This is a Phylo" (q ^. qv_filiation) (q ^. qv_verbose) p $ initPhyloView (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
-- | dirty params
phyloParams :: PhyloParam
phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") "" Nothing
-- | To get the PhyloParam of a Phylo
-- | To do : effectively get the PhyloParams of a Phylo
getPhyloParams :: Phylo -> PhyloParam getPhyloParams :: Phylo -> PhyloParam
getPhyloParams p = phyloParams getPhyloParams = _phylo_param
\ No newline at end of file
-- | To get the title of a Phylo
getPhyloTitle :: Phylo -> Text
getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
-- | To get the desc of a Phylo
getPhyloDescription :: Phylo -> Text
getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
\ No newline at end of file
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