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
119
Issues
119
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
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
bf864cb7
Commit
bf864cb7
authored
Jun 27, 2023
by
qlobbe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
fix the invalid chart
parent
8ab26486
Pipeline
#4293
failed with stages
in 40 minutes and 16 seconds
Changes
2
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
6 additions
and
39 deletions
+6
-39
PhyloExport.hs
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
+2
-36
SynchronicClustering.hs
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
+4
-3
No files found.
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @
bf864cb7
...
...
@@ -28,7 +28,6 @@ import Gargantext.Core.Viz.Phylo.PhyloTools
import
Gargantext.Core.Viz.Phylo.TemporalMatching
(
filterDocs
,
filterDiago
,
reduceDiagos
,
toSimilarity
,
getNextPeriods
)
import
Gargantext.Prelude
hiding
(
scale
)
import
Prelude
(
writeFile
)
import
Protolude
(
floor
)
import
System.FilePath
import
qualified
Data.GraphViz.Attributes.HTML
as
H
import
qualified
Data.Text
as
Text
...
...
@@ -78,37 +77,6 @@ branchIdToDotId bId = (fromStrict . Text.pack) $ "branch" <> show (snd bId)
periodIdToDotId
::
Period
->
DotId
periodIdToDotId
prd
=
(
fromStrict
.
Text
.
pack
)
$
"period"
<>
show
(
fst
prd
)
<>
show
(
snd
prd
)
groupToTable
::
Vector
Ngrams
->
PhyloGroup
->
H
.
Label
groupToTable
fdt
g
=
H
.
Table
H
.
HTable
{
H
.
tableFontAttrs
=
Just
[
H
.
PointSize
14
,
H
.
Align
H
.
HLeft
]
,
H
.
tableAttrs
=
[
H
.
Border
0
,
H
.
CellBorder
0
,
H
.
BGColor
(
toColor
White
)]
,
H
.
tableRows
=
[
header
]
<>
[
H
.
Cells
[
H
.
LabelCell
[
H
.
Height
10
]
$
H
.
Text
[
H
.
Str
$
fromStrict
""
]]]
<>
(
map
ngramsToRow
$
splitEvery
4
$
reverse
$
sortOn
(
snd
.
snd
)
$
zip
(
ngramsToText
fdt
(
g
^.
phylo_groupNgrams
))
$
zip
((
g
^.
phylo_groupMeta
)
!
"dynamics"
)
((
g
^.
phylo_groupMeta
)
!
"inclusion"
))}
where
--------------------------------------
ngramsToRow
::
[(
Ngrams
,
(
Double
,
Double
))]
->
H
.
Row
ngramsToRow
ns
=
H
.
Cells
$
map
(
\
(
n
,
(
d
,
_
))
->
H
.
LabelCell
[
H
.
Align
H
.
HLeft
,
dynamicToColor
$
floor
d
]
$
H
.
Text
[
H
.
Str
$
fromStrict
n
])
ns
--------------------------------------
header
::
H
.
Row
header
=
H
.
Cells
[
H
.
LabelCell
[
pickLabelColor
$
floor
<$>
((
g
^.
phylo_groupMeta
)
!
"dynamics"
)]
$
H
.
Text
[
H
.
Str
$
((
fromStrict
.
Text
.
toUpper
)
$
g
^.
phylo_groupLabel
)
<>
fromStrict
" ( "
<>
(
pack
$
show
(
fst
$
g
^.
phylo_groupPeriod
))
<>
fromStrict
" , "
<>
(
pack
$
show
(
snd
$
g
^.
phylo_groupPeriod
))
<>
fromStrict
" ) "
<>
(
pack
$
show
(
getGroupId
g
))]]
--------------------------------------
branchToDotNode
::
PhyloBranch
->
Int
->
Dot
DotId
branchToDotNode
b
bId
=
node
(
branchIdToDotId
$
b
^.
branch_id
)
...
...
@@ -116,8 +84,7 @@ branchToDotNode b bId =
,
FontName
"Arial"
,
FontSize
40
,
Shape
Egg
,
Style
[
SItem
Bold
[]
]
,
Label
(
toDotLabel
$
b
^.
branch_label
)
]
,
Style
[
SItem
Bold
[]
]
]
<>
(
metaToAttr
$
b
^.
branch_meta
)
<>
[
toAttr
"nodeType"
"branch"
,
toAttr
"bId"
(
pack
$
show
bId
)
...
...
@@ -143,8 +110,7 @@ periodToDotNode prd prd' =
groupToDotNode
::
Vector
Ngrams
->
PhyloGroup
->
Int
->
Dot
DotId
groupToDotNode
fdt
g
bId
=
node
(
groupIdToDotId
$
getGroupId
g
)
([
FontName
"Arial"
,
Shape
Square
,
penWidth
4
,
toLabel
(
groupToTable
fdt
g
)]
<>
[
toAttr
"nodeType"
"group"
([
toAttr
"nodeType"
"group"
,
toAttr
"gid"
(
groupIdToDotId
$
getGroupId
g
)
,
toAttr
"from"
(
pack
$
show
(
fst
$
g
^.
phylo_groupPeriod
))
,
toAttr
"to"
(
pack
$
show
(
snd
$
g
^.
phylo_groupPeriod
))
...
...
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
bf864cb7
...
...
@@ -22,6 +22,7 @@ import Gargantext.Core.Viz.Phylo.PhyloExport (processDynamics)
import
Gargantext.Core.Viz.Phylo.PhyloTools
import
Gargantext.Core.Viz.Phylo.TemporalMatching
(
weightedLogJaccard'
,
filterDiago
,
reduceDiagos
)
import
Gargantext.Prelude
-- import Debug.Trace (trace)
import
qualified
Data.Map
as
Map
...
...
@@ -175,13 +176,13 @@ reduceGroups prox sync docs diagos branch =
$
unionWith
(
\
v1
v2
->
if
v1
>=
v2
then
v1
else
v2
)
edgesLeft
edgesRight
-- 3) reduce the graph a a set of related components
clusters
=
toRelatedComponents
groups
mergedEdges
in
map
(
\
comp
->
-- 4) add to each groups their futur level parent group
let
parentId
=
toParentId
(
head'
"parentId"
comp
)
in
map
(
\
g
->
g
&
phylo_groupScaleParents
%~
(
++
[(
parentId
,
1
)])
)
comp
)
-- 3) reduce the graph a a set of related components
$
toRelatedComponents
groups
mergedEdges
)
periods
$
clusters
)
periods
chooseClusteringStrategy
::
Synchrony
->
[[
PhyloGroup
]]
->
[[
PhyloGroup
]]
chooseClusteringStrategy
sync
branches
=
case
sync
of
...
...
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