Skip to content

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

add a toPhylo function and the foundation of the Rest routes

parent e23cae57
Hide whitespace changes
Inline Side-by-side
Showing with 255 additions and 74 deletions
src/Gargantext/Viz/Phylo.hs
View file @ c35221a6
......@@ -43,6 +43,21 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
------------------------------------------------------------------------
data PhyloQuery = PhyloQuery
{ _phyloQuery_phyloName :: Text
, _phyloQuery_phyloDescription :: Text
, _phyloQuery_timeGrain :: Int
, _phyloQuery_timeSteps :: Int
, _phyloQuery_fstCluster :: Clustering
, _phyloQuery_timeMatching :: Proximity
, _phyloQuery_nthLevel :: Level
, _phyloQuery_nthCluster :: Clustering
} deriving (Show)
data PhyloExport =
PhyloExport { _phyloExport_param :: PhyloParam
, _phyloExport_data :: Phylo
......@@ -53,6 +68,7 @@ data PhyloParam =
PhyloParam { _phyloParam_version :: Text -- Double ?
, _phyloParam_software :: Software
, _phyloParam_params :: Hash
, _phyloParam_query :: Maybe PhyloQuery
} deriving (Generic, Show)
type Hash = Text
......@@ -185,12 +201,21 @@ data PhyloError = LevelDoesNotExist
deriving (Show)
-- | A List of Proximity mesures or strategies
data Proximity = WeightedLogJaccard | Hamming | FromPairs
-- | A List of Clustering methods
data Clustering = Louvain | RelatedComponents
data PairTo = Childs | Parents
-- | A List of Proximity methods names
data ProximityName = WeightedLogJaccard | Hamming | Filiation deriving (Show)
-- | A List of Clustering methods names
data ClusteringName = Louvain | RelatedComponents | FrequentItemSet deriving (Show)
-- | A constructor for Proximities
data Proximity = Proximity
{ _proximity_name :: ProximityName
, _proximity_params :: Map Text Double
, _proximity_threshold :: Maybe Double } deriving (Show)
-- | A constructor for Clustering
data Clustering = Clustering
{ _clustering_name :: ClusteringName
, _clustering_params :: Map Text Double
, _clustering_paramsBool :: Map Text Bool
, _clustering_proximity :: Maybe Proximity } deriving (Show)
------------------------------------------------------------------------
-- | To export a Phylo | --
......@@ -261,8 +286,8 @@ data QueryFilter = QueryFilter
}
-- | A PhyloQuery is the structured representation of a user query to be applied to a Phylo
data PhyloQuery = PhyloQuery
-- | A PhyloQueryView is the structured representation of a user query to be applied to a Phylo
data PhyloQueryView = PhyloQueryView
{ _query_lvl :: Level
-- Does the PhyloGraph contain ascendant, descendant or a complete Filiation ?
......@@ -300,13 +325,16 @@ makeLenses ''PhyloGroup
makeLenses ''PhyloLevel
makeLenses ''PhyloPeriod
makeLenses ''PhyloView
makeLenses ''PhyloQuery
makeLenses ''PhyloQueryView
makeLenses ''PhyloBranch
makeLenses ''PhyloNode
makeLenses ''PhyloEdge
makeLenses ''Proximity
makeLenses ''Clustering
makeLenses ''QueryFilter
makeLenses ''PhyloQuery
-- | JSON instances
-- | JSON instances
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
......@@ -314,6 +342,11 @@ $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
--
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_clustering_" ) ''Clustering )
$(deriveJSON (unPrefix "_proximity_" ) ''Proximity )
$(deriveJSON (unPrefix "") ''ProximityName )
$(deriveJSON (unPrefix "") ''ClusteringName )
$(deriveJSON (unPrefix "_phyloQuery_" ) ''PhyloQuery )
$(deriveJSON (unPrefix "_phyloExport_" ) ''PhyloExport )
-- | TODO XML instances
......
src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs
View file @ c35221a6
......@@ -17,6 +17,8 @@ Portability : POSIX
module Gargantext.Viz.Phylo.Aggregates.Cluster
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (last,head,union,concat,null,nub,(++),init,tail,(!!))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith)
import Data.Set (Set)
......@@ -35,18 +37,18 @@ import qualified Data.Set as Set
-- | To apply a Clustering method to a PhyloGraph
graphToClusters :: (Clustering,[Double]) -> GroupGraph -> [Cluster]
graphToClusters (clust,param) (nodes,edges) = case clust of
graphToClusters :: Clustering -> GroupGraph -> [Cluster]
graphToClusters clust (nodes,edges) = case clust ^. clustering_name of
Louvain -> undefined -- louvain (nodes,edges)
RelatedComponents -> relatedComp 0 (head nodes) (tail nodes,edges) [] []
-- | To transform a Phylo into Clusters of PhyloGroups at a given level
phyloToClusters :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> Phylo -> Map (Date,Date) [Cluster]
phyloToClusters lvl (prox,param) (clus,param') p = Map.fromList
$ zip (getPhyloPeriods p)
(map (\prd -> let graph = groupsToGraph (prox,param) (getGroupsWithFilters lvl prd p) p
in if null (fst graph)
then []
else graphToClusters (clus,param') graph)
(getPhyloPeriods p))
phyloToClusters :: Level -> Proximity -> Clustering -> Phylo -> Map (Date,Date) [Cluster]
phyloToClusters lvl prox clus p = Map.fromList
$ zip (getPhyloPeriods p)
(map (\prd -> let graph = groupsToGraph prox (getGroupsWithFilters lvl prd p) p
in if null (fst graph)
then []
else graphToClusters clus graph)
(getPhyloPeriods p))
src/Gargantext/Viz/Phylo/BranchMaker.hs
View file @ c35221a6
......@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.BranchMaker
import Control.Lens hiding (both, Level)
import Data.List (last,head,union,concat,null,nub,(++),init,tail,(!!))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith)
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,empty,(!))
import Data.Set (Set)
import Data.Tuple (fst, snd)
......@@ -44,19 +44,19 @@ graphToBranches lvl (nodes,edges) p = concat
-- | To transform a list of PhyloGroups into a PhyloGraph by using a given Proximity mesure
groupsToGraph :: (Proximity,[Double]) -> [PhyloGroup] -> Phylo -> GroupGraph
groupsToGraph (prox,param) groups p = (groups,edges)
groupsToGraph :: Proximity -> [PhyloGroup] -> Phylo -> GroupGraph
groupsToGraph prox groups p = (groups,edges)
where
edges :: GroupEdges
edges = case prox of
FromPairs -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
edges = case prox ^. proximity_name of
Filiation -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
++
(map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) groups
WeightedLogJaccard -> filter (\edge -> snd edge >= (param !! 0))
WeightedLogJaccard -> filter (\edge -> snd edge >= (fromJust (prox ^. proximity_threshold)))
$ map (\(x,y) -> ((x,y), weightedLogJaccard
(param !! 1) (getGroupCooc x)
(getSensibility prox) (getGroupCooc x)
(unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
Hamming -> filter (\edge -> snd edge <= (param !! 0))
Hamming -> filter (\edge -> snd edge <= (fromJust (prox ^. proximity_threshold)))
$ map (\(x,y) -> ((x,y), hamming (getGroupCooc x)
(unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
_ -> undefined
......@@ -72,5 +72,5 @@ setPhyloBranches lvl p = alterGroupWithLevel (\g -> let bIdx = (fst . head) $ fi
bs = graphToBranches lvl graph p
--------------------------------------
graph :: GroupGraph
graph = groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p
graph = groupsToGraph (Proximity Filiation empty Nothing) (getGroupsWithLevel lvl p) p
--------------------------------------
\ No newline at end of file
src/Gargantext/Viz/Phylo/Example.hs
View file @ c35221a6
......@@ -56,6 +56,7 @@ import Gargantext.Viz.Phylo.LevelMaker
import Gargantext.Viz.Phylo.LinkMaker
import Gargantext.Viz.Phylo.Metrics.Proximity
import Gargantext.Viz.Phylo.Metrics.Clustering
import Gargantext.Viz.Phylo.PhyloMaker
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.View.Display
import Gargantext.Viz.Phylo.View.Filters
......@@ -74,20 +75,43 @@ import qualified Data.Tuple as Tuple
import qualified Data.Vector as Vector
------------------------------------------------------------------------
-- | STEP 13 | -- Create a Phylo from a Rest request
phylo' :: Phylo
phylo' = toPhylo phyloQuery corpus actants
phyloQuery :: PhyloQuery
phyloQuery = PhyloQuery "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
5 3
(Clustering FrequentItemSet
(singleton "supportInf" 1)
(Map.fromList [("filterFis",True),("emptyFis",False)])
Nothing)
(Proximity WeightedLogJaccard
(singleton "sensibility" 0) (Just 0.01))
2
(Clustering RelatedComponents
empty empty
(Just (Proximity Filiation empty Nothing)))
------------------------------------------------------------------------
-- | STEP 12 | -- Return a Phylo as a View for upcomming visiualization tasks
-- | To do : add a queryParser from an URL and then update the defaultQuery
urlToQuery :: Text -> PhyloQuery
urlToQuery :: Text -> PhyloQueryView
urlToQuery url = defaultQuery
& query_metrics %~ (++ [BranchAge])
& query_filters %~ (++ [QueryFilter LonelyBranch [2,2,1]])
& query_taggers %~ (++ [BranchLabelFreq,GroupLabelCooc])
defaultQuery :: PhyloQuery
defaultQuery = PhyloQuery 3 Descendant False 1 [] [] [] (Just (ByBranchAge,Asc)) Flat True
defaultQuery :: PhyloQueryView
defaultQuery = PhyloQueryView 3 Descendant False 1 [] [] [] (Just (ByBranchAge,Asc)) Flat True
urlQuery :: Text
......@@ -107,16 +131,16 @@ phyloView = toPhyloView urlQuery phylo6
phylo6 :: Phylo
phylo6 = toNthLevel 6 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) (WeightedLogJaccard,[0.01,0]) phylo3
phylo6 = toNthLevel 6 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) (Clustering RelatedComponents empty empty (Just (Proximity Filiation empty Nothing))) phylo3
phylo3 :: Phylo
phylo3 = setPhyloBranches 3
$ interTempoMatching Childs 3 (WeightedLogJaccard,[0.01,0])
$ interTempoMatching Parents 3 (WeightedLogJaccard,[0.01,0])
$ interTempoMatching Descendant 3 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01))
$ interTempoMatching Ascendant 3 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01))
$ setLevelLinks (2,3)
$ addPhyloLevel 3
(phyloToClusters 2 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) phyloBranch2)
(phyloToClusters 2 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) (Clustering RelatedComponents empty empty (Just (Proximity Filiation empty Nothing))) phyloBranch2)
phyloBranch2
......@@ -128,11 +152,11 @@ phyloBranch2 = setPhyloBranches 2 phylo2_c
phylo2_c :: Phylo
phylo2_c = interTempoMatching Childs 2 (WeightedLogJaccard,[0.01,0]) phylo2_p
phylo2_c = interTempoMatching Descendant 2 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) phylo2_p
phylo2_p :: Phylo
phylo2_p = interTempoMatching Parents 2 (WeightedLogJaccard,[0.01,0]) phylo2_1_2
phylo2_p = interTempoMatching Ascendant 2 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) phylo2_1_2
phylo2_1_2 :: Phylo
......@@ -145,7 +169,7 @@ phylo2 = addPhyloLevel 2 phyloCluster phyloBranch1
phyloCluster :: Map (Date,Date) [Cluster]
phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) phyloBranch1
phyloCluster = phyloToClusters 1 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) (Clustering RelatedComponents empty empty (Just (Proximity Filiation empty Nothing))) phyloBranch1
------------------------------------------------------------------------
......@@ -161,11 +185,11 @@ phyloBranch1 = setPhyloBranches 1 phylo1_c
phylo1_c :: Phylo
phylo1_c = interTempoMatching Childs 1 (WeightedLogJaccard,[0.01,0]) phylo1_p
phylo1_c = interTempoMatching Descendant 1 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) phylo1_p
phylo1_p :: Phylo
phylo1_p = interTempoMatching Parents 1 (WeightedLogJaccard,[0.01,0]) phylo1_0_1
phylo1_p = interTempoMatching Ascendant 1 (Proximity WeightedLogJaccard (singleton "sensibility" 0) (Just 0.01)) phylo1_0_1
------------------------------------------------------------------------
......@@ -244,4 +268,10 @@ actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV"
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")]
\ No newline at end of file
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")]
------------------------------------------------------------------------
-- | From REST routes | -- Let's build a Phylomemy from scratch
src/Gargantext/Viz/Phylo/LevelMaker.hs
View file @ c35221a6
......@@ -23,11 +23,13 @@ import Data.Map (Map, (!), empty, restrictKeys, filterWithKe
import Data.Set (Set)
import Data.Text (Text, words)
import Data.Tuple.Extra
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo.Aggregates.Cluster
import Gargantext.Viz.Phylo.Aggregates.Cooc
import Gargantext.Viz.Phylo.Aggregates.Document
import Gargantext.Viz.Phylo.Aggregates.Fis
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.LinkMaker
......@@ -37,6 +39,7 @@ import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector
-- | A typeClass for polymorphic PhyloLevel functions
......@@ -141,6 +144,7 @@ toPhyloLevel lvl m p = alterPhyloPeriods
) 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
......@@ -151,18 +155,74 @@ initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
-- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo
toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p
toNthLevel :: Level -> Proximity -> Clustering -> Phylo -> Phylo
toNthLevel lvlMax prox clus p
| lvl >= lvlMax = p
| otherwise = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
| otherwise = toNthLevel lvlMax prox clus
$ setPhyloBranches (lvl + 1)
$ interTempoMatching Childs (lvl + 1) (prox',param3)
$ interTempoMatching Parents (lvl + 1) (prox',param3)
$ interTempoMatching Descendant (lvl + 1) prox
$ interTempoMatching Ascendant (lvl + 1) prox
$ setLevelLinks (lvl, lvl + 1)
$ addPhyloLevel (lvl + 1)
(phyloToClusters lvl (prox,param1) (clus,param2) p) p
(phyloToClusters lvl (fromJust $ clus ^. clustering_proximity) clus p) p
where
--------------------------------------
lvl :: Level
lvl = getLastLevel p
--------------------------------------
-- | To reconstruct the Level 1 of a Phylo based on a Clustering Methods
toPhylo1 :: Clustering -> Proximity -> Map (Date, Date) [Document] -> Phylo -> Phylo
toPhylo1 clst proxy d p = case getClusterName clst of
FrequentItemSet -> setPhyloBranches 1
$ interTempoMatching Descendant 1 proxy
$ interTempoMatching Ascendant 1 proxy
$ setLevelLinks (0,1)
$ setLevelLinks (1,0)
$ addPhyloLevel 1 phyloFis p
where
--------------------------------------
phyloFis :: Map (Date, Date) [Fis]
phyloFis = filterFisBySupport (getClusterParamBool clst "emptyFis") (round $ getClusterParam clst "supportInf") (filterFisByNested (docsToFis d))
--------------------------------------
_ -> panic "[ERR][Viz.Phylo.PhyloMaker.toPhylo1] fst clustering not recognized"
-- | To reconstruct the Level 0 of a Phylo
toPhylo0 :: Map (Date, Date) [Document] -> Phylo -> Phylo
toPhylo0 d p = addPhyloLevel 0 d p
-- | To reconstruct the Base of a Phylo
toPhyloBase :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
toPhyloBase q c a = initPhyloBase periods foundations
where
--------------------------------------
periods :: [(Date,Date)]
periods = initPeriods (getTimeGrain q) (getTimeSteps q)
$ both fst (head c,last c)
--------------------------------------
foundations :: Vector Ngrams
foundations = initFoundations a
--------------------------------------
-- | To reconstruct a Phylomemy from a PhyloQuery, a Corpus and a list of actants
toPhylo :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
toPhylo q c a = toNthLevel (getNthLevel q) (getTimeMatching q) (getNthCluster q) phylo1
where
--------------------------------------
phylo1 :: Phylo
phylo1 = toPhylo1 (getFstCluster q) (getTimeMatching q) phyloDocs phylo0
--------------------------------------
phylo0 :: Phylo
phylo0 = toPhylo0 phyloDocs phyloBase
--------------------------------------
phyloDocs :: Map (Date, Date) [Document]
phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase
--------------------------------------
phyloBase :: Phylo
phyloBase = toPhyloBase q c a
--------------------------------------
\ No newline at end of file
src/Gargantext/Viz/Phylo/LinkMaker.hs
View file @ c35221a6
......@@ -19,7 +19,7 @@ module Gargantext.Viz.Phylo.LinkMaker
import Control.Lens hiding (both, Level)
import Data.List ((++), sort, concat, nub, words, zip, sortOn, head, null, tail, splitAt, (!!), elem)
import Data.Map (Map)
import Data.Map (Map,(!))
import Data.Set (Set)
import Data.Tuple.Extra
......@@ -85,19 +85,19 @@ setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
-- | To apply the corresponding proximity function based on a given Proximity
getProximity :: (Proximity,[Double]) -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
getProximity (prox,param) g1 g2 = case prox of
WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (param !! 1) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
getProximity :: Proximity -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
getProximity prox g1 g2 = case (prox ^. proximity_name) of
WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (getSensibility prox) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
Hamming -> ((getGroupId g2),hamming (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
_ -> panic ("[ERR][Viz.Phylo.Example.getProximity] Proximity function not defined")
-- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
getNextPeriods :: PairTo -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
getNextPeriods :: Filiation -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
getNextPeriods to id l = case to of
Childs -> unNested id ((tail . snd) next)
Parents -> unNested id ((reverse . fst) next)
_ -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PairTo type not defined")
Descendant -> unNested id ((tail . snd) next)
Ascendant -> unNested id ((reverse . fst) next)
_ -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] Filiation type not defined")
where
--------------------------------------
next :: ([PhyloPeriodId], [PhyloPeriodId])
......@@ -122,11 +122,11 @@ getNextPeriods to id l = case to of
-- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )
findBestCandidates :: PairTo -> Int -> Int -> (Proximity,[Double]) -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
findBestCandidates to depth max (prox,param) group p
findBestCandidates :: Filiation -> Int -> Int -> Proximity -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
findBestCandidates to depth max prox group p
| depth > max || null next = []
| (not . null) best = take 2 best
| otherwise = findBestCandidates to (depth + 1) max (prox,param) group p
| otherwise = findBestCandidates to (depth + 1) max prox group p
where
--------------------------------------
next :: [PhyloPeriodId]
......@@ -136,23 +136,23 @@ findBestCandidates to depth max (prox,param) group p
candidates = getGroupsWithFilters (getGroupLevel group) (head next) p
--------------------------------------
scores :: [(PhyloGroupId, Double)]
scores = map (\group' -> getProximity (prox,param) group group') candidates
scores = map (\group' -> getProximity prox group group') candidates
--------------------------------------
best :: [(PhyloGroupId, Double)]
best = reverse
$ sortOn snd
$ filter (\(id,score) -> case prox of
WeightedLogJaccard -> score >= (param !! 0)
Hamming -> score <= (param !! 0)) scores
$ filter (\(id,score) -> case (prox ^. proximity_name) of
WeightedLogJaccard -> score >= fromJust (prox ^. proximity_threshold)
Hamming -> score <= fromJust (prox ^. proximity_threshold)) scores
--------------------------------------
-- | To add a new list of Pointers into an existing Childs/Parents list of Pointers
makePair :: PairTo -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
makePair :: Filiation -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
makePair to group ids = case to of
Childs -> over (phylo_groupPeriodChilds) addPointers group
Parents -> over (phylo_groupPeriodParents) addPointers group
_ -> panic ("[ERR][Viz.Phylo.Example.makePair] PairTo type not defined")
Descendant -> over (phylo_groupPeriodChilds) addPointers group
Ascendant -> over (phylo_groupPeriodParents) addPointers group
_ -> panic ("[ERR][Viz.Phylo.Example.makePair] Filiation type not defined")
where
--------------------------------------
addPointers :: [Pointer] -> [Pointer]
......@@ -161,8 +161,8 @@ makePair to group ids = case to of
-- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
interTempoMatching :: PairTo -> Level -> (Proximity,[Double]) -> Phylo -> Phylo
interTempoMatching to lvl (prox,param) p = alterPhyloGroups
interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
interTempoMatching to lvl prox p = alterPhyloGroups
(\groups ->
map (\group ->
if (getGroupLevel group) == lvl
......@@ -170,7 +170,7 @@ interTempoMatching to lvl (prox,param) p = alterPhyloGroups
let
--------------------------------------
candidates :: [(PhyloGroupId, Double)]
candidates = findBestCandidates to 1 5 (prox,param) group p
candidates = findBestCandidates to 1 5 prox group p
--------------------------------------
in
makePair to group candidates
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ c35221a6
......@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.Tools
import Control.Lens hiding (both, Level)
import Data.List (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub, concat, union, sortOn)
import Data.Maybe (mapMaybe)
import Data.Map (Map, mapKeys, member, elems, adjust)
import Data.Map (Map, mapKeys, member, elems, adjust, (!))
import Data.Set (Set)
import Data.Text (Text, toLower)
import Data.Tuple.Extra
......@@ -136,7 +136,31 @@ getBranchIdsWith lvl p = sortOn snd
-- | To get the Meta value of a PhyloBranch
getBranchMeta :: Text -> PhyloBranch -> Double
getBranchMeta k b = (b ^. phylo_branchMeta) Map.! k
getBranchMeta k b = (b ^. phylo_branchMeta) ! k
-- | To get the Name of a Clustering Methods
getClusterName :: Clustering -> ClusteringName
getClusterName c = _clustering_name c
-- | To get the params of a Clustering Methods
getClusterParam :: Clustering -> Text -> Double
getClusterParam c k = if (member k $ _clustering_params c)
then (_clustering_params c) Map.! k
else panic "[ERR][Viz.Phylo.Tools.getClusterParam] the key is not in params"
-- | To get the boolean params of a Clustering Methods
getClusterParamBool :: Clustering -> Text -> Bool
getClusterParamBool c k = if (member k $ _clustering_paramsBool c)
then (_clustering_paramsBool c) Map.! k
else panic "[ERR][Viz.Phylo.Tools.getClusterParamBool] the key is not in paramsBool"
-- | To get the first clustering method to apply to get the level 1 of a Phylo
getFstCluster :: PhyloQuery -> Clustering
getFstCluster q = q ^. phyloQuery_fstCluster
-- | To get the foundations of a Phylo
......@@ -355,6 +379,16 @@ getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId)
$ v ^. phylo_viewNodes
-- | To get the cluster methods to apply to the Nths levels of a Phylo
getNthCluster :: PhyloQuery -> Clustering
getNthCluster q = q ^. phyloQuery_nthCluster
-- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
getNthLevel :: PhyloQuery -> Level
getNthLevel q = q ^. phyloQuery_nthLevel
-- | To get the PhylolevelId of a given PhyloLevel
getPhyloLevelId :: PhyloLevel -> PhyloLevelId
getPhyloLevelId = _phylo_levelId
......@@ -376,6 +410,13 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
getPhyloPeriodId prd = _phylo_periodId prd
-- | To get the sensibility of a Proximity if it exists
getSensibility :: Proximity -> Double
getSensibility prox = if (member "sensibility" $ prox ^. proximity_params)
then (prox ^. proximity_params) ! "sensibility"
else panic "[ERR][Viz.Phylo.Tools.getSensibility] sensibility not in params"
-- | To get the PhyloGroupId of the Source of a PhyloEdge
getSourceId :: PhyloEdge -> PhyloGroupId
getSourceId e = e ^. phylo_edgeSource
......@@ -386,6 +427,21 @@ getTargetId :: PhyloEdge -> PhyloGroupId
getTargetId e = e ^. phylo_edgeTarget
-- | To get the Grain of the PhyloPeriods from a PhyloQuery
getTimeGrain :: PhyloQuery -> Int
getTimeGrain q = q ^. phyloQuery_timeGrain
-- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
getTimeMatching :: PhyloQuery -> Proximity
getTimeMatching q = q ^. phyloQuery_timeMatching
-- | To get the Steps of the PhyloPeriods from a PhyloQuery
getTimeSteps :: PhyloQuery -> Int
getTimeSteps q = q ^. phyloQuery_timeSteps
-- | To get all the PhyloBranchIds of a PhyloView
getViewBranchIds :: PhyloView -> [PhyloBranchId]
getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches
......
src/Gargantext/Viz/Phylo/View/ViewMaker.hs
View file @ c35221a6
......@@ -125,7 +125,7 @@ addChildNodes shouldDo lvl lvlMin vb fl p v =
-- | To transform a PhyloQuery into a PhyloView
queryToView :: PhyloQuery -> Phylo -> PhyloView
queryToView :: PhyloQueryView -> Phylo -> PhyloView
queryToView q p = processDisplay (q ^. query_display)
$ processSort (q ^. query_sort) p
$ processTaggers (q ^. query_taggers) p
......@@ -137,7 +137,7 @@ queryToView q p = processDisplay (q ^. query_display)
-- | dirty params
phyloParams :: PhyloParam
phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") ""
phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") "" Nothing
-- | To do : effectively get the PhyloParams of a Phylo
......
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