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
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
840513f3
Commit
840513f3
authored
1 year ago
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Use parMap instead of using parList
parent
8485e059
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
14 additions
and
20 deletions
+14
-20
PhyloMaker.hs
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
+14
-20
No files found.
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
840513f3
...
...
@@ -15,7 +15,7 @@ module Gargantext.Core.Viz.Phylo.PhyloMaker where
import
Control.Lens
hiding
(
Level
)
import
Control.Parallel.Strategies
(
par
List
,
rdeepseq
,
using
)
import
Control.Parallel.Strategies
(
par
Map
,
rpar
)
import
Data.List
(
nub
,
partition
,
intersect
,
tail
)
import
Data.List
qualified
as
List
import
Data.Map
(
fromListWith
,
keys
,
unionWith
,
fromList
,
empty
,
toList
,
elems
,
(
!
),
restrictKeys
,
insert
)
...
...
@@ -131,7 +131,7 @@ evolvSeaLadder nbFdt lambda freq similarities graph = map snd
--------
-- 1.1) for each measure of similarity, prune the flat phylo, compute the branches and estimate the quality
qua
::
[
Double
]
qua
=
map
(
\
thr
->
qua
=
parMap
rpar
(
\
thr
->
let
edges
=
filter
(
\
edge
->
snd
edge
>=
thr
)
graph
nodes
=
nub
$
concat
$
map
(
\
((
n
,
n'
),
_
)
->
[
n
,
n'
])
edges
branches
=
toRelatedComponents
nodes
edges
...
...
@@ -172,7 +172,7 @@ findSeaLadder phylo = case getSeaElevation phylo of
docs
=
filterDocs
(
getDocsByDate
phylo
)
([
period
]
++
next
)
diagos
=
filterDiago
(
getCoocByDate
phylo
)
([
period
]
++
next
)
-- 1.2) compute the kinship similarities between pairs of source & target in parallel
pairs
=
map
(
\
source
->
pairs
=
parMap
rpar
(
\
source
->
let
candidates
=
filter
(
\
target
->
(
>
2
)
$
length
$
intersect
(
getGroupNgrams
source
)
(
getGroupNgrams
target
))
targets
in
map
(
\
target
->
...
...
@@ -183,8 +183,7 @@ findSeaLadder phylo = case getSeaElevation phylo of
in
((
source
,
target
),
toSimilarity
nbDocs
diago
(
getSimilarity
phylo
)
(
getGroupNgrams
source
)
(
getGroupNgrams
target
)
(
getGroupNgrams
target
))
)
candidates
)
sources
pairs'
=
pairs
`
using
`
parList
rdeepseq
in
acc
++
(
concat
pairs'
)
in
acc
++
(
concat
pairs
)
)
[]
$
keys
$
phylo
^.
phylo_periods
appendGroups
::
(
a
->
Period
->
(
Text
,
Text
)
->
Scale
->
Int
->
[
Cooc
]
->
Map
Int
Double
->
PhyloGroup
)
->
Scale
->
Map
(
Date
,
Date
)
[
a
]
->
Phylo
->
Phylo
...
...
@@ -311,15 +310,14 @@ filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. clustering_roots) >=
-- To filter nested Fis
filterCliqueByNested
::
Map
(
Date
,
Date
)
[
Clustering
]
->
Map
(
Date
,
Date
)
[
Clustering
]
filterCliqueByNested
m
=
let
clq
=
map
(
\
l
->
let
clq
=
parMap
rpar
(
\
l
->
foldl
(
\
mem
f
->
if
(
any
(
\
f'
->
isNested
(
f'
^.
clustering_roots
)
(
f
^.
clustering_roots
))
mem
)
then
mem
else
let
fMax
=
filter
(
\
f'
->
not
$
isNested
(
f
^.
clustering_roots
)
(
f'
^.
clustering_roots
))
mem
in
fMax
++
[
f
]
)
[]
l
)
$
elems
m
clq'
=
clq
`
using
`
parList
rdeepseq
in
fromList
$
zip
(
keys
m
)
clq'
in
fromList
$
zip
(
keys
m
)
clq
-- | To transform a time map of docs into a time map of Fis with some filters
...
...
@@ -340,7 +338,7 @@ toSeriesOfClustering phylo phyloDocs = case (clique $ getConfig phylo) of
seriesOfClustering
::
Map
(
Date
,
Date
)
[
Clustering
]
seriesOfClustering
=
case
(
clique
$
getConfig
phylo
)
of
Fis
_
_
->
let
fis
=
map
(
\
(
prd
,
docs
)
->
let
fis
=
parMap
rpar
(
\
(
prd
,
docs
)
->
case
(
corpusParser
$
getConfig
phylo
)
of
Csv'
_
->
let
lst
=
toList
$
fisWithSizePolyMap'
(
Segment
1
20
)
1
(
map
(
\
d
->
(
ngramsToIdx
(
text
d
)
(
getRoots
phylo
),
(
weight
d
,
(
sourcesToIdx
(
sources
d
)
(
getSources
phylo
)))))
docs
)
...
...
@@ -350,18 +348,16 @@ toSeriesOfClustering phylo phyloDocs = case (clique $ getConfig phylo) of
in
(
prd
,
map
(
\
f
->
Clustering
(
Set
.
toList
$
fst
f
)
(
snd
f
)
prd
(
Just
$
fromIntegral
$
snd
f
)
[]
)
lst
)
)
$
toList
phyloDocs
fis'
=
fis
`
using
`
parList
rdeepseq
in
fromList
fis'
in
fromList
fis
MaxClique
_
thr
filterType
->
let
mcl
=
map
(
\
(
prd
,
docs
)
->
let
mcl
=
parMap
rpar
(
\
(
prd
,
docs
)
->
let
cooc
=
map
round
$
foldl
sumCooc
empty
$
map
listToMatrix
$
map
(
\
d
->
ngramsToIdx
(
text
d
)
(
getRoots
phylo
))
docs
in
(
prd
,
map
(
\
cl
->
Clustering
cl
0
prd
Nothing
[]
)
$
getMaxCliques
filterType
Conditional
thr
cooc
))
$
toList
phyloDocs
mcl'
=
mcl
`
using
`
parList
rdeepseq
in
fromList
mcl'
in
fromList
mcl
--------------------------------------
-- dev viz graph maxClique getMaxClique
...
...
@@ -406,13 +402,12 @@ groupDocsByPeriodRec f prds docs acc =
groupDocsByPeriod'
::
(
NFData
doc
,
Ord
date
,
Enum
date
)
=>
(
doc
->
date
)
->
[(
date
,
date
)]
->
[
doc
]
->
Map
(
date
,
date
)
[
doc
]
groupDocsByPeriod'
f
pds
docs
=
let
docs'
=
groupBy
(
\
d
d'
->
f
d
==
f
d'
)
$
sortOn
f
docs
periods
=
map
(
inPeriode
f
docs'
)
pds
periods'
=
periods
`
using
`
parList
rdeepseq
periods
=
parMap
rpar
(
inPeriode
f
docs'
)
pds
in
trace
(
"
\n
"
<>
"-- | Group "
<>
show
(
length
docs
)
<>
" docs by "
<>
show
(
length
pds
)
<>
" periods"
<>
"
\n
"
::
Text
)
$
fromList
$
zip
pds
periods
'
$
fromList
$
zip
pds
periods
where
--------------------------------------
inPeriode
::
Ord
b
=>
(
t
->
b
)
->
[[
t
]]
->
(
b
,
b
)
->
[
t
]
...
...
@@ -425,13 +420,12 @@ groupDocsByPeriod' f pds docs =
groupDocsByPeriod
::
(
NFData
doc
,
Ord
date
,
Enum
date
)
=>
(
doc
->
date
)
->
[(
date
,
date
)]
->
[
doc
]
->
Map
(
date
,
date
)
[
doc
]
groupDocsByPeriod
_
_
[]
=
panic
"[ERR][Viz.Phylo.PhyloMaker] Empty [Documents] can not have any periods"
groupDocsByPeriod
f
pds
es
=
let
periods
=
map
(
inPeriode
f
es
)
pds
periods'
=
periods
`
using
`
parList
rdeepseq
let
periods
=
parMap
rpar
(
inPeriode
f
es
)
pds
in
trace
(
"
\n
"
<>
"-- | Group "
<>
show
(
length
es
)
<>
" docs by "
<>
show
(
length
pds
)
<>
" periods"
<>
"
\n
"
::
Text
)
$
fromList
$
zip
pds
periods
'
$
fromList
$
zip
pds
periods
where
--------------------------------------
inPeriode
::
Ord
b
=>
(
t
->
b
)
->
[
t
]
->
(
b
,
b
)
->
[
t
]
...
...
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