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
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
...
@@ -49,7 +49,7 @@ main = do
whnfIO
(
toUserHash
$
NewUser
"alfredo"
"alfredo@well-typed.com"
(
GargPassword
"rabbit"
))
whnfIO
(
toUserHash
$
NewUser
"alfredo"
"alfredo@well-typed.com"
(
GargPassword
"rabbit"
))
]
]
,
bgroup
"Phylo"
[
,
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"
...
@@ -41,22 +41,19 @@ phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot"
phyloDot
::
DotGraph
DotId
phyloDot
::
DotGraph
DotId
phyloDot
=
toPhyloExport
phyloCleopatre
phyloDot
=
toPhyloExport
phyloCleopatre
phyloOpts
::
ToPhyloOptions
phyloOpts
=
ToPhyloOptions
True
-- enable debug logs
--------------------------------------------------
--------------------------------------------------
-- | STEP 4 | -- Process the synchronic clustering
-- | STEP 4 | -- Process the synchronic clustering
--------------------------------------------------
--------------------------------------------------
phyloCleopatre
::
Phylo
phyloCleopatre
::
Phylo
phyloCleopatre
=
synchronicClustering
phyloOpts
$
toHorizon
flatPhylo
phyloCleopatre
=
synchronicClustering
$
toHorizon
flatPhylo
-----------------------------------------------
-----------------------------------------------
-- | STEP 3 | -- Build the Level 1 of the Phylo
-- | STEP 3 | -- Build the Level 1 of the Phylo
-----------------------------------------------
-----------------------------------------------
flatPhylo
::
Phylo
flatPhylo
::
Phylo
flatPhylo
=
temporalMatching
phyloOpts
(
getLadder
emptyPhylo'
)
emptyPhylo'
flatPhylo
=
temporalMatching
(
getLadder
emptyPhylo'
)
emptyPhylo'
emptyPhylo'
::
Phylo
emptyPhylo'
::
Phylo
emptyPhylo'
=
joinRoots
emptyPhylo'
=
joinRoots
...
...
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
259b905e
...
@@ -11,21 +11,7 @@ Portability : POSIX
...
@@ -11,21 +11,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module
Gargantext.Core.Viz.Phylo.PhyloMaker
(
module
Gargantext.Core.Viz.Phylo.PhyloMaker
where
toPhylo
,
toPhyloWithOptions
,
toPhyloWithoutLink
,
appendGroups
,
clusterToGroup
,
docsToTimeScaleCooc
,
docsToTimeScaleNb
,
findSeaLadder
,
groupDocsByPeriod
,
initPhylo
,
joinRoots
,
toSeriesOfClustering
)
where
import
Control.Lens
hiding
(
Level
)
import
Control.Lens
hiding
(
Level
)
...
@@ -57,23 +43,17 @@ data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
...
@@ -57,23 +43,17 @@ data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
| PhyloN { _phylo'_flatPhylo :: Phylo}
| PhyloN { _phylo'_flatPhylo :: Phylo}
toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
toPhylo' (PhyloN phylo) = toPhylo'
toPhylo' (PhyloN phylo) = toPhylo'
toPhylo' (PhyloBase phylo) = toPhylo
toPhylo' (PhyloBase phylo) = toPhylo
-}
-}
toPhylo
::
Phylo
->
Phylo
toPhylo
=
toPhyloWithOptions
(
ToPhyloOptions
True
)
-- TODO an adaptative synchronic clustering with a slider
-- 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
toPhylo
::
Phylo
->
Phylo
-- the compatibility story, for now we keep the status quo.
toPhylo
phylowithoutLink
=
traceToPhylo
(
phyloScale
$
getConfig
phylowithoutLink
)
$
toPhyloWithOptions
::
ToPhyloOptions
->
Phylo
->
Phylo
toPhyloWithOptions
phyloOpts
phylowithoutLink
=
traceToPhylo
phyloOpts
(
phyloScale
$
getConfig
phylowithoutLink
)
$
if
(
phyloScale
$
getConfig
phylowithoutLink
)
>
1
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
else
phyloAncestors
where
where
--------------------------------------
--------------------------------------
...
@@ -84,7 +64,7 @@ toPhyloWithOptions phyloOpts phylowithoutLink = traceToPhylo phyloOpts (phyloSca
...
@@ -84,7 +64,7 @@ toPhyloWithOptions phyloOpts phylowithoutLink = traceToPhylo phyloOpts (phyloSca
else
phyloWithLinks
else
phyloWithLinks
--------------------------------------
--------------------------------------
phyloWithLinks
::
Phylo
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 =
...
@@ -72,8 +72,8 @@ addPhyloScale lvl phylo =
(
PhyloScale
(
phyloPrd
^.
phylo_periodPeriod
)
(
phyloPrd
^.
phylo_periodPeriodStr
)
lvl
empty
)))
phylo
(
PhyloScale
(
phyloPrd
^.
phylo_periodPeriod
)
(
phyloPrd
^.
phylo_periodPeriodStr
)
lvl
empty
)))
phylo
toNextScale
::
ToPhyloOptions
->
Phylo
->
[
PhyloGroup
]
->
Phylo
toNextScale
::
Phylo
->
[
PhyloGroup
]
->
Phylo
toNextScale
opts
phylo
groups
=
toNextScale
phylo
groups
=
let
curLvl
=
getLastLevel
phylo
let
curLvl
=
getLastLevel
phylo
oldGroups
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
getLevelParentId
g
))
groups
oldGroups
=
fromList
$
map
(
\
g
->
(
getGroupId
g
,
getLevelParentId
g
))
groups
newGroups
=
concat
$
groupsToBranches'
newGroups
=
concat
$
groupsToBranches'
...
@@ -86,7 +86,7 @@ toNextScale opts phylo groups =
...
@@ -86,7 +86,7 @@ toNextScale opts phylo groups =
$
fromListWith
(
++
)
$
map
(
\
g
->
(
getLevelParentId
g
,
[
g
]))
groups
$
fromListWith
(
++
)
$
map
(
\
g
->
(
getLevelParentId
g
,
[
g
]))
groups
newPeriods
=
fromListWith
(
++
)
$
map
(
\
g
->
(
g
^.
phylo_groupPeriod
,
[
g
]))
newGroups
newPeriods
=
fromListWith
(
++
)
$
map
(
\
g
->
(
g
^.
phylo_groupPeriod
,
[
g
]))
newGroups
in
traceSynchronyEnd
opts
in
traceSynchronyEnd
$
over
(
phylo_periods
.
traverse
.
phylo_periodScales
.
traverse
$
over
(
phylo_periods
.
traverse
.
phylo_periodScales
.
traverse
-- 6) update each period at curLvl + 1
-- 6) update each period at curLvl + 1
.
filtered
(
\
phyloLvl
->
phyloLvl
^.
phylo_scaleScale
==
(
curLvl
+
1
)))
.
filtered
(
\
phyloLvl
->
phyloLvl
^.
phylo_scaleScale
==
(
curLvl
+
1
)))
...
@@ -205,8 +205,8 @@ levelUpAncestors groups =
...
@@ -205,8 +205,8 @@ levelUpAncestors groups =
in
g
&
phylo_groupAncestors
.~
ancestors'
in
g
&
phylo_groupAncestors
.~
ancestors'
)
groups
)
groups
synchronicClustering
::
ToPhyloOptions
->
Phylo
->
Phylo
synchronicClustering
::
Phylo
->
Phylo
synchronicClustering
opts
phylo
=
synchronicClustering
phylo
=
let
prox
=
similarity
$
getConfig
phylo
let
prox
=
similarity
$
getConfig
phylo
sync
=
phyloSynchrony
$
getConfig
phylo
sync
=
phyloSynchrony
$
getConfig
phylo
docs
=
getDocsByDate
phylo
docs
=
getDocsByDate
phylo
...
@@ -215,9 +215,9 @@ synchronicClustering opts phylo =
...
@@ -215,9 +215,9 @@ synchronicClustering opts phylo =
$
map
processDynamics
$
map
processDynamics
$
chooseClusteringStrategy
sync
$
chooseClusteringStrategy
sync
$
phyloLastScale
$
phyloLastScale
$
traceSynchronyStart
opts
phylo
$
traceSynchronyStart
phylo
newBranches'
=
newBranches
`
using
`
parList
rdeepseq
newBranches'
=
newBranches
`
using
`
parList
rdeepseq
in
toNextScale
opts
phylo
$
levelUpAncestors
$
concat
newBranches'
in
toNextScale
phylo
$
levelUpAncestors
$
concat
newBranches'
-- synchronicDistance :: Phylo -> Level -> String
-- 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
...
@@ -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
-- start the temporal matching process up, recover the resulting branches and update the groups (at scale 1) consequently
-}
-}
temporalMatching
::
ToPhyloOptions
->
[
Double
]
->
Phylo
->
Phylo
temporalMatching
::
[
Double
]
->
Phylo
->
Phylo
temporalMatching
opts
ladder
phylo
=
updatePhyloGroups
1
temporalMatching
ladder
phylo
=
updatePhyloGroups
1
(
Map
.
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
traceMatchEnd
opts
$
concat
branches
)
(
Map
.
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
$
traceMatchEnd
$
concat
branches
)
(
updateQuality
quality
phylo
)
(
updateQuality
quality
phylo
)
where
where
-------
-------
...
@@ -718,4 +718,4 @@ temporalMatching opts ladder phylo = updatePhyloGroups 1
...
@@ -718,4 +718,4 @@ temporalMatching opts ladder phylo = updatePhyloGroups 1
(
getDocsByDate
phylo
)
(
getDocsByDate
phylo
)
(
getCoocByDate
phylo
)
(
getCoocByDate
phylo
)
((
phylo
^.
phylo_foundations
)
^.
foundations_rootsInGroups
)
((
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