Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
147
Issues
147
List
Board
Labels
Milestones
Merge Requests
6
Merge Requests
6
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
815ab543
Commit
815ab543
authored
Jun 14, 2019
by
qlobbe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
add parallelism
parent
7832afe9
Pipeline
#473
failed with stage
Changes
10
Pipelines
1
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
211 additions
and
169 deletions
+211
-169
package.yaml
package.yaml
+2
-0
Phylo.hs
src/Gargantext/Viz/Phylo.hs
+6
-2
Cluster.hs
src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs
+14
-12
BranchMaker.hs
src/Gargantext/Viz/Phylo/BranchMaker.hs
+21
-31
Example.hs
src/Gargantext/Viz/Phylo/Example.hs
+1
-1
LevelMaker.hs
src/Gargantext/Viz/Phylo/LevelMaker.hs
+28
-13
LinkMaker.hs
src/Gargantext/Viz/Phylo/LinkMaker.hs
+116
-82
Clustering.hs
src/Gargantext/Viz/Phylo/Metrics/Clustering.hs
+11
-27
Tools.hs
src/Gargantext/Viz/Phylo/Tools.hs
+11
-1
stack.yaml
stack.yaml
+1
-0
No files found.
package.yaml
View file @
815ab543
...
...
@@ -103,6 +103,7 @@ library:
-
contravariant
-
crawlerPubMed
-
data-time-segment
-
deepseq
-
directory
-
duckling
-
exceptions
...
...
@@ -138,6 +139,7 @@ library:
-
natural-transformation
-
opaleye
-
pandoc
-
parallel
-
parsec
-
patches-class
-
patches-map
...
...
src/Gargantext/Viz/Phylo.hs
View file @
815ab543
...
...
@@ -22,7 +22,7 @@ one 8, e54847.
-}
{-# LANGUAGE DeriveGeneric
#-}
{-# LANGUAGE DeriveGeneric
, DeriveAnyClass
#-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
...
...
@@ -44,6 +44,8 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import
Gargantext.Text.Context
(
TermList
)
import
Gargantext.Prelude
import
Control.DeepSeq
--------------------
-- | PhyloParam | --
--------------------
...
...
@@ -161,7 +163,9 @@ data PhyloGroup =
,
_phylo_groupLevelParents
::
[
Pointer
]
,
_phylo_groupLevelChilds
::
[
Pointer
]
}
deriving
(
Generic
,
Show
,
Eq
,
Ord
)
deriving
(
Generic
,
NFData
,
Show
,
Eq
,
Ord
)
-- instance NFData PhyloGroup
-- | Level : A level of aggregation (-1 = Txt, 0 = Ngrams, 1 = Fis, [2..] = Cluster)
...
...
src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs
View file @
815ab543
...
...
@@ -13,11 +13,13 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Viz.Phylo.Aggregates.Cluster
where
import
Data.List
(
null
,
tail
,
concat
,
sort
,
intersect
)
import
Control.Parallel.Strategies
import
Data.List
(
null
,
concat
,
sort
,
intersect
,(
++
))
import
Data.Map
(
Map
)
import
Data.Tuple
(
fst
)
import
Gargantext.Prelude
...
...
@@ -44,17 +46,19 @@ getCandidates gs = filter (\(g,g') -> (not . null) $ intersect (getGroupNgrams g
graphToClusters
::
Cluster
->
GroupGraph
->
[
PhyloCluster
]
graphToClusters
clust
(
nodes
,
edges
)
=
case
clust
of
Louvain
(
LouvainParams
_
)
->
undefined
RelatedComponents
(
RCParams
_
)
->
relatedComp
0
(
head'
"graphToClusters"
nodes
)
(
tail
nodes
,
edges
)
[]
[]
RelatedComponents
(
RCParams
_
)
->
relatedComp
$
((
map
(
\
((
g
,
g'
),
_
)
->
[
g
,
g'
])
edges
)
++
(
map
(
\
g
->
[
g
])
nodes
))
_
->
panic
"[ERR][Viz.Phylo.Aggregates.Cluster.graphToClusters] not implemented"
-- | To transform a list of PhyloGroups into a Graph of Proximity
groupsToGraph
::
Double
->
Proximity
->
[
PhyloGroup
]
->
([
GroupNode
],[
GroupEdge
])
groupsToGraph
nbDocs
prox
gs
=
case
prox
of
WeightedLogJaccard
(
WLJParams
_
sens
)
->
(
gs
,
map
(
\
(
x
,
y
)
->
((
x
,
y
),
weightedLogJaccard
sens
nbDocs
(
getGroupCooc
x
)
(
getGroupCooc
y
)
(
getGroupNgrams
x
)
(
getGroupNgrams
y
)))
$
getCandidates
gs
)
WeightedLogJaccard
(
WLJParams
_
sens
)
->
(
gs
,
let
candidates
=
map
(
\
(
x
,
y
)
->
((
x
,
y
),
weightedLogJaccard
sens
nbDocs
(
getGroupCooc
x
)
(
getGroupCooc
y
)
(
getGroupNgrams
x
)
(
getGroupNgrams
y
)))
$
getCandidates
gs
candidates'
=
candidates
`
using
`
parList
rdeepseq
in
candidates'
)
Hamming
(
HammingParams
_
)
->
(
gs
,
map
(
\
(
x
,
y
)
->
((
x
,
y
),
hamming
(
getGroupCooc
x
)
(
getGroupCooc
y
)))
$
getCandidates
gs
)
_
->
undefined
_
->
undefined
-- | To filter a Graph of Proximity using a given threshold
...
...
@@ -78,9 +82,11 @@ phyloToClusters lvl clus p = Map.fromList
graphs'
=
traceGraphFiltered
lvl
$
map
(
\
g
->
filterGraph
prox
g
)
graphs
--------------------------------------
graphs
::
[([
GroupNode
],[
GroupEdge
])]
graphs
=
traceGraph
lvl
(
getThreshold
prox
)
$
map
(
\
prd
->
groupsToGraph
(
periodsToNbDocs
[
prd
]
p
)
prox
(
getGroupsWithFilters
lvl
prd
p
))
periods
graphs
::
[([
GroupNode
],[
GroupEdge
])]
graphs
=
traceGraph
lvl
(
getThreshold
prox
)
$
let
gs
=
map
(
\
prd
->
groupsToGraph
(
periodsToNbDocs
[
prd
]
p
)
prox
(
getGroupsWithFilters
lvl
prd
p
))
periods
gs'
=
gs
`
using
`
parList
rdeepseq
in
gs'
--------------------------------------
prox
::
Proximity
prox
=
getProximity
clus
...
...
@@ -115,7 +121,3 @@ traceGraphFiltered lvl g = trace ( "----\nClustering in Phylo" <> show (lvl) <>
<>
show
(
percentile
90
(
VS
.
fromList
lst
))
<>
" (90%)
\n
"
)
g
where
lst
=
sort
$
map
snd
$
concat
$
map
snd
g
-- traceSim :: PhyloGroup -> PhyloGroup -> Phylo -> Double -> Double
-- traceSim g g' p sim = trace (show (getGroupText g p) <> " [vs] " <> show (getGroupText g' p) <> " = " <> show (sim) <> "\n") sim
src/Gargantext/Viz/Phylo/BranchMaker.hs
View file @
815ab543
...
...
@@ -17,6 +17,7 @@ Portability : POSIX
module
Gargantext.Viz.Phylo.BranchMaker
where
import
Control.Parallel.Strategies
import
Control.Lens
hiding
(
both
,
Level
)
import
Data.List
(
concat
,
nub
,(
++
),
tail
,
sortOn
,
take
,
reverse
,
sort
,
null
,
intersect
,
union
)
import
Data.Map
(
Map
)
...
...
@@ -82,13 +83,14 @@ findSimBranches frame thr nth p (id,gs) bs
pks
=
getGroupsPeaks
gs
nth
p
--------------------------------------
findBestPointer
::
Phylo
->
Proximity
->
[
PhyloGroup
]
->
[
PhyloGroup
]
->
[(
PhyloGroupId
,
Pointer
)]
findBestPointer
p
prox
gs
gs'
=
take
1
$
reverse
$
sortOn
(
snd
.
snd
)
$
concat
$
map
(
\
g
->
let
pts
=
findBestCandidates'
prox
gs'
g
p
in
map
(
\
pt
->
(
getGroupId
g
,
pt
))
pts
)
gs
findBestPointer
p
prox
gs
gs'
=
let
candidates
=
map
(
\
g
->
let
pts
=
findBestCandidates'
prox
gs'
g
p
in
map
(
\
pt
->
(
getGroupId
g
,
pt
))
pts
)
gs
candidates'
=
candidates
`
using
`
parList
rdeepseq
in
take
1
$
reverse
$
sortOn
(
snd
.
snd
)
$
concat
candidates'
makeBranchLinks
::
Phylo
->
Proximity
->
(
PhyloBranchId
,[
PhyloGroup
])
->
[(
PhyloBranchId
,[
PhyloGroup
])]
->
[(
PhyloGroupId
,
Pointer
)]
->
[(
PhyloGroupId
,
Pointer
)]
makeBranchLinks
p
prox
(
id
,
gs
)
bs
pts
...
...
@@ -126,34 +128,22 @@ linkPhyloBranches lvl prox p = setPhyloBranches lvl
-- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
graphToBranches
::
Level
->
GroupGraph
->
Phylo
->
[(
Int
,
PhyloGroupId
)]
graphToBranches
_lvl
(
nodes
,
edges
)
_p
=
concat
$
map
(
\
(
idx
,
gs
)
->
map
(
\
g
->
(
idx
,
getGroupId
g
))
gs
)
$
zip
[
1
..
]
$
relatedComp
0
(
head'
"branchMaker"
nodes
)
(
tail
nodes
,
edges
)
[]
[]
-- | To build a graph using the parents and childs pointers
makeGraph
::
[
PhyloGroup
]
->
Phylo
->
GroupGraph
makeGraph
gs
p
=
(
gs
,
edges
)
where
edges
::
[
GroupEdge
]
edges
=
(
nub
.
concat
)
$
map
(
\
g
->
(
map
(
\
g'
->
((
g'
,
g
),
1
))
$
getGroupParents
g
p
)
++
(
map
(
\
g'
->
((
g
,
g'
),
1
))
$
getGroupChilds
g
p
))
gs
graphToBranches
::
[
PhyloGroup
]
->
Phylo
->
[(
Int
,
PhyloGroupId
)]
graphToBranches
groups
p
=
concat
$
map
(
\
(
idx
,
gs
)
->
map
(
\
g
->
(
idx
,
getGroupId
g
))
gs
)
$
zip
[
1
..
]
$
relatedComp
$
map
(
\
g
->
nub
$
[
g
]
++
(
getGroupParents
g
p
)
++
(
getGroupChilds
g
p
))
groups
-- | To set all the PhyloBranches for a given Level in a Phylo
setPhyloBranches
::
Level
->
Phylo
->
Phylo
setPhyloBranches
lvl
p
=
alterGroupWithLevel
(
\
g
->
let
bIdx
=
(
fst
$
head'
"branchMaker"
$
filter
(
\
b
->
snd
b
==
getGroupId
g
)
bs
)
in
over
(
phylo_groupBranchId
)
(
\
_
->
Just
(
lvl
,
bIdx
))
g
)
lvl
p
where
--------------------------------------
bs
::
[(
Int
,
PhyloGroupId
)]
bs
=
graphToBranches
lvl
graph
p
setPhyloBranches
lvl
p
=
alterGroupWithLevel
(
\
g
->
let
bIdx
=
(
fst
$
head'
"branchMaker"
$
filter
(
\
b
->
snd
b
==
getGroupId
g
)
branches
)
in
over
(
phylo_groupBranchId
)
(
\
_
->
Just
(
lvl
,
bIdx
))
g
)
lvl
p
where
--------------------------------------
graph
::
GroupGraph
graph
=
makeGraph
(
getGroupsWithLevel
lvl
p
)
p
branches
::
[(
Int
,
PhyloGroupId
)]
branches
=
graphToBranches
(
getGroupsWithLevel
lvl
p
)
p
--------------------------------------
src/Gargantext/Viz/Phylo/Example.hs
View file @
815ab543
...
...
@@ -105,7 +105,7 @@ queryEx = "title=Cesar et Cleôpatre"
phyloQueryBuild
::
PhyloQueryBuild
phyloQueryBuild
=
PhyloQueryBuild
"Cesar et Cleôpatre"
"An example of Phylomemy (french without accent)"
5
3
defaultFis
[]
[]
(
WeightedLogJaccard
$
WLJParams
0.
1
20
)
5
0.5
4
2
(
RelatedComponents
$
RCParams
$
WeightedLogJaccard
$
WLJParams
0.3
0
)
5
3
defaultFis
[]
[]
(
WeightedLogJaccard
$
WLJParams
0.
6
20
)
5
0.5
4
2
(
RelatedComponents
$
RCParams
$
WeightedLogJaccard
$
WLJParams
0.4
0
)
...
...
src/Gargantext/Viz/Phylo/LevelMaker.hs
View file @
815ab543
...
...
@@ -19,6 +19,7 @@ Portability : POSIX
module
Gargantext.Viz.Phylo.LevelMaker
where
import
Control.Parallel.Strategies
import
Control.Lens
hiding
(
both
,
Level
)
import
Data.List
((
++
),
sort
,
concat
,
nub
,
zip
,
last
)
import
Data.Map
(
Map
,
(
!
),
empty
,
singleton
)
...
...
@@ -61,7 +62,10 @@ instance PhyloLevelMaker PhyloCluster
|
otherwise
=
panic
(
"[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2"
)
--------------------------------------
-- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
toPhyloGroups
lvl
(
d
,
d'
)
l
m
p
=
map
(
\
(
idx
,
cluster
)
->
clusterToGroup
(
d
,
d'
)
lvl
idx
""
cluster
m
p
)
$
zip
[
1
..
]
l
toPhyloGroups
lvl
(
d
,
d'
)
l
m
p
=
let
clusters
=
map
(
\
(
idx
,
cluster
)
->
clusterToGroup
(
d
,
d'
)
lvl
idx
""
cluster
m
p
)
$
zip
[
1
..
]
l
clusters'
=
clusters
`
using
`
parList
rdeepseq
in
clusters'
--------------------------------------
...
...
@@ -74,7 +78,10 @@ instance PhyloLevelMaker PhyloFis
|
otherwise
=
panic
(
"[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1"
)
--------------------------------------
-- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
toPhyloGroups
lvl
(
d
,
d'
)
l
_
p
=
map
(
\
(
idx
,
fis
)
->
cliqueToGroup
(
d
,
d'
)
lvl
idx
""
fis
p
)
$
zip
[
1
..
]
l
toPhyloGroups
lvl
(
d
,
d'
)
l
_
p
=
let
groups
=
map
(
\
(
idx
,
fis
)
->
cliqueToGroup
(
d
,
d'
)
lvl
idx
""
fis
p
)
$
zip
[
1
..
]
l
groups'
=
groups
`
using
`
parList
rdeepseq
in
groups'
--------------------------------------
...
...
@@ -87,8 +94,7 @@ instance PhyloLevelMaker Document
|
otherwise
=
panic
(
"[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> 0"
)
--------------------------------------
-- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
toPhyloGroups
lvl
(
d
,
d'
)
l
_m
p
=
map
(
\
(
idx
,
ngram
)
->
ngramsToGroup
(
d
,
d'
)
lvl
idx
ngram
[
ngram
]
p
)
$
zip
[
1
..
]
toPhyloGroups
lvl
(
d
,
d'
)
l
_m
p
=
map
(
\
ngram
->
ngramsToGroup
(
d
,
d'
)
lvl
(
getIdxInRoots
ngram
p
)
ngram
[
ngram
]
p
)
$
(
nub
.
concat
)
$
map
text
l
--------------------------------------
...
...
@@ -100,11 +106,13 @@ clusterToGroup prd lvl idx lbl groups _m p =
PhyloGroup
((
prd
,
lvl
),
idx
)
lbl
ngrams
empty
Nothing
(
getMiniCooc
(
listToFullCombi
ngrams
)
(
periodsToYears
[
prd
])
(
getPhyloCooc
p
))
[]
[]
[]
childs
ascLink
desLink
[]
childs
where
--------------------------------------
childs
::
[
Pointer
]
childs
=
map
(
\
g
->
(
getGroupId
g
,
1
))
groups
ascLink
=
concat
$
map
getGroupPeriodParents
groups
desLink
=
concat
$
map
getGroupPeriodChilds
groups
--------------------------------------
ngrams
::
[
Int
]
ngrams
=
(
sort
.
nub
.
concat
)
$
map
getGroupNgrams
groups
...
...
@@ -116,7 +124,7 @@ cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> PhyloFis -> Phylo -> P
cliqueToGroup
prd
lvl
idx
lbl
fis
p
=
PhyloGroup
((
prd
,
lvl
),
idx
)
lbl
ngrams
(
singleton
"support"
(
fromIntegral
$
getSupport
fis
))
Nothing
(
getMiniCooc
(
listToFullCombi
ngrams
)
(
periodsToYears
[
prd
])
(
getPhyloCooc
p
))
[]
[]
[]
[]
[]
[]
[]
childs
where
--------------------------------------
ngrams
::
[
Int
]
...
...
@@ -124,6 +132,9 @@ cliqueToGroup prd lvl idx lbl fis p =
$
Set
.
toList
$
getClique
fis
--------------------------------------
childs
::
[
Pointer
]
childs
=
map
(
\
n
->
(((
prd
,
lvl
-
1
),
n
),
1
))
ngrams
--------------------------------------
-- | To transform a list of Ngrams into a PhyloGroup
...
...
@@ -152,6 +163,7 @@ toNthLevel lvlMax prox clus p
$
traceBranches
(
lvl
+
1
)
$
setPhyloBranches
(
lvl
+
1
)
$
transposePeriodLinks
(
lvl
+
1
)
$
tracePhyloN
(
lvl
+
1
)
$
setLevelLinks
(
lvl
,
lvl
+
1
)
$
addPhyloLevel
(
lvl
+
1
)
(
clusters
)
p
...
...
@@ -169,15 +181,15 @@ toNthLevel lvlMax prox clus p
toPhylo1
::
Cluster
->
Proximity
->
Map
(
Date
,
Date
)
[
Document
]
->
Phylo
->
Phylo
toPhylo1
clus
prox
d
p
=
case
clus
of
Fis
(
FisParams
k
s
t
)
->
traceReBranches
1
$
linkPhyloBranches
1
prox
--
$ linkPhyloBranches 1 prox
$
traceBranches
1
$
setPhyloBranches
1
$
traceTempoMatching
Descendant
1
$
interTempoMatching
Descendant
1
prox
$
traceTempoMatching
Ascendant
1
$
interTempoMatching
Ascendant
1
prox
$
tracePhylo1
$
setLevelLinks
(
0
,
1
)
$
setLevelLinks
(
1
,
0
)
$
addPhyloLevel
1
phyloFis
phylo'
where
--------------------------------------
...
...
@@ -212,7 +224,7 @@ instance PhyloMaker [(Date, Text)]
phylo1
=
toPhylo1
(
getContextualUnit
q
)
(
getInterTemporalMatching
q
)
phyloDocs
phylo0
--------------------------------------
phylo0
::
Phylo
phylo0
=
toPhylo0
phyloDocs
phyloBase
phylo0
=
t
racePhylo0
$
t
oPhylo0
phyloDocs
phyloBase
--------------------------------------
phyloDocs
::
Map
(
Date
,
Date
)
[
Document
]
phyloDocs
=
corpusToDocs
c
phyloBase
...
...
@@ -251,7 +263,7 @@ instance PhyloMaker [Document]
phylo1
=
toPhylo1
(
getContextualUnit
q
)
(
getInterTemporalMatching
q
)
phyloDocs
phylo0
--------------------------------------
phylo0
::
Phylo
phylo0
=
toPhylo0
phyloDocs
phyloBase
phylo0
=
t
racePhylo0
$
t
oPhylo0
phyloDocs
phyloBase
--------------------------------------
phyloDocs
::
Map
(
Date
,
Date
)
[
Document
]
phyloDocs
=
corpusToDocs
c
phyloBase
...
...
@@ -286,13 +298,16 @@ instance PhyloMaker [Document]
tracePhylo0
::
Phylo
->
Phylo
tracePhylo0
p
=
trace
(
"
\n
---------------
\n
--| Phylo 0 |--
\n
---------------
\n\n
"
)
p
tracePhylo0
p
=
trace
(
"
\n
---------------
\n
--| Phylo 0 |--
\n
---------------
\n\n
"
<>
show
(
length
$
getGroupsWithLevel
0
p
)
<>
" groups created
\n
"
)
p
tracePhylo1
::
Phylo
->
Phylo
tracePhylo1
p
=
trace
(
"
\n
---------------
\n
--| Phylo 1 |--
\n
---------------
\n\n
"
)
p
tracePhylo1
p
=
trace
(
"
\n
---------------
\n
--| Phylo 1 |--
\n
---------------
\n\n
"
<>
show
(
length
$
getGroupsWithLevel
1
p
)
<>
" groups created
\n
"
)
p
tracePhyloN
::
Level
->
Phylo
->
Phylo
tracePhyloN
lvl
p
=
trace
(
"
\n
---------------
\n
--| Phylo "
<>
show
(
lvl
)
<>
" |--
\n
---------------
\n\n
"
)
p
tracePhyloN
lvl
p
=
trace
(
"
\n
---------------
\n
--| Phylo "
<>
show
(
lvl
)
<>
" |--
\n
---------------
\n\n
"
<>
show
(
length
$
getGroupsWithLevel
lvl
p
)
<>
" groups created
\n
"
)
p
tracePhyloBase
::
Phylo
->
Phylo
...
...
src/Gargantext/Viz/Phylo/LinkMaker.hs
View file @
815ab543
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Metrics/Clustering.hs
View file @
815ab543
...
...
@@ -18,36 +18,20 @@ module Gargantext.Viz.Phylo.Metrics.Clustering
where
import
Data.Graph.Clustering.Louvain.CplusPlus
import
Data.List
(
last
,
concat
,
null
,
nub
,(
++
),
init
,
tail
,
elemIndex
,
groupBy
,(
!!
)
)
import
Data.List
(
concat
,
null
,
nub
,(
++
),
elemIndex
,
groupBy
,(
!!
),
(
\\
),
union
,
intersect
)
import
Data.Map
(
fromList
,
mapKeys
)
import
Gargantext.Prelude
import
Gargantext.Viz.Phylo
import
Gargantext.Viz.Phylo.Tools
-- | To apply the related components method to a PhyloGraph
-- curr = the current PhyloGroup
-- (nodes,edges) = the initial PhyloGraph minus the current PhyloGroup
-- next = the next PhyloGroups to be added in the cluster
-- memo = the memory of the allready created clusters
relatedComp
::
Int
->
PhyloGroup
->
GroupGraph
->
[
PhyloGroup
]
->
[[
PhyloGroup
]]
->
[[
PhyloGroup
]]
relatedComp
idx
curr
(
nodes
,
edges
)
next
memo
|
null
nodes'
&&
null
next'
=
memo'
|
(
not
.
null
)
next'
=
relatedComp
idx
(
head'
"relatedComp1"
next'
)
(
nodes'
,
edges
)
(
tail
next'
)
memo'
|
otherwise
=
relatedComp
(
idx
+
1
)
(
head'
"relatedComp2"
nodes'
)
(
tail
nodes'
,
edges
)
[]
memo'
where
--------------------------------------
memo'
::
[[
PhyloGroup
]]
memo'
|
null
memo
=
[[
curr
]]
|
idx
==
((
length
memo
)
-
1
)
=
(
init
memo
)
++
[(
last
memo
)
++
[
curr
]]
|
otherwise
=
memo
++
[[
curr
]]
--------------------------------------
next'
::
[
PhyloGroup
]
next'
=
filter
(
\
x
->
not
$
elem
x
$
concat
memo
)
$
nub
$
next
++
(
getNeighbours
False
curr
edges
)
--------------------------------------
nodes'
::
[
PhyloGroup
]
nodes'
=
filter
(
\
x
->
not
$
elem
x
next'
)
nodes
--------------------------------------
relatedComp
::
[[
PhyloGroup
]]
->
[[
PhyloGroup
]]
relatedComp
graphs
=
foldl'
(
\
mem
groups
->
if
(
null
mem
)
then
mem
++
[
groups
]
else
let
related
=
filter
(
\
groups'
->
(
not
.
null
)
$
intersect
groups
groups'
)
mem
in
if
(
null
related
)
then
mem
++
[
groups
]
else
(
mem
\\
related
)
++
[
union
groups
(
nub
$
concat
related
)]
)
[]
graphs
louvain
::
([
GroupNode
],[
GroupEdge
])
->
IO
[[
PhyloGroup
]]
...
...
src/Gargantext/Viz/Phylo/Tools.hs
View file @
815ab543
...
...
@@ -110,6 +110,13 @@ listToDirectedCombi :: Eq a => [a] -> [(a,a)]
listToDirectedCombi
l
=
[(
x
,
y
)
|
x
<-
l
,
y
<-
l
,
x
/=
y
]
listToEqualCombi
::
Eq
a
=>
[
a
]
->
[(
a
,
a
)]
listToEqualCombi
l
=
[(
x
,
y
)
|
x
<-
l
,
y
<-
l
,
x
==
y
]
listToPairs
::
Eq
a
=>
[
a
]
->
[(
a
,
a
)]
listToPairs
l
=
(
listToEqualCombi
l
)
++
(
listToUnDirectedCombi
l
)
-- | 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
]
...
...
@@ -195,6 +202,9 @@ getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
getPhyloMatchingFrame
::
Phylo
->
Int
getPhyloMatchingFrame
p
=
_q_interTemporalMatchingFrame
$
_phyloParam_query
$
getPhyloParams
p
getPhyloProximity
::
Phylo
->
Proximity
getPhyloProximity
p
=
_q_interTemporalMatching
$
_phyloParam_query
$
getPhyloParams
p
getPhyloReBranchThr
::
Phylo
->
Double
getPhyloReBranchThr
p
=
_q_reBranchThr
$
_phyloParam_query
$
getPhyloParams
p
...
...
@@ -243,7 +253,7 @@ alterGroupWithLevel f lvl p = over ( phylo_periods
.
traverse
)
(
\
g
->
if
getGroupLevel
g
==
lvl
then
f
g
else
g
)
p
else
g
)
p
-- | To alter each list of PhyloGroups following a given function
...
...
stack.yaml
View file @
815ab543
...
...
@@ -35,6 +35,7 @@ extra-deps:
-
KMP-0.1.0.2
-
accelerate-1.2.0.0
-
aeson-lens-0.5.0.0
-
deepseq-th-0.1.0.4
-
duckling-0.1.3.0
-
full-text-search-0.2.1.4
-
fullstop-0.1.4
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment