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
108
Issues
108
List
Board
Labels
Milestones
Merge Requests
5
Merge Requests
5
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
5f77499e
Commit
5f77499e
authored
Sep 30, 2022
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[MERGE] dev-phylo
parent
5d9172ee
Changes
12
Expand all
Show whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
803 additions
and
792 deletions
+803
-792
Main.hs
bin/gargantext-phylo/Main.hs
+34
-51
gargantext.cabal
gargantext.cabal
+1
-1
MaxClique.hs
src/Gargantext/Core/Methods/Graph/MaxClique.hs
+1
-1
Phylo.hs
src/Gargantext/Core/Viz/Phylo.hs
+87
-87
API.hs
src/Gargantext/Core/Viz/Phylo/API.hs
+3
-2
Tools.hs
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
+3
-3
Example.hs
src/Gargantext/Core/Viz/Phylo/Example.hs
+23
-20
PhyloExport.hs
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
+32
-30
PhyloMaker.hs
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
+126
-88
PhyloTools.hs
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
+96
-73
SynchronicClustering.hs
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
+27
-26
TemporalMatching.hs
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
+370
-410
No files found.
bin/gargantext-phylo/Main.hs
View file @
5f77499e
...
...
@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListType(..))
import
Gargantext.Core.Viz.Phylo
import
Gargantext.Core.Viz.Phylo.API.Tools
import
Gargantext.Core.Viz.Phylo.PhyloExport
(
toPhyloExport
,
dotToFile
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhylo
Step
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhylo
WithoutLink
)
import
Gargantext.Core.Viz.Phylo.PhyloTools
(
printIOMsg
,
printIOComment
,
setConfig
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
...
...
@@ -50,7 +50,7 @@ import qualified Data.Text as T
import
qualified
Data.Vector
as
Vector
import
qualified
Gargantext.Core.Text.Corpus.Parsers.CSV
as
Csv
data
PhyloStage
=
PhyloWithCliques
|
PhyloWithLinks
deriving
(
Show
)
data
Backup
=
BackupPhyloWithoutLink
|
BackupPhylo
deriving
(
Show
)
---------------
-- | Tools | --
...
...
@@ -153,9 +153,9 @@ seaToLabel config = case (seaElevation config) of
sensToLabel
::
PhyloConfig
->
[
Char
]
sensToLabel
config
=
case
(
phyloProximity
config
)
of
Hamming
_
->
undefined
WeightedLogJaccard
s
->
(
"WeightedLogJaccard_"
<>
show
s
)
WeightedLogSim
s
->
(
"WeightedLogSim-sens_"
<>
show
s
)
Hamming
_
_
->
undefined
WeightedLogJaccard
s
_
->
(
"WeightedLogJaccard_"
<>
show
s
)
WeightedLogSim
s
_
->
(
"WeightedLogSim-sens_"
<>
show
s
)
cliqueToLabel
::
PhyloConfig
->
[
Char
]
...
...
@@ -179,7 +179,7 @@ configToLabel :: PhyloConfig -> [Char]
configToLabel
config
=
outputPath
config
<>
(
unpack
$
phyloName
config
)
<>
"-"
<>
(
timeToLabel
config
)
<>
"-scale_"
<>
(
show
(
phylo
Level
config
))
<>
"-scale_"
<>
(
show
(
phylo
Scale
config
))
<>
"-"
<>
(
seaToLabel
config
)
<>
"-"
<>
(
sensToLabel
config
)
<>
"-"
<>
(
cliqueToLabel
config
)
...
...
@@ -189,18 +189,18 @@ configToLabel config = outputPath config
-- To write a sha256 from a set of config's parameters
configToSha
::
PhyloStage
->
PhyloConfig
->
[
Char
]
configToSha
::
Backup
->
PhyloConfig
->
[
Char
]
configToSha
stage
config
=
unpack
$
replace
"/"
"-"
$
T
.
pack
(
show
(
hash
$
C8
.
pack
label
))
where
label
::
[
Char
]
label
=
case
stage
of
PhyloWithCliques
->
(
corpusPath
config
)
BackupPhyloWithoutLink
->
(
corpusPath
config
)
<>
(
listPath
config
)
<>
(
timeToLabel
config
)
<>
(
cliqueToLabel
config
)
PhyloWithLinks
->
(
corpusPath
config
)
BackupPhylo
->
(
corpusPath
config
)
<>
(
listPath
config
)
<>
(
timeToLabel
config
)
<>
(
cliqueToLabel
config
)
...
...
@@ -208,7 +208,7 @@ configToSha stage config = unpack
<>
(
seaToLabel
config
)
<>
(
syncToLabel
config
)
<>
(
qualToConfig
config
)
<>
(
show
(
phylo
Level
config
))
<>
(
show
(
phylo
Scale
config
))
readListV4
::
[
Char
]
->
IO
NgramsList
...
...
@@ -255,55 +255,38 @@ main = do
printIOMsg
"Reconstruct the phylo"
let
phyloWithCliquesFile
=
(
outputPath
config
)
<>
"phyloWithCliques_"
<>
(
configToSha
PhyloWithCliques
config
)
<>
".json"
let
phyloWithLinksFile
=
(
outputPath
config
)
<>
"phyloWithLinks_"
<>
(
configToSha
PhyloWithLinks
config
)
<>
".json"
-- check the existing backup files
phyloWithCliquesExists
<-
doesFileExist
phyloWithCliquesFile
phyloWithLinksExists
<-
doesFileExist
phyloWithLinksFile
let
backupPhyloWithoutLink
=
(
outputPath
config
)
<>
"backupPhyloWithoutLink_"
<>
(
configToSha
BackupPhyloWithoutLink
config
)
<>
".json"
let
backupPhylo
=
(
outputPath
config
)
<>
"backupPhylo_"
<>
(
configToSha
BackupPhylo
config
)
<>
".json"
-- phyloStep <- if phyloWithCliquesExists
-- then do
-- printIOMsg "Reconstruct the phylo step from an existing file"
-- readPhylo phyloWithCliquesFile
-- else do
-- printIOMsg "Reconstruct the phylo step from scratch"
-- pure $ toPhyloStep corpus mapList config
phyloWithoutLinkExists
<-
doesFileExist
backupPhyloWithoutLink
phyloExists
<-
doesFileExist
backupPhylo
--
writePhylo phyloWithCliquesFile phyloStep
--
reconstruct the phylo
-- let phylo = toPhylo (setConfig config phyloStep)
phyloWithLinks
<-
if
phyloWithLinksExists
phylo
<-
if
phyloExists
then
do
printIOMsg
"Reconstruct the phylo from an existing file with intertemporal links
"
readPhylo
phyloWithLinksFile
printIOMsg
"Reconstruct the phylo from an existing file
"
readPhylo
backupPhylo
else
do
if
phyloWithCliques
Exists
if
phyloWithoutLink
Exists
then
do
printIOMsg
"Reconstruct the phylo from an existing file with clique
s"
phyloWithCliques
<-
readPhylo
phyloWithCliquesFile
writePhylo
phyloWithCliquesFile
phyloWithCliques
pure
$
toPhylo
(
setConfig
config
phyloWithCliques
)
printIOMsg
"Reconstruct the phylo from an existing file without link
s"
phyloWithoutLink
<-
readPhylo
backupPhyloWithoutLink
writePhylo
backupPhyloWithoutLink
phyloWithoutLink
pure
$
toPhylo
(
setConfig
config
phyloWithoutLink
)
else
do
printIOMsg
"Reconstruct the phylo from scratch"
phyloWithCliques
<-
pure
$
toPhyloStep
corpus
mapList
config
writePhylo
phyloWithCliquesFile
phyloWithCliques
pure
$
toPhylo
(
setConfig
config
phyloWithCliques
)
writePhylo
phyloWithLinksFile
phyloWithLinks
-- probes
-- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_synchronic_distance_cumu_jaccard.txt")
-- $ synchronicDistance' phylo 1
phyloWithoutLink
<-
pure
$
toPhyloWithoutLink
corpus
mapList
config
writePhylo
backupPhyloWithoutLink
phyloWithoutLink
pure
$
toPhylo
(
setConfig
config
phyloWithoutLink
)
-- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_inflexion_points.txt")
-- $ inflexionPoints phylo 1
writePhylo
backupPhylo
phylo
printIOMsg
"End of reconstruction, start the export"
let
dot
=
toPhyloExport
(
setConfig
config
phylo
WithLinks
)
let
dot
=
toPhyloExport
(
setConfig
config
phylo
)
let
output
=
configToLabel
config
...
...
gargantext.cabal
View file @
5f77499e
src/Gargantext/Core/Methods/Graph/MaxClique.hs
View file @
5f77499e
...
...
@@ -72,7 +72,7 @@ type Neighbor = Node
-- | getMaxCliques
-- TODO chose distance order
getMaxCliques
::
Ord
a
=>
CliqueFilter
->
Distance
->
Threshold
->
Map
(
a
,
a
)
Int
->
[[
a
]]
getMaxCliques
::
Ord
a
=>
Max
CliqueFilter
->
Distance
->
Threshold
->
Map
(
a
,
a
)
Int
->
[[
a
]]
getMaxCliques
f
d
t
m
=
map
fromIndices
$
getMaxCliques'
t
m'
where
m'
=
toIndex
to
m
...
...
src/Gargantext/Core/Viz/Phylo.hs
View file @
5f77499e
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/API.hs
View file @
5f77499e
...
...
@@ -27,7 +27,7 @@ import Gargantext.Core.Types (TODO(..))
import
Gargantext.Core.Viz.LegacyPhylo
import
Gargantext.Core.Viz.Phylo
(
defaultConfig
)
import
Gargantext.Core.Viz.Phylo.API.Tools
import
Gargantext.Core.Viz.Phylo.Example
(
phylo
Exampl
e
)
import
Gargantext.Core.Viz.Phylo.Example
(
phylo
Cleopatr
e
)
import
Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
-- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
...
...
@@ -118,7 +118,8 @@ getPhylo phyloId lId _level _minSizeBranch = do
getPhyloDataJson
::
PhyloId
->
GargNoServer
Value
getPhyloDataJson
phyloId
=
do
phyloData
<-
fromMaybe
phyloExample
<$>
getPhyloData
phyloId
maybePhyloData
<-
getPhyloData
phyloId
let
phyloData
=
fromMaybe
phyloCleopatre
maybePhyloData
phyloJson
<-
liftBase
$
phylo2dot2json
phyloData
pure
phyloJson
...
...
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @
5f77499e
...
...
@@ -30,7 +30,7 @@ import Gargantext.Core.Types (Context)
import
Gargantext.Core.Types.Main
(
ListType
(
MapTerm
))
import
Gargantext.Core.Viz.Phylo
(
TimeUnit
(
..
),
Date
,
Document
(
..
),
PhyloConfig
(
..
),
Phylo
)
import
Gargantext.Core.Viz.Phylo.PhyloExport
(
toPhyloExport
,
dotToFile
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhylo
Step
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhylo
WithoutLink
)
import
Gargantext.Core.Viz.Phylo.PhyloTools
(
{-printIOMsg, printIOComment,-}
setConfig
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataPhylo
(
..
))
...
...
@@ -87,9 +87,9 @@ phylo2dot2json phylo = do
flowPhyloAPI
::
PhyloConfig
->
CorpusId
->
GargNoServer
Phylo
flowPhyloAPI
config
cId
=
do
(
mapList
,
corpus
)
<-
corpusIdtoDocuments
(
timeUnit
config
)
cId
temporalSeries
<-
pure
$
toPhyloStep
corpus
mapList
config
phyloWithCliques
<-
pure
$
toPhyloWithoutLink
corpus
mapList
config
-- writePhylo phyloWithCliquesFile phyloWithCliques
pure
$
toPhylo
(
setConfig
config
temporalSeri
es
)
pure
$
toPhylo
(
setConfig
config
phyloWithCliqu
es
)
--------------------------------------------------------------------
corpusIdtoDocuments
::
TimeUnit
->
CorpusId
->
GargNoServer
(
TermList
,
[
Document
])
...
...
src/Gargantext/Core/Viz/Phylo/Example.hs
View file @
5f77499e
...
...
@@ -27,9 +27,10 @@ import Gargantext.Core.Viz.Phylo.PhyloExport
import
Gargantext.Core.Viz.Phylo.PhyloMaker
import
Gargantext.Core.Viz.Phylo.PhyloTools
import
Gargantext.Core.Viz.Phylo.SynchronicClustering
(
synchronicClustering
)
import
Gargantext.Core.Viz.Phylo.TemporalMatching
(
adaptativeTemporalMatching
,
constanteT
emporalMatching
)
import
Gargantext.Core.Viz.Phylo.TemporalMatching
(
t
emporalMatching
)
import
Gargantext.Prelude
import
qualified
Data.Vector
as
Vector
import
qualified
Data.Set
as
Set
---------------------------------
-- | STEP 5 | -- Export the phylo
...
...
@@ -39,49 +40,50 @@ phyloExport :: IO ()
phyloExport
=
dotToFile
"/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot"
phyloDot
phyloDot
::
DotGraph
DotId
phyloDot
=
toPhyloExport
phylo
Exampl
e
phyloDot
=
toPhyloExport
phylo
Cleopatr
e
--------------------------------------------------
-- | STEP 4 | -- Process the synchronic clustering
--------------------------------------------------
phylo
Exampl
e
::
Phylo
phylo
Example
=
synchronicClustering
$
toHorizon
phylo1
phylo
Cleopatr
e
::
Phylo
phylo
Cleopatre
=
synchronicClustering
$
toHorizon
flatPhylo
-----------------------------------------------
-- | STEP 3 | -- Build the Level 1 of the Phylo
-----------------------------------------------
phylo1
::
Phylo
phylo1
=
case
(
getSeaElevation
phyloBase
)
of
Constante
s
g
->
constanteTemporalMatching
s
g
$
toGroupsProxi
1
$
appendGroups
cliqueToGroup
1
phyloClique
phyloBase
Adaptative
s
->
adaptativeTemporalMatching
s
$
toGroupsProxi
1
$
appendGroups
cliqueToGroup
1
phyloClique
phyloBase
flatPhylo
::
Phylo
flatPhylo
=
case
(
getSeaElevation
emptyPhylo
)
of
Constante
s
g
->
temporalMatching
(
constDiachronicLadder
s
g
Set
.
empty
)
$
scanSimilarity
1
$
appendGroups
clusterToGroup
1
seriesOfClustering
emptyPhylo
Adaptative
s
->
temporalMatching
(
adaptDiachronicLadder
s
(
emptyPhylo'
^.
phylo_diaSimScan
)
Set
.
empty
)
emptyPhylo'
emptyPhylo'
::
Phylo
emptyPhylo'
=
scanSimilarity
1
$
appendGroups
clusterToGroup
1
seriesOfClustering
emptyPhylo
---------------------------------------------
-- | STEP 2 | -- Build the cliques
---------------------------------------------
phyloClique
::
Map
(
Date
,
Date
)
[
PhyloClique
]
phyloClique
=
toPhyloClique
phyloBase
docsByPeriods
seriesOfClustering
::
Map
(
Date
,
Date
)
[
Clustering
]
seriesOfClustering
=
toSeriesOfClustering
emptyPhylo
docsByPeriods
docsByPeriods
::
Map
(
Date
,
Date
)
[
Document
]
docsByPeriods
=
groupDocsByPeriod
date
periods
docs
---------------------------------
-----------
-- | STEP 1 | -- Init the
Base of the
Phylo
---------------------------------
-----------
---------------------------------
-- | STEP 1 | -- Init the Phylo
---------------------------------
phyloBase
::
Phylo
phyloBase
=
toPhyloBase
docs
mapList
config
emptyPhylo
::
Phylo
emptyPhylo
=
initPhylo
docs
mapList
config
phyloCooc
::
Map
Date
Cooc
...
...
@@ -101,7 +103,8 @@ nbDocsByYear = docsToTimeScaleNb docs
config
::
PhyloConfig
config
=
defaultConfig
{
phyloName
=
"Cesar et Cleopatre"
,
phyloLevel
=
2
,
phyloScale
=
2
,
seaElevation
=
Adaptative
4
,
exportFilter
=
[
ByBranchSize
0
]
,
clique
=
MaxClique
0
15
ByNeighbours
}
...
...
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @
5f77499e
...
...
@@ -26,7 +26,7 @@ import Debug.Trace (trace)
import
Gargantext.Core.Viz.Phylo
import
Gargantext.Core.Viz.Phylo.PhyloTools
import
Gargantext.Core.Viz.Phylo.TemporalMatching
(
filterDocs
,
filterDiago
,
reduceDiagos
,
toProximity
,
getNextPeriods
)
import
Gargantext.Prelude
import
Gargantext.Prelude
hiding
(
scale
)
import
Prelude
(
writeFile
)
import
System.FilePath
import
qualified
Data.GraphViz.Attributes.HTML
as
H
...
...
@@ -73,7 +73,7 @@ groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show
branchIdToDotId
::
PhyloBranchId
->
DotId
branchIdToDotId
bId
=
(
fromStrict
.
Text
.
pack
)
$
(
"branch"
<>
show
(
snd
bId
))
periodIdToDotId
::
P
hyloPeriodI
d
->
DotId
periodIdToDotId
::
P
erio
d
->
DotId
periodIdToDotId
prd
=
(
fromStrict
.
Text
.
pack
)
$
(
"period"
<>
show
(
fst
prd
)
<>
show
(
snd
prd
))
groupToTable
::
Vector
Ngrams
->
PhyloGroup
->
H
.
Label
...
...
@@ -220,9 +220,10 @@ exportToDot phylo export =
,(
toAttr
(
fromStrict
"phyloGroups"
)
$
pack
$
show
(
length
$
export
^.
export_groups
))
,(
toAttr
(
fromStrict
"phyloSources"
)
$
pack
$
show
(
Vector
.
toList
$
getSources
phylo
))
,(
toAttr
(
fromStrict
"phyloTimeScale"
)
$
pack
$
getTimeScale
phylo
)
,(
toAttr
(
fromStrict
"phyloLevel"
)
$
pack
$
show
(
_qua_granularity
$
phyloQuality
$
getConfig
phylo
))
,(
toAttr
(
fromStrict
"phyloSeaRiseStart"
)
$
pack
$
show
(
_cons_start
$
getSeaElevation
phylo
))
,(
toAttr
(
fromStrict
"phyloSeaRiseSteps"
)
$
pack
$
show
(
_cons_step
$
getSeaElevation
phylo
))
,(
toAttr
(
fromStrict
"PhyloScale"
)
$
pack
$
show
(
_qua_granularity
$
phyloQuality
$
getConfig
phylo
))
,(
toAttr
(
fromStrict
"phyloQuality"
)
$
pack
$
show
(
phylo
^.
phylo_quality
))
,(
toAttr
(
fromStrict
"phyloSeaRiseStart"
)
$
pack
$
show
(
getPhyloSeaRiseStart
phylo
))
,(
toAttr
(
fromStrict
"phyloSeaRiseSteps"
)
$
pack
$
show
(
getPhyloSeaRiseSteps
phylo
))
-- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
])
...
...
@@ -249,7 +250,7 @@ exportToDot phylo export =
_
<-
mapM
(
\
period
->
subgraph
((
Str
.
fromStrict
.
Text
.
pack
)
$
(
"Period"
<>
show
(
fst
$
_phylo_periodPeriod
period
)
<>
show
(
snd
$
_phylo_periodPeriod
period
)))
$
do
graphAttrs
[
Rank
SameRank
]
periodToDotNode
(
period
^.
phylo_periodPeriod
)
(
period
^.
phylo_periodPeriod
'
)
periodToDotNode
(
period
^.
phylo_periodPeriod
)
(
period
^.
phylo_periodPeriod
Str
)
{-- 6) create a node for each group -}
mapM
(
\
g
->
groupToDotNode
(
getRoots
phylo
)
g
(
toBid
g
(
export
^.
export_branches
)))
(
filter
(
\
g
->
g
^.
phylo_groupPeriod
==
(
period
^.
phylo_periodPeriod
))
$
export
^.
export_groups
)
...
...
@@ -372,9 +373,9 @@ sortByBirthDate order export =
processSort
::
Sort
->
SeaElevation
->
PhyloExport
->
PhyloExport
processSort
sort'
elev
export
=
case
sort'
of
ByBirthDate
o
->
sortByBirthDate
o
export
ByHierarchy
_
->
export
&
export_branches
.~
(
branchToIso'
(
_cons_start
elev
)
(
_cons_step
elev
)
$
sortByHierarchy
0
(
export
^.
export_branches
))
ByHierarchy
_
->
case
elev
of
Constante
s
s'
->
export
&
export_branches
.~
(
branchToIso'
s
s'
$
sortByHierarchy
0
(
export
^.
export_branches
))
Adaptative
_
->
export
&
export_branches
.~
(
branchToIso
$
sortByHierarchy
0
(
export
^.
export_branches
))
-----------------
-- | Metrics | --
...
...
@@ -545,9 +546,10 @@ processLabels labels foundations freq export =
-- | Dynamics | --
------------------
toDynamics
::
Int
->
[
PhyloGroup
]
->
PhyloGroup
->
Map
Int
(
Date
,
Date
)
->
Double
toDynamics
n
parents
g
m
=
-- utiliser & creer une Map FdtId [PhyloGroup]
-- n = index of the current term
toDynamics
::
FdtId
->
[
PhyloGroup
]
->
PhyloGroup
->
Map
FdtId
(
Date
,
Date
)
->
Double
toDynamics
n
elders
g
m
=
let
prd
=
g
^.
phylo_groupPeriod
end
=
last'
"dynamics"
(
sort
$
map
snd
$
elems
m
)
in
if
(((
snd
prd
)
==
(
snd
$
m
!
n
))
&&
(
snd
prd
/=
end
))
...
...
@@ -563,18 +565,18 @@ toDynamics n parents g m =
where
--------------------------------------
isNew
::
Bool
isNew
=
not
$
elem
n
$
concat
$
map
_phylo_groupNgrams
parents
isNew
=
not
$
elem
n
$
concat
$
map
_phylo_groupNgrams
elders
type
FdtId
=
Int
processDynamics
::
[
PhyloGroup
]
->
[
PhyloGroup
]
processDynamics
groups
=
map
(
\
g
->
let
parent
s
=
filter
(
\
g'
->
(
g
^.
phylo_groupBranchId
==
g'
^.
phylo_groupBranchId
)
let
elder
s
=
filter
(
\
g'
->
(
g
^.
phylo_groupBranchId
==
g'
^.
phylo_groupBranchId
)
&&
((
fst
$
g
^.
phylo_groupPeriod
)
>
(
fst
$
g'
^.
phylo_groupPeriod
)))
groups
in
g
&
phylo_groupMeta
%~
insert
"dynamics"
(
map
(
\
n
->
toDynamics
n
parent
s
g
mapNgrams
)
$
g
^.
phylo_groupNgrams
)
)
groups
in
g
&
phylo_groupMeta
%~
insert
"dynamics"
(
map
(
\
n
->
toDynamics
n
elder
s
g
mapNgrams
)
$
g
^.
phylo_groupNgrams
)
)
groups
where
--------------------------------------
mapNgrams
::
Map
Int
(
Date
,
Date
)
mapNgrams
::
Map
FdtId
(
Date
,
Date
)
mapNgrams
=
map
(
\
dates
->
let
dates'
=
sort
dates
in
(
head'
"dynamics"
dates'
,
last'
"dynamics"
dates'
))
...
...
@@ -615,28 +617,28 @@ headsToAncestors nbDocs diago proximity step heads acc =
toHorizon
::
Phylo
->
Phylo
toHorizon
phylo
=
let
phyloAncestor
=
updatePhyloGroups
level
scale
(
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
concat
$
tracePhyloAncestors
newGroups
)
phylo
reBranched
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
concat
$
groupsToBranches
$
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
getGroupsFromLevel
level
phyloAncestor
in
updatePhyloGroups
level
reBranched
phylo
$
groupsToBranches
'
$
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
getGroupsFromScale
scale
phyloAncestor
in
updatePhyloGroups
scale
reBranched
phylo
where
-- | 1) for each periods
periods
::
[
P
hyloPeriodI
d
]
periods
::
[
P
erio
d
]
periods
=
getPeriodIds
phylo
-- --
level
::
Level
level
=
getLastLevel
phylo
scale
::
Scale
scale
=
getLastLevel
phylo
-- --
frame
::
Int
frame
=
getTimeFrame
$
timeUnit
$
getConfig
phylo
-- | 2) find ancestors between groups without parents
mapGroups
::
[[
PhyloGroup
]]
mapGroups
=
map
(
\
prd
->
let
groups
=
getGroupsFrom
LevelPeriods
level
[
prd
]
phylo
childs
=
getPreviousChildIds
level
frame
prd
periods
phylo
let
groups
=
getGroupsFrom
ScalePeriods
scale
[
prd
]
phylo
childs
=
getPreviousChildIds
scale
frame
prd
periods
phylo
-- maybe add a better filter for non isolated ancestors
heads
=
filter
(
\
g
->
(
not
.
null
)
$
(
g
^.
phylo_groupPeriodChilds
))
$
filter
(
\
g
->
null
(
g
^.
phylo_groupPeriodParents
)
&&
(
notElem
(
getGroupId
g
)
childs
))
groups
...
...
@@ -646,7 +648,7 @@ toHorizon phylo =
proximity
=
(
phyloProximity
$
getConfig
phylo
)
step
=
case
getSeaElevation
phylo
of
Constante
_
s
->
s
Adaptative
_
->
undefined
Adaptative
_
->
0
-- in headsToAncestors nbDocs diago proximity heads groups []
in
map
(
\
ego
->
toAncestor
nbDocs
diago
proximity
step
noHeads
ego
)
$
headsToAncestors
nbDocs
diago
proximity
step
heads
[]
...
...
@@ -656,10 +658,10 @@ toHorizon phylo =
newGroups
=
mapGroups
`
using
`
parList
rdeepseq
--------------------------------------
getPreviousChildIds
::
Level
->
Int
->
PhyloPeriodId
->
[
PhyloPeriodI
d
]
->
Phylo
->
[
PhyloGroupId
]
getPreviousChildIds
::
Scale
->
Int
->
Period
->
[
Perio
d
]
->
Phylo
->
[
PhyloGroupId
]
getPreviousChildIds
lvl
frame
curr
prds
phylo
=
concat
$
map
((
map
fst
)
.
_phylo_groupPeriodChilds
)
$
getGroupsFrom
Level
Periods
lvl
(
getNextPeriods
ToParents
frame
curr
prds
)
phylo
$
getGroupsFrom
Scale
Periods
lvl
(
getNextPeriods
ToParents
frame
curr
prds
)
phylo
---------------------
-- | phyloExport | --
...
...
@@ -694,10 +696,10 @@ toPhyloExport phylo = exportToDot phylo
--------------------------------------
groups
::
[
PhyloGroup
]
groups
=
traceExportGroups
-- necessaire ?
$
processDynamics
$
getGroupsFrom
Level
(
phyloLevel
$
getConfig
phylo
)
$
getGroupsFrom
Scale
(
phyloScale
$
getConfig
phylo
)
$
tracePhyloInfo
phylo
-- \$ toHorizon phylo
traceExportBranches
::
[
PhyloBranch
]
->
[
PhyloBranch
]
...
...
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
5f77499e
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @
5f77499e
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
5f77499e
...
...
@@ -60,19 +60,19 @@ mergeGroups coocs id mapIds childs =
mergeAncestors
::
[
Pointer
]
->
[
Pointer
]
mergeAncestors
pointers
=
Map
.
toList
$
fromListWith
max
pointers
addPhylo
Level
::
Level
->
Phylo
->
Phylo
addPhylo
Level
lvl
phylo
=
addPhylo
Scale
::
Scale
->
Phylo
->
Phylo
addPhylo
Scale
lvl
phylo
=
over
(
phylo_periods
.
traverse
)
(
\
phyloPrd
->
phyloPrd
&
phylo_period
Level
s
(
\
phyloPrd
->
phyloPrd
&
phylo_period
Scale
s
%~
(
insert
(
phyloPrd
^.
phylo_periodPeriod
,
lvl
)
(
Phylo
Level
(
phyloPrd
^.
phylo_periodPeriod
)
(
phyloPrd
^.
phylo_periodPeriod'
)
lvl
empty
)))
phylo
(
Phylo
Scale
(
phyloPrd
^.
phylo_periodPeriod
)
(
phyloPrd
^.
phylo_periodPeriodStr
)
lvl
empty
)))
phylo
toNext
Level'
::
Phylo
->
[
PhyloGroup
]
->
Phylo
toNext
Level'
phylo
groups
=
toNext
Scale
::
Phylo
->
[
PhyloGroup
]
->
Phylo
toNext
Scale
phylo
groups
=
let
curLvl
=
getLastLevel
phylo
oldGroups
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
getLevelParentId
g
))
groups
newGroups
=
concat
$
groupsToBranches
newGroups
=
concat
$
groupsToBranches
'
$
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
foldlWithKey
(
\
acc
id
groups'
->
-- 4) create the parent group
...
...
@@ -83,17 +83,17 @@ toNextLevel' phylo groups =
newPeriods
=
fromListWith
(
++
)
$
map
(
\
g
->
(
g
^.
phylo_groupPeriod
,
[
g
]))
newGroups
in
traceSynchronyEnd
$
over
(
phylo_periods
.
traverse
.
phylo_period
Level
s
.
traverse
$
over
(
phylo_periods
.
traverse
.
phylo_period
Scale
s
.
traverse
-- 6) update each period at curLvl + 1
.
filtered
(
\
phyloLvl
->
phyloLvl
^.
phylo_
levelLevel
==
(
curLvl
+
1
)))
.
filtered
(
\
phyloLvl
->
phyloLvl
^.
phylo_
scaleScale
==
(
curLvl
+
1
)))
-- 7) by adding the parents
(
\
phyloLvl
->
if
member
(
phyloLvl
^.
phylo_
level
Period
)
newPeriods
then
phyloLvl
&
phylo_
level
Groups
.~
fromList
(
map
(
\
g
->
(
getGroupId
g
,
g
))
$
newPeriods
!
(
phyloLvl
^.
phylo_
level
Period
))
if
member
(
phyloLvl
^.
phylo_
scale
Period
)
newPeriods
then
phyloLvl
&
phylo_
scale
Groups
.~
fromList
(
map
(
\
g
->
(
getGroupId
g
,
g
))
$
newPeriods
!
(
phyloLvl
^.
phylo_
scale
Period
))
else
phyloLvl
)
-- 2) add the curLvl + 1
phyloLevel
to the phylo
$
addPhylo
Level
(
curLvl
+
1
)
-- 2) add the curLvl + 1
PhyloScale
to the phylo
$
addPhylo
Scale
(
curLvl
+
1
)
-- 1) update the current groups (with level parent pointers) in the phylo
$
updatePhyloGroups
curLvl
(
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
groups
)
phylo
...
...
@@ -140,17 +140,17 @@ groupsToEdges prox sync nbDocs diago groups =
toEdges
::
Double
->
[(
PhyloGroup
,
PhyloGroup
)]
->
[((
PhyloGroup
,
PhyloGroup
),
Double
)]
toEdges
sens
edges
=
case
prox
of
WeightedLogJaccard
_
->
map
(
\
(
g
,
g'
)
->
WeightedLogJaccard
_
_
->
map
(
\
(
g
,
g'
)
->
((
g
,
g'
),
weightedLogJaccard'
(
sens
)
nbDocs
diago
(
g
^.
phylo_groupNgrams
)
(
g'
^.
phylo_groupNgrams
)))
edges
WeightedLogSim
_
->
map
(
\
(
g
,
g'
)
->
WeightedLogSim
_
_
->
map
(
\
(
g
,
g'
)
->
((
g
,
g'
),
weightedLogJaccard'
(
1
/
sens
)
nbDocs
diago
(
g
^.
phylo_groupNgrams
)
(
g'
^.
phylo_groupNgrams
)))
edges
_
->
undefined
toParentId
::
PhyloGroup
->
PhyloGroupId
toParentId
child
=
((
child
^.
phylo_groupPeriod
,
child
^.
phylo_group
Level
+
1
),
child
^.
phylo_groupIndex
)
toParentId
child
=
((
child
^.
phylo_groupPeriod
,
child
^.
phylo_group
Scale
+
1
),
child
^.
phylo_groupIndex
)
reduceGroups
::
Proximity
->
Synchrony
->
Map
Date
Double
->
Map
Date
Cooc
->
[
PhyloGroup
]
->
[
PhyloGroup
]
...
...
@@ -159,6 +159,7 @@ reduceGroups prox sync docs diagos branch =
let
periods
=
fromListWith
(
++
)
$
map
(
\
g
->
(
g
^.
phylo_groupPeriod
,[
g
]))
branch
in
(
concat
.
concat
.
elems
)
-- TODO : ajouter un parallelisme
$
mapWithKey
(
\
prd
groups
->
-- 2) for each period, transform the groups as a proximity graph filtered by a threshold
let
diago
=
reduceDiagos
$
filterDiago
diagos
[
prd
]
...
...
@@ -166,17 +167,17 @@ reduceGroups prox sync docs diagos branch =
in
map
(
\
comp
->
-- 4) add to each groups their futur level parent group
let
parentId
=
toParentId
(
head'
"parentId"
comp
)
in
map
(
\
g
->
g
&
phylo_group
Level
Parents
%~
(
++
[(
parentId
,
1
)])
)
comp
)
in
map
(
\
g
->
g
&
phylo_group
Scale
Parents
%~
(
++
[(
parentId
,
1
)])
)
comp
)
-- 3) reduce the graph a a set of related components
$
toRelatedComponents
groups
edges
)
periods
adjustClustering
::
Synchrony
->
[[
PhyloGroup
]]
->
[[
PhyloGroup
]]
adjustClustering
sync
branches
=
case
sync
of
chooseClusteringStrategy
::
Synchrony
->
[[
PhyloGroup
]]
->
[[
PhyloGroup
]]
chooseClusteringStrategy
sync
branches
=
case
sync
of
ByProximityThreshold
_
_
scope
_
->
case
scope
of
SingleBranch
->
branches
SiblingBranches
->
groupBy
(
\
g
g'
->
(
last'
"
adjustClustering
"
$
(
g
^.
phylo_groupMeta
)
!
"breaks"
)
==
(
last'
"
adjustClustering
"
$
(
g'
^.
phylo_groupMeta
)
!
"breaks"
))
SiblingBranches
->
groupBy
(
\
g
g'
->
(
last'
"
chooseClusteringStrategy
"
$
(
g
^.
phylo_groupMeta
)
!
"breaks"
)
==
(
last'
"
chooseClusteringStrategy
"
$
(
g'
^.
phylo_groupMeta
)
!
"breaks"
))
$
sortOn
_phylo_groupBranchId
$
concat
branches
AllBranches
->
[
concat
branches
]
ByProximityDistribution
_
_
->
branches
...
...
@@ -185,7 +186,7 @@ adjustClustering sync branches = case sync of
levelUpAncestors
::
[
PhyloGroup
]
->
[
PhyloGroup
]
levelUpAncestors
groups
=
-- 1) create an associative map of (old,new) ids
let
ids'
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
fst
$
head'
"levelUpAncestors"
(
g
^.
phylo_group
Level
Parents
)))
groups
let
ids'
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
fst
$
head'
"levelUpAncestors"
(
g
^.
phylo_group
Scale
Parents
)))
groups
in
map
(
\
g
->
let
id'
=
ids'
!
(
getGroupId
g
)
ancestors
=
g
^.
phylo_groupAncestors
...
...
@@ -202,11 +203,11 @@ synchronicClustering phylo =
diagos
=
map
coocToDiago
$
phylo
^.
phylo_timeCooc
newBranches
=
map
(
\
branch
->
reduceGroups
prox
sync
docs
diagos
branch
)
$
map
processDynamics
$
adjustClustering
sync
$
phylo
ToLastBranches
$
chooseClusteringStrategy
sync
$
phylo
LastScale
$
traceSynchronyStart
phylo
newBranches'
=
newBranches
`
using
`
parList
rdeepseq
in
toNext
Level'
phylo
$
levelUpAncestors
$
concat
newBranches'
in
toNext
Scale
phylo
$
levelUpAncestors
$
concat
newBranches'
-- synchronicDistance :: Phylo -> Level -> String
...
...
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @
5f77499e
This diff is collapsed.
Click to expand it.
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