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
153
Issues
153
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
deee2cd3
Commit
deee2cd3
authored
Mar 10, 2023
by
qlobbe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
merge with dev
parent
1cd9e5a1
Pipeline
#3747
failed with stage
in 88 minutes and 29 seconds
Changes
5
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
26 additions
and
26 deletions
+26
-26
Phylo.hs
src/Gargantext/Core/Viz/Phylo.hs
+6
-6
PhyloExport.hs
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
+2
-2
PhyloTools.hs
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
+5
-5
SynchronicClustering.hs
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
+2
-2
TemporalMatching.hs
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
+11
-11
No files found.
src/Gargantext/Core/Viz/Phylo.hs
View file @
deee2cd3
...
...
@@ -71,7 +71,7 @@ data SeaElevation =
instance
ToSchema
SeaElevation
data
Similarity
=
data
Phylo
Similarity
=
WeightedLogJaccard
{
_wlj_sensibility
::
Double
,
_wlj_minSharedNgrams
::
Int
}
...
...
@@ -84,7 +84,7 @@ data Similarity =
deriving
(
Show
,
Generic
,
Eq
)
instance
ToSchema
Similarity
where
instance
ToSchema
Phylo
Similarity
where
declareNamedSchema
=
genericDeclareNamedSchema
(
unPrefixSwagger
""
)
...
...
@@ -179,7 +179,7 @@ data PhyloConfig =
,
listParser
::
ListParser
,
phyloName
::
Text
,
phyloScale
::
Int
,
similarity
::
Similarity
,
similarity
::
Phylo
Similarity
,
seaElevation
::
SeaElevation
,
defaultMode
::
Bool
,
findAncestors
::
Bool
...
...
@@ -253,8 +253,8 @@ instance ToJSON CorpusParser
instance
FromJSON
ListParser
instance
ToJSON
ListParser
instance
FromJSON
Similarity
instance
ToJSON
Similarity
instance
FromJSON
Phylo
Similarity
instance
ToJSON
Phylo
Similarity
instance
FromJSON
SeaElevation
instance
ToJSON
SeaElevation
...
...
@@ -601,7 +601,7 @@ instance ToSchema PhyloExport where
makeLenses
''
P
hyloConfig
makeLenses
''
P
hyloSubConfig
makeLenses
''
S
imilarity
makeLenses
''
P
hylo
Similarity
makeLenses
''
S
eaElevation
makeLenses
''
Q
uality
makeLenses
''
C
luster
...
...
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @
deee2cd3
...
...
@@ -596,7 +596,7 @@ getGroupThr step g =
breaks
=
(
g
^.
phylo_groupMeta
)
!
"breaks"
in
(
last'
"export"
(
take
(
round
$
(
last'
"export"
breaks
)
+
1
)
seaLvl
))
-
step
toAncestor
::
Double
->
Map
Int
Double
->
Similarity
->
Double
->
[
PhyloGroup
]
->
PhyloGroup
->
PhyloGroup
toAncestor
::
Double
->
Map
Int
Double
->
Phylo
Similarity
->
Double
->
[
PhyloGroup
]
->
PhyloGroup
->
PhyloGroup
toAncestor
nbDocs
diago
similarity
step
candidates
ego
=
let
curr
=
ego
^.
phylo_groupAncestors
in
ego
&
phylo_groupAncestors
.~
(
curr
++
(
map
(
\
(
g
,
w
)
->
(
getGroupId
g
,
w
))
...
...
@@ -605,7 +605,7 @@ toAncestor nbDocs diago similarity step candidates ego =
$
filter
(
\
g
->
g
^.
phylo_groupBranchId
/=
ego
^.
phylo_groupBranchId
)
candidates
))
headsToAncestors
::
Double
->
Map
Int
Double
->
Similarity
->
Double
->
[
PhyloGroup
]
->
[
PhyloGroup
]
->
[
PhyloGroup
]
headsToAncestors
::
Double
->
Map
Int
Double
->
Phylo
Similarity
->
Double
->
[
PhyloGroup
]
->
[
PhyloGroup
]
->
[
PhyloGroup
]
headsToAncestors
nbDocs
diago
similarity
step
heads
acc
=
if
(
null
heads
)
then
acc
...
...
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @
deee2cd3
...
...
@@ -406,14 +406,14 @@ getPeriodPointers fil g =
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
filterSimilarity
::
Similarity
->
Double
->
Double
->
Bool
filterSimilarity
::
Phylo
Similarity
->
Double
->
Double
->
Bool
filterSimilarity
similarity
thr
local
=
case
similarity
of
WeightedLogJaccard
_
_
->
local
>=
thr
WeightedLogSim
_
_
->
local
>=
thr
Hamming
_
_
->
undefined
getSimilarityName
::
Similarity
->
String
getSimilarityName
::
Phylo
Similarity
->
String
getSimilarityName
similarity
=
case
similarity
of
WeightedLogJaccard
_
_
->
"WLJaccard"
...
...
@@ -474,7 +474,7 @@ getScales phylo = nub
getSeaElevation
::
Phylo
->
SeaElevation
getSeaElevation
phylo
=
seaElevation
(
getConfig
phylo
)
getSimilarity
::
Phylo
->
Similarity
getSimilarity
::
Phylo
->
Phylo
Similarity
getSimilarity
phylo
=
similarity
(
getConfig
phylo
)
...
...
@@ -687,13 +687,13 @@ traceSynchronyStart phylo =
-- | Similarity | --
-------------------
getSensibility
::
Similarity
->
Double
getSensibility
::
Phylo
Similarity
->
Double
getSensibility
proxi
=
case
proxi
of
WeightedLogJaccard
s
_
->
s
WeightedLogSim
s
_
->
s
Hamming
_
_
->
undefined
getMinSharedNgrams
::
Similarity
->
Int
getMinSharedNgrams
::
Phylo
Similarity
->
Int
getMinSharedNgrams
proxi
=
case
proxi
of
WeightedLogJaccard
_
m
->
m
WeightedLogSim
_
m
->
m
...
...
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @
deee2cd3
...
...
@@ -124,7 +124,7 @@ toDiamonds groups = foldl' (\acc groups' ->
$
foldl'
(
\
acc
g
->
acc
++
(
map
(
\
(
id
,
_
)
->
(
id
,[
g
])
)
$
g
^.
phylo_groupPeriodParents
)
)
[]
groups
groupsToEdges
::
Similarity
->
Synchrony
->
Double
->
Map
Int
Double
->
[
PhyloGroup
]
->
[((
PhyloGroup
,
PhyloGroup
),
Double
)]
groupsToEdges
::
Phylo
Similarity
->
Synchrony
->
Double
->
Map
Int
Double
->
[
PhyloGroup
]
->
[((
PhyloGroup
,
PhyloGroup
),
Double
)]
groupsToEdges
prox
sync
nbDocs
diago
groups
=
case
sync
of
ByProximityThreshold
thr
sens
_
strat
->
...
...
@@ -153,7 +153,7 @@ toParentId :: PhyloGroup -> PhyloGroupId
toParentId
child
=
((
child
^.
phylo_groupPeriod
,
child
^.
phylo_groupScale
+
1
),
child
^.
phylo_groupIndex
)
reduceGroups
::
Similarity
->
Synchrony
->
Map
Date
Double
->
Map
Date
Cooc
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reduceGroups
::
Phylo
Similarity
->
Synchrony
->
Map
Date
Double
->
Map
Date
Cooc
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reduceGroups
prox
sync
docs
diagos
branch
=
-- 1) reduce a branch as a set of periods & groups
let
periods
=
fromListWith
(
++
)
...
...
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @
deee2cd3
...
...
@@ -119,7 +119,7 @@ weightedLogSim' sens nbDocs diago ego_ngrams target_ngrams
{-
-- perform a seamilarity measure between a given group and a pair of targeted groups
-}
toSimilarity
::
Double
->
Map
Int
Double
->
Similarity
->
[
Int
]
->
[
Int
]
->
[
Int
]
->
Double
toSimilarity
::
Double
->
Map
Int
Double
->
Phylo
Similarity
->
[
Int
]
->
[
Int
]
->
[
Int
]
->
Double
toSimilarity
nbDocs
diago
similarity
egoNgrams
targetNgrams
targetNgrams'
=
case
similarity
of
WeightedLogJaccard
sens
_
->
...
...
@@ -147,7 +147,7 @@ findLastPeriod fil periods = case fil of
ToChildsMemory
->
undefined
ToParentsMemory
->
undefined
removeOldPointers
::
[
Pointer
]
->
Filiation
->
Double
->
Similarity
->
Period
removeOldPointers
::
[
Pointer
]
->
Filiation
->
Double
->
Phylo
Similarity
->
Period
->
[((
PhyloGroupId
,[
Int
]),(
PhyloGroupId
,[
Int
]))]
->
[((
PhyloGroupId
,[
Int
]),(
PhyloGroupId
,[
Int
]))]
removeOldPointers
oldPointers
fil
thr
prox
prd
pairs
...
...
@@ -166,10 +166,10 @@ removeOldPointers oldPointers fil thr prox prd pairs
||
(((
fst
.
fst
.
fst
)
id'
)
>
(
fst
lastMatchedPrd
)))
pairs
|
otherwise
=
[]
filterPointers
::
Similarity
->
Double
->
[
Pointer
]
->
[
Pointer
]
filterPointers
::
Phylo
Similarity
->
Double
->
[
Pointer
]
->
[
Pointer
]
filterPointers
proxi
thr
pts
=
filter
(
\
(
_
,
w
)
->
filterSimilarity
proxi
thr
w
)
pts
filterPointers'
::
Similarity
->
Double
->
[(
Pointer
,[
Int
])]
->
[(
Pointer
,[
Int
])]
filterPointers'
::
Phylo
Similarity
->
Double
->
[(
Pointer
,[
Int
])]
->
[(
Pointer
,[
Int
])]
filterPointers'
proxi
thr
pts
=
filter
(
\
((
_
,
w
),
_
)
->
filterSimilarity
proxi
thr
w
)
pts
...
...
@@ -231,7 +231,7 @@ groupsToBranches groups =
{-
-- find the best pair/singleton of parents/childs for a given group
-}
makePairs
::
(
PhyloGroupId
,[
Int
])
->
[(
PhyloGroupId
,[
Int
])]
->
[
Period
]
->
[
Pointer
]
->
Filiation
->
Double
->
Similarity
makePairs
::
(
PhyloGroupId
,[
Int
])
->
[(
PhyloGroupId
,[
Int
])]
->
[
Period
]
->
[
Pointer
]
->
Filiation
->
Double
->
Phylo
Similarity
->
Map
Date
Double
->
Map
Date
Cooc
->
[((
PhyloGroupId
,[
Int
]),(
PhyloGroupId
,[
Int
]))]
makePairs
(
egoId
,
egoNgrams
)
candidates
periods
oldPointers
fil
thr
prox
docs
diagos
=
if
(
null
periods
)
...
...
@@ -258,7 +258,7 @@ makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs di
{-
-- find the best temporal links between a given group and its parents/childs
-}
phyloGroupMatching
::
[[(
PhyloGroupId
,[
Int
])]]
->
Filiation
->
Similarity
->
Map
Date
Double
->
Map
Date
Cooc
phyloGroupMatching
::
[[(
PhyloGroupId
,[
Int
])]]
->
Filiation
->
Phylo
Similarity
->
Map
Date
Double
->
Map
Date
Cooc
->
Double
->
[
Pointer
]
->
(
PhyloGroupId
,[
Int
])
->
[
Pointer
]
phyloGroupMatching
candidates
filiation
proxi
docs
diagos
thr
oldPointers
(
id
,
ngrams
)
=
if
(
null
$
filterPointers
proxi
thr
oldPointers
)
...
...
@@ -329,7 +329,7 @@ getCandidates minNgrams ego targets =
{-
-- set up and start performing the upstream/downstream inter‐temporal matching period by period
-}
reconstructTemporalLinks
::
Int
->
[
Period
]
->
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reconstructTemporalLinks
::
Int
->
[
Period
]
->
Phylo
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reconstructTemporalLinks
frame
periods
similarity
thr
docs
coocs
groups
=
let
groups'
=
groupByField
_phylo_groupPeriod
groups
in
foldl'
(
\
acc
prd
->
...
...
@@ -396,7 +396,7 @@ filterByNgrams inf ngrams groups =
{-
-- perform the upstream/downstream inter‐temporal matching process group by group
-}
reconstructTemporalLinks'
::
Int
->
[
Period
]
->
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
Map
Int
[
PhyloGroupId
]
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reconstructTemporalLinks'
::
Int
->
[
Period
]
->
Phylo
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
Map
Int
[
PhyloGroupId
]
->
[
PhyloGroup
]
->
[
PhyloGroup
]
reconstructTemporalLinks'
frame
periods
similarity
thr
docs
coocs
roots
groups
=
let
egos
=
map
(
\
ego
->
let
-- 1) find the parents/childs matching periods
...
...
@@ -432,7 +432,7 @@ reconstructTemporalLinks' frame periods similarity thr docs coocs roots groups =
{-
-- reconstruct a phylomemetic network from a list of groups and from a given threshold
-}
toPhylomemeticNetwork
::
Int
->
[
Period
]
->
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
Map
Int
[
PhyloGroupId
]
->
[
PhyloGroup
]
->
[
Branch
]
toPhylomemeticNetwork
::
Int
->
[
Period
]
->
Phylo
Similarity
->
Double
->
Map
Date
Double
->
Map
Date
Cooc
->
Map
Int
[
PhyloGroupId
]
->
[
PhyloGroup
]
->
[
Branch
]
toPhylomemeticNetwork
timescale
periods
similarity
thr
docs
coocs
roots
groups
=
groupsToBranches
$
fromList
$
map
(
\
g
->
(
getGroupId
g
,
g
))
-- $ reconstructTemporalLinks timescale periods similarity thr docs coocs groups
...
...
@@ -592,7 +592,7 @@ thrToMeta thr branches =
-- done = all the already separated branches
-- rest = all the branches we still have to separate
-}
separateBranches
::
Double
->
Similarity
->
Double
->
Map
Int
Double
->
Int
->
Double
->
Double
separateBranches
::
Double
->
Phylo
Similarity
->
Double
->
Map
Int
Double
->
Int
->
Double
->
Double
->
Int
->
Map
Date
Double
->
Map
Date
Cooc
->
Map
Int
[
PhyloGroupId
]
->
[
Period
]
->
[(
Branch
,
ShouldTry
)]
->
(
Branch
,
ShouldTry
)
->
[(
Branch
,
ShouldTry
)]
->
[(
Branch
,
ShouldTry
)]
...
...
@@ -647,7 +647,7 @@ separateBranches fdt similarity lambda frequency minBranch thr rise timescale do
{-
-- perform the sea-level rise algorithm, browse the similarity ladder and check that we can try out the next step
-}
seaLevelRise
::
Double
->
Similarity
->
Double
->
Int
->
Map
Int
Double
seaLevelRise
::
Double
->
Phylo
Similarity
->
Double
->
Int
->
Map
Int
Double
->
[
Double
]
->
Double
->
Int
->
[
Period
]
->
Map
Date
Double
->
Map
Date
Cooc
...
...
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