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
160
Issues
160
List
Board
Labels
Milestones
Merge Requests
14
Merge Requests
14
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
4b742e1f
Commit
4b742e1f
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
a60a1be7
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 @
4b742e1f
...
...
@@ -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 @
4b742e1f
...
...
@@ -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 @
4b742e1f
...
...
@@ -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 @
4b742e1f
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
4b742e1f
...
...
@@ -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 @
4b742e1f
...
...
@@ -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