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
154
Issues
154
List
Board
Labels
Milestones
Merge Requests
9
Merge Requests
9
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
053fa8bc
Commit
053fa8bc
authored
3 years ago
by
qlobbe
Committed by
Alexandre Delanoë
3 years ago
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
changes done
parent
7a6ec685
Changes
4
Show whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
41 additions
and
3 deletions
+41
-3
PhyloExport.hs
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
+24
-0
PhyloMaker.hs
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
+1
-1
SynchronicClustering.hs
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
+4
-0
TemporalMatching.hs
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
+12
-2
No files found.
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @
053fa8bc
...
...
@@ -146,13 +146,26 @@ groupToDotNode fdt g bId =
,
toAttr
"foundation"
(
pack
$
show
(
idxToLabel
(
g
^.
phylo_groupNgrams
)))
,
toAttr
"role"
(
pack
$
show
(
idxToLabel'
((
g
^.
phylo_groupMeta
)
!
"dynamics"
)))
,
toAttr
"frequence"
(
pack
$
show
(
idxToLabel'
((
g
^.
phylo_groupMeta
)
!
"frequence"
)))
,
toAttr
"seaLvl"
(
pack
$
show
((
g
^.
phylo_groupMeta
)
!
"seaLevels"
))
])
toDotEdge'
::
DotId
->
DotId
->
[
Char
]
->
[
Char
]
->
EdgeType
->
Dot
DotId
toDotEdge'
source
target
thr
w
edgeType
=
edge
source
target
(
case
edgeType
of
GroupToGroup
->
undefined
GroupToGroupMemory
->
[
Width
3
,
penWidth
4
,
Color
[
toWColor
Black
],
Constraint
True
]
<>
[
toAttr
"edgeType"
"memoryLink"
,
toAttr
"thr"
(
pack
thr
),
toAttr
"weight"
(
pack
w
)]
BranchToGroup
->
undefined
BranchToBranch
->
undefined
GroupToAncestor
->
undefined
PeriodToPeriod
->
undefined
)
toDotEdge
::
DotId
->
DotId
->
[
Char
]
->
EdgeType
->
Dot
DotId
toDotEdge
source
target
lbl
edgeType
=
edge
source
target
(
case
edgeType
of
GroupToGroup
->
[
Width
3
,
penWidth
4
,
Color
[
toWColor
Black
],
Constraint
True
]
<>
[
toAttr
"edgeType"
"link"
,
toAttr
"lbl"
(
pack
lbl
)]
GroupToGroupMemory
->
undefined
BranchToGroup
->
[
Width
3
,
Color
[
toWColor
Black
],
ArrowHead
(
AType
[(
ArrMod
FilledArrow
RightSide
,
DotArrow
)])]
<>
[
toAttr
"edgeType"
"branchLink"
]
BranchToBranch
->
[
Width
2
,
Color
[
toWColor
Black
],
Style
[
SItem
Dashed
[]
],
ArrowHead
(
AType
[(
ArrMod
FilledArrow
BothSides
,
DotArrow
)])]
GroupToAncestor
->
[
Width
3
,
Color
[
toWColor
Red
],
Style
[
SItem
Dashed
[]
],
ArrowHead
(
AType
[(
ArrMod
FilledArrow
BothSides
,
NoArrow
)]),
PenWidth
4
]
<>
[
toAttr
"edgeType"
"ancestorLink"
,
toAttr
"lbl"
(
pack
lbl
)]
...
...
@@ -165,6 +178,12 @@ mergePointers groups =
toParents
=
fromList
$
concat
$
map
(
\
g
->
map
(
\
(
target
,
w
)
->
((
target
,
getGroupId
g
),
w
))
$
g
^.
phylo_groupPeriodParents
)
groups
in
unionWith
(
\
w
w'
->
max
w
w'
)
toChilds
toParents
mergePointersMemory
::
[
PhyloGroup
]
->
[((
PhyloGroupId
,
PhyloGroupId
),(
Double
,
Double
))]
mergePointersMemory
groups
=
let
toChilds
=
concat
$
map
(
\
g
->
map
(
\
(
target
,(
t
,
w
))
->
((
getGroupId
g
,
target
),(
t
,
w
)))
$
g
^.
phylo_groupPeriodMemoryChilds
)
groups
toParents
=
concat
$
map
(
\
g
->
map
(
\
(
target
,(
t
,
w
))
->
((
target
,
getGroupId
g
),(
t
,
w
)))
$
g
^.
phylo_groupPeriodMemoryParents
)
groups
in
concat
[
toChilds
,
toParents
]
mergeAncestors
::
[
PhyloGroup
]
->
[((
PhyloGroupId
,
PhyloGroupId
),
Double
)]
mergeAncestors
groups
=
concat
$
map
(
\
g
->
map
(
\
(
target
,
w
)
->
((
getGroupId
g
,
target
),
w
))
$
g
^.
phylo_groupAncestors
)
...
...
@@ -245,6 +264,11 @@ exportToDot phylo export =
toDotEdge
(
groupIdToDotId
k
)
(
groupIdToDotId
k'
)
(
show
v
)
GroupToGroup
)
$
(
toList
.
mergePointers
)
$
export
^.
export_groups
{- 8-bis) create the edges between the groups -}
_
<-
mapM
(
\
((
k
,
k'
),
v
)
->
toDotEdge'
(
groupIdToDotId
k
)
(
groupIdToDotId
k'
)
(
show
(
fst
v
))
(
show
(
snd
v
))
GroupToGroupMemory
)
$
mergePointersMemory
$
export
^.
export_groups
_
<-
mapM
(
\
((
k
,
k'
),
v
)
->
toDotEdge
(
groupIdToDotId
k
)
(
groupIdToDotId
k'
)
(
show
v
)
GroupToAncestor
)
$
mergeAncestors
$
export
^.
export_groups
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
053fa8bc
...
...
@@ -135,7 +135,7 @@ cliqueToGroup fis pId pId' lvl idx coocs = PhyloGroup pId pId' lvl idx ""
(
ngramsToCooc
(
fis
^.
phyloClique_nodes
)
coocs
)
(
1
,[
0
])
-- branchid (lvl,[path in the branching tree])
(
fromList
[(
"breaks"
,[
0
]),(
"seaLevels"
,[
0
])])
[]
[]
[]
[]
[]
[]
[]
[]
[]
[]
[]
[]
toPhylo1
::
Phylo
->
Phylo
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
053fa8bc
...
...
@@ -45,6 +45,8 @@ mergeGroups coocs id mapIds childs =
(
updatePointers
$
concat
$
map
_phylo_groupPeriodParents
childs
)
(
updatePointers
$
concat
$
map
_phylo_groupPeriodChilds
childs
)
(
mergeAncestors
$
concat
$
map
_phylo_groupAncestors
childs
)
(
updatePointers'
$
concat
$
map
_phylo_groupPeriodMemoryParents
childs
)
(
updatePointers'
$
concat
$
map
_phylo_groupPeriodMemoryChilds
childs
)
where
--------------------
bId
::
[
Int
]
...
...
@@ -52,6 +54,8 @@ mergeGroups coocs id mapIds childs =
--------------------
updatePointers
::
[
Pointer
]
->
[
Pointer
]
updatePointers
pointers
=
map
(
\
(
pId
,
w
)
->
(
mapIds
!
pId
,
w
))
pointers
updatePointers'
::
[
Pointer'
]
->
[
Pointer'
]
updatePointers'
pointers
=
map
(
\
(
pId
,(
t
,
w
))
->
(
mapIds
!
pId
,(
t
,
w
)))
pointers
--------------------
mergeAncestors
::
[
Pointer
]
->
[
Pointer
]
mergeAncestors
pointers
=
Map
.
toList
$
fromListWith
max
pointers
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @
053fa8bc
...
...
@@ -119,6 +119,8 @@ findLastPeriod :: Filiation -> [PhyloPeriodId] -> PhyloPeriodId
findLastPeriod
fil
periods
=
case
fil
of
ToParents
->
head'
"findLastPeriod"
(
sortOn
fst
periods
)
ToChilds
->
last'
"findLastPeriod"
(
sortOn
fst
periods
)
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
-- | To filter pairs of candidates related to old pointers periods
...
...
@@ -133,6 +135,8 @@ removeOldPointers oldPointers fil thr prox prd pairs
then
[]
else
filter
(
\
((
id
,
_
),(
id'
,
_
))
->
case
fil
of
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
ToParents
->
(((
fst
.
fst
.
fst
)
id
)
<
(
fst
lastMatchedPrd
))
||
(((
fst
.
fst
.
fst
)
id'
)
<
(
fst
lastMatchedPrd
))
ToChilds
->
(((
fst
.
fst
.
fst
)
id
)
>
(
fst
lastMatchedPrd
))
...
...
@@ -181,6 +185,8 @@ filterPointersByPeriod fil pts =
$
case
fil
of
ToParents
->
reverse
pts'
ToChilds
->
pts'
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
phyloGroupMatching
::
[[(
PhyloGroupId
,[
Int
])]]
->
Filiation
->
Proximity
->
Map
Date
Double
->
Map
Date
Cooc
->
Double
->
[
Pointer
]
->
(
PhyloGroupId
,[
Int
])
->
[
Pointer
]
...
...
@@ -236,6 +242,8 @@ getNextPeriods fil max' pId pIds =
case
fil
of
ToChilds
->
take
max'
$
(
tail
.
snd
)
$
splitAt
(
elemIndex'
pId
pIds
)
pIds
ToParents
->
take
max'
$
(
reverse
.
fst
)
$
splitAt
(
elemIndex'
pId
pIds
)
pIds
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
getCandidates
::
PhyloGroup
->
[[(
PhyloGroupId
,[
Int
])]]
->
[[(
PhyloGroupId
,[
Int
])]]
...
...
@@ -268,7 +276,9 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups =
pointersChi
=
phyloGroupMatching
(
getCandidates
ego
candidatesChi
)
ToChilds
proximity
docsChi
diagoChi
thr
(
getPeriodPointers
ToChilds
ego
)
(
getGroupId
ego
,
ego
^.
phylo_groupNgrams
)
in
addPointers
ToChilds
TemporalPointer
pointersChi
$
addPointers
ToParents
TemporalPointer
pointersPar
ego
)
$
addPointers
ToParents
TemporalPointer
pointersPar
$
addMemoryPointers
ToChildsMemory
TemporalPointer
thr
pointersChi
$
addMemoryPointers
ToParentsMemory
TemporalPointer
thr
pointersPar
ego
)
$
findWithDefault
[]
prd
groups'
egos'
=
egos
`
using
`
parList
rdeepseq
in
acc
++
egos'
...
...
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