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
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
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
Christian Merten
haskell-gargantext
Commits
259b905e
Commit
259b905e
authored
Jan 30, 2024
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Revert "wip - disable debug logs for Phylo code"
This reverts commit
a60a1be7
.
parent
0b73cd17
Changes
6
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
65 additions
and
192 deletions
+65
-192
Main.hs
bench/Main.hs
+1
-1
Example.hs
src/Gargantext/Core/Viz/Phylo/Example.hs
+2
-5
PhyloMaker.hs
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
+6
-26
PhyloTools.hs
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
+45
-149
SynchronicClustering.hs
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
+7
-7
TemporalMatching.hs
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
+4
-4
No files found.
bench/Main.hs
View file @
259b905e
...
...
@@ -49,7 +49,7 @@ main = do
whnfIO
(
toUserHash
$
NewUser
"alfredo"
"alfredo@well-typed.com"
(
GargPassword
"rabbit"
))
]
,
bgroup
"Phylo"
[
bench
"toPhylo (small)"
$
nf
(
toPhyloWithOptions
(
ToPhyloOptions
False
)
issue290PhyloSmall
bench
"toPhylo (small)"
$
nf
toPhylo
issue290PhyloSmall
]
]
]
src/Gargantext/Core/Viz/Phylo/Example.hs
View file @
259b905e
...
...
@@ -41,22 +41,19 @@ phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot"
phyloDot
::
DotGraph
DotId
phyloDot
=
toPhyloExport
phyloCleopatre
phyloOpts
::
ToPhyloOptions
phyloOpts
=
ToPhyloOptions
True
-- enable debug logs
--------------------------------------------------
-- | STEP 4 | -- Process the synchronic clustering
--------------------------------------------------
phyloCleopatre
::
Phylo
phyloCleopatre
=
synchronicClustering
phyloOpts
$
toHorizon
flatPhylo
phyloCleopatre
=
synchronicClustering
$
toHorizon
flatPhylo
-----------------------------------------------
-- | STEP 3 | -- Build the Level 1 of the Phylo
-----------------------------------------------
flatPhylo
::
Phylo
flatPhylo
=
temporalMatching
phyloOpts
(
getLadder
emptyPhylo'
)
emptyPhylo'
flatPhylo
=
temporalMatching
(
getLadder
emptyPhylo'
)
emptyPhylo'
emptyPhylo'
::
Phylo
emptyPhylo'
=
joinRoots
...
...
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
259b905e
...
...
@@ -11,21 +11,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhyloWithOptions
,
toPhyloWithoutLink
,
appendGroups
,
clusterToGroup
,
docsToTimeScaleCooc
,
docsToTimeScaleNb
,
findSeaLadder
,
groupDocsByPeriod
,
initPhylo
,
joinRoots
,
toSeriesOfClustering
)
where
module
Gargantext.Core.Viz.Phylo.PhyloMaker
where
import
Control.Lens
hiding
(
Level
)
...
...
@@ -57,23 +43,17 @@ data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
| PhyloN { _phylo'_flatPhylo :: Phylo}
toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
toPhylo' (PhyloN phylo) = toPhylo'
toPhylo' (PhyloBase phylo) = toPhylo
-}
toPhylo
::
Phylo
->
Phylo
toPhylo
=
toPhyloWithOptions
(
ToPhyloOptions
True
)
-- TODO an adaptative synchronic clustering with a slider
-- FIXME(adn) Currently we emit traces from pure code(!!). This is obviously not very nice
-- and it breaks referencial transparency; we ought to fix it, but in order to smooth out
-- the compatibility story, for now we keep the status quo.
toPhyloWithOptions
::
ToPhyloOptions
->
Phylo
->
Phylo
toPhyloWithOptions
phyloOpts
phylowithoutLink
=
traceToPhylo
phyloOpts
(
phyloScale
$
getConfig
phylowithoutLink
)
$
toPhylo
::
Phylo
->
Phylo
toPhylo
phylowithoutLink
=
traceToPhylo
(
phyloScale
$
getConfig
phylowithoutLink
)
$
if
(
phyloScale
$
getConfig
phylowithoutLink
)
>
1
then
foldl'
(
\
phylo'
_
->
synchronicClustering
phylo
Opts
phylo
'
)
phyloAncestors
[
2
..
(
phyloScale
$
getConfig
phylowithoutLink
)]
then
foldl'
(
\
phylo'
_
->
synchronicClustering
phylo'
)
phyloAncestors
[
2
..
(
phyloScale
$
getConfig
phylowithoutLink
)]
else
phyloAncestors
where
--------------------------------------
...
...
@@ -84,7 +64,7 @@ toPhyloWithOptions phyloOpts phylowithoutLink = traceToPhylo phyloOpts (phyloSca
else
phyloWithLinks
--------------------------------------
phyloWithLinks
::
Phylo
phyloWithLinks
=
temporalMatching
phyloOpts
(
getLadder
phylowithoutLink
)
phylowithoutLink
phyloWithLinks
=
temporalMatching
(
getLadder
phylowithoutLink
)
phylowithoutLink
--------------------------------------
...
...
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @
259b905e
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
259b905e
...
...
@@ -72,8 +72,8 @@ addPhyloScale lvl phylo =
(
PhyloScale
(
phyloPrd
^.
phylo_periodPeriod
)
(
phyloPrd
^.
phylo_periodPeriodStr
)
lvl
empty
)))
phylo
toNextScale
::
ToPhyloOptions
->
Phylo
->
[
PhyloGroup
]
->
Phylo
toNextScale
opts
phylo
groups
=
toNextScale
::
Phylo
->
[
PhyloGroup
]
->
Phylo
toNextScale
phylo
groups
=
let
curLvl
=
getLastLevel
phylo
oldGroups
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
getLevelParentId
g
))
groups
newGroups
=
concat
$
groupsToBranches'
...
...
@@ -86,7 +86,7 @@ toNextScale opts phylo groups =
$
fromListWith
(
++
)
$
map
(
\
g
->
(
getLevelParentId
g
,
[
g
]))
groups
newPeriods
=
fromListWith
(
++
)
$
map
(
\
g
->
(
g
^.
phylo_groupPeriod
,
[
g
]))
newGroups
in
traceSynchronyEnd
opts
in
traceSynchronyEnd
$
over
(
phylo_periods
.
traverse
.
phylo_periodScales
.
traverse
-- 6) update each period at curLvl + 1
.
filtered
(
\
phyloLvl
->
phyloLvl
^.
phylo_scaleScale
==
(
curLvl
+
1
)))
...
...
@@ -205,8 +205,8 @@ levelUpAncestors groups =
in
g
&
phylo_groupAncestors
.~
ancestors'
)
groups
synchronicClustering
::
ToPhyloOptions
->
Phylo
->
Phylo
synchronicClustering
opts
phylo
=
synchronicClustering
::
Phylo
->
Phylo
synchronicClustering
phylo
=
let
prox
=
similarity
$
getConfig
phylo
sync
=
phyloSynchrony
$
getConfig
phylo
docs
=
getDocsByDate
phylo
...
...
@@ -215,9 +215,9 @@ synchronicClustering opts phylo =
$
map
processDynamics
$
chooseClusteringStrategy
sync
$
phyloLastScale
$
traceSynchronyStart
opts
phylo
$
traceSynchronyStart
phylo
newBranches'
=
newBranches
`
using
`
parList
rdeepseq
in
toNextScale
opts
phylo
$
levelUpAncestors
$
concat
newBranches'
in
toNextScale
phylo
$
levelUpAncestors
$
concat
newBranches'
-- synchronicDistance :: Phylo -> Level -> String
...
...
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @
259b905e
...
...
@@ -679,9 +679,9 @@ seaLevelRise fdt similarity lambda minBranch frequency ladder rise frame periods
{-
-- start the temporal matching process up, recover the resulting branches and update the groups (at scale 1) consequently
-}
temporalMatching
::
ToPhyloOptions
->
[
Double
]
->
Phylo
->
Phylo
temporalMatching
opts
ladder
phylo
=
updatePhyloGroups
1
(
Map
.
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
traceMatchEnd
opts
$
concat
branches
)
temporalMatching
::
[
Double
]
->
Phylo
->
Phylo
temporalMatching
ladder
phylo
=
updatePhyloGroups
1
(
Map
.
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
traceMatchEnd
$
concat
branches
)
(
updateQuality
quality
phylo
)
where
-------
...
...
@@ -718,4 +718,4 @@ temporalMatching opts ladder phylo = updatePhyloGroups 1
(
getDocsByDate
phylo
)
(
getCoocByDate
phylo
)
((
phylo
^.
phylo_foundations
)
^.
foundations_rootsInGroups
)
(
traceTemporalMatching
opts
$
getGroupsFromScale
1
phylo
)
(
traceTemporalMatching
$
getGroupsFromScale
1
phylo
)
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