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
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
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
Christian Merten
haskell-gargantext
Commits
e7c244d8
Commit
e7c244d8
authored
Jun 21, 2023
by
qlobbe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
maybe fix the phylo issue
parent
e93416f8
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
65 additions
and
49 deletions
+65
-49
Update.hs
src/Gargantext/API/Node/Update.hs
+3
-3
Phylo.hs
src/Gargantext/Core/Viz/Phylo.hs
+33
-27
PhyloExport.hs
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
+1
-1
PhyloMaker.hs
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
+25
-15
PhyloTools.hs
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
+3
-3
No files found.
src/Gargantext/API/Node/Update.hs
View file @
e7c244d8
...
@@ -32,7 +32,7 @@ import Gargantext.Core.Types.Main (ListType(..))
...
@@ -32,7 +32,7 @@ import Gargantext.Core.Types.Main (ListType(..))
import
Gargantext.Core.Viz.Graph.API
(
recomputeGraph
)
import
Gargantext.Core.Viz.Graph.API
(
recomputeGraph
)
import
Gargantext.Core.Viz.Graph.Tools
(
PartitionMethod
(
..
),
BridgenessMethod
(
..
))
import
Gargantext.Core.Viz.Graph.Tools
(
PartitionMethod
(
..
),
BridgenessMethod
(
..
))
import
Gargantext.Core.Viz.Graph.Types
(
Strength
)
import
Gargantext.Core.Viz.Graph.Types
(
Strength
)
import
Gargantext.Core.Viz.Phylo
(
PhyloSubConfig
(
..
),
subConfig
2config
)
import
Gargantext.Core.Viz.Phylo
(
PhyloSubConfig
API
(
..
),
subConfigAPI
2config
)
import
Gargantext.Core.Viz.Phylo.API.Tools
(
flowPhyloAPI
)
import
Gargantext.Core.Viz.Phylo.API.Tools
(
flowPhyloAPI
)
import
Gargantext.Database.Action.Flow.Pairing
(
pairing
)
import
Gargantext.Database.Action.Flow.Pairing
(
pairing
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
...
@@ -76,7 +76,7 @@ data UpdateNodeParams = UpdateNodeParamsList { methodList :: !Method }
...
@@ -76,7 +76,7 @@ data UpdateNodeParams = UpdateNodeParamsList { methodList :: !Method }
|
LinkNodeReq
{
nodeType
::
!
NodeType
|
LinkNodeReq
{
nodeType
::
!
NodeType
,
id
::
!
NodeId
}
,
id
::
!
NodeId
}
|
UpdateNodePhylo
{
config
::
!
PhyloSubConfig
}
|
UpdateNodePhylo
{
config
::
!
PhyloSubConfig
API
}
deriving
(
Generic
)
deriving
(
Generic
)
----------------------------------------------------------------------
----------------------------------------------------------------------
...
@@ -209,7 +209,7 @@ updateNode _userId phyloId (UpdateNodePhylo config) logStatus = do
...
@@ -209,7 +209,7 @@ updateNode _userId phyloId (UpdateNodePhylo config) logStatus = do
let
corpusId
=
fromMaybe
(
panic
""
)
corpusId'
let
corpusId
=
fromMaybe
(
panic
""
)
corpusId'
phy
<-
flowPhyloAPI
(
subConfig2config
config
)
corpusId
phy
<-
flowPhyloAPI
(
subConfig
API
2config
config
)
corpusId
logStatus
JobLog
{
_scst_succeeded
=
Just
2
logStatus
JobLog
{
_scst_succeeded
=
Just
2
,
_scst_failed
=
Just
0
,
_scst_failed
=
Just
0
...
...
src/Gargantext/Core/Viz/Phylo.hs
View file @
e7c244d8
...
@@ -41,9 +41,9 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
...
@@ -41,9 +41,9 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
qualified
Data.Text.Lazy
as
TextLazy
import
qualified
Data.Text.Lazy
as
TextLazy
----------------
----------------
-----
-- | PhyloConfig | --
-- | PhyloConfig | --
----------------
----------------
-----
data
CorpusParser
=
data
CorpusParser
=
Wos
{
_wos_limit
::
Int
}
Wos
{
_wos_limit
::
Int
}
...
@@ -193,45 +193,51 @@ data PhyloConfig =
...
@@ -193,45 +193,51 @@ data PhyloConfig =
}
deriving
(
Show
,
Generic
,
Eq
)
}
deriving
(
Show
,
Generic
,
Eq
)
------------------------------------------------------------------------
--------------------------------
data
PhyloSubConfig
=
-- | SubConfig API & 1Click | --
PhyloSubConfig
{
_sc_phyloProximity
::
Double
--------------------------------
,
_sc_phyloSynchrony
::
Double
,
_sc_phyloQuality
::
Double
,
_sc_timeUnit
::
TimeUnit
,
_sc_clique
::
Cluster
,
_sc_exportFilter
::
Double
}
deriving
(
Show
,
Generic
,
Eq
)
data
PhyloSubConfigAPI
=
PhyloSubConfigAPI
{
_sc_phyloProximity
::
Double
,
_sc_phyloSynchrony
::
Double
,
_sc_phyloQuality
::
Double
,
_sc_timeUnit
::
TimeUnit
,
_sc_clique
::
Cluster
,
_sc_exportFilter
::
Double
}
deriving
(
Show
,
Generic
,
Eq
)
subConfig2config
::
PhyloSubConfig
->
PhyloConfig
subConfig2config
subConfig
=
defaultConfig
{
similarity
=
WeightedLogJaccard
(
_sc_phyloProximity
subConfig
)
1
subConfigAPI2config
::
PhyloSubConfigAPI
->
PhyloConfig
subConfigAPI2config
subConfig
=
defaultConfig
{
similarity
=
WeightedLogJaccard
(
_sc_phyloProximity
subConfig
)
2
,
phyloSynchrony
=
ByProximityThreshold
(
_sc_phyloSynchrony
subConfig
)
0
AllBranches
MergeAllGroups
,
phyloSynchrony
=
ByProximityThreshold
(
_sc_phyloSynchrony
subConfig
)
0
AllBranches
MergeAllGroups
,
phyloQuality
=
Quality
(
_sc_phyloQuality
subConfig
)
1
,
phyloQuality
=
Quality
(
_sc_phyloQuality
subConfig
)
3
,
timeUnit
=
_sc_timeUnit
subConfig
,
timeUnit
=
_sc_timeUnit
subConfig
,
clique
=
_sc_clique
subConfig
,
clique
=
_sc_clique
subConfig
,
exportFilter
=
[
ByBranchSize
$
_sc_exportFilter
subConfig
]
,
exportFilter
=
[
ByBranchSize
$
_sc_exportFilter
subConfig
]
}
}
------------------------------------------------------------------------
--------------------------
-- | SubConfig 1Click | --
--------------------------
defaultConfig
::
PhyloConfig
defaultConfig
::
PhyloConfig
defaultConfig
=
defaultConfig
=
PhyloConfig
{
corpusPath
=
"corpus.csv"
-- useful for commandline only
PhyloConfig
{
corpusPath
=
"corpus.csv"
-- useful for commandline only
,
listPath
=
"list.csv"
-- useful for commandline only
,
listPath
=
"list.csv"
-- useful for commandline only
,
outputPath
=
"data/"
,
outputPath
=
"data/"
,
corpusParser
=
Csv
1
0
0000
,
corpusParser
=
Csv
1
5
0000
,
listParser
=
V4
,
listParser
=
V4
,
phyloName
=
pack
"Phylo Name"
,
phyloName
=
pack
"Phylo Name"
,
phyloScale
=
2
,
phyloScale
=
2
,
similarity
=
WeightedLogJaccard
0.5
1
,
similarity
=
WeightedLogJaccard
0.5
2
,
seaElevation
=
Constante
0.1
0.1
,
seaElevation
=
Constante
0.1
0.1
,
defaultMode
=
Tru
e
,
defaultMode
=
Fals
e
,
findAncestors
=
Fals
e
,
findAncestors
=
Tru
e
,
phyloSynchrony
=
ByProximityThreshold
0.
5
0
AllBranches
MergeAllGroups
,
phyloSynchrony
=
ByProximityThreshold
0.
6
0
AllBranches
MergeAllGroups
,
phyloQuality
=
Quality
0.5
1
,
phyloQuality
=
Quality
0.5
3
,
timeUnit
=
Year
3
1
5
,
timeUnit
=
Year
3
1
5
,
clique
=
MaxClique
5
0.0001
ByThreshold
,
clique
=
Fis
2
3
,
exportLabel
=
[
BranchLabel
MostEmergentTfIdf
2
,
GroupLabel
MostEmergentInclusive
2
]
,
exportLabel
=
[
BranchLabel
MostEmergentTfIdf
2
,
GroupLabel
MostEmergentInclusive
2
]
,
exportSort
=
ByHierarchy
Desc
,
exportSort
=
ByHierarchy
Desc
,
exportFilter
=
[
ByBranchSize
3
]
,
exportFilter
=
[
ByBranchSize
3
]
...
@@ -239,13 +245,13 @@ defaultConfig =
...
@@ -239,13 +245,13 @@ defaultConfig =
-- Main Instances
-- Main Instances
instance
ToSchema
PhyloConfig
instance
ToSchema
PhyloConfig
instance
ToSchema
PhyloSubConfig
instance
ToSchema
PhyloSubConfig
API
instance
FromJSON
PhyloConfig
instance
FromJSON
PhyloConfig
instance
ToJSON
PhyloConfig
instance
ToJSON
PhyloConfig
instance
FromJSON
PhyloSubConfig
instance
FromJSON
PhyloSubConfig
API
instance
ToJSON
PhyloSubConfig
instance
ToJSON
PhyloSubConfig
API
instance
FromJSON
CorpusParser
instance
FromJSON
CorpusParser
instance
ToJSON
CorpusParser
instance
ToJSON
CorpusParser
...
@@ -604,7 +610,7 @@ instance ToSchema PhyloExport where
...
@@ -604,7 +610,7 @@ instance ToSchema PhyloExport where
----------------
----------------
makeLenses
''
P
hyloConfig
makeLenses
''
P
hyloConfig
makeLenses
''
P
hyloSubConfig
makeLenses
''
P
hyloSubConfig
API
makeLenses
''
P
hyloSimilarity
makeLenses
''
P
hyloSimilarity
makeLenses
''
S
eaElevation
makeLenses
''
S
eaElevation
makeLenses
''
Q
uality
makeLenses
''
Q
uality
...
...
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @
e7c244d8
...
@@ -716,7 +716,7 @@ tracePhyloAncestors :: [[PhyloGroup]] -> [[PhyloGroup]]
...
@@ -716,7 +716,7 @@ tracePhyloAncestors :: [[PhyloGroup]] -> [[PhyloGroup]]
tracePhyloAncestors
groups
=
trace
(
"-- | Found "
<>
show
(
length
$
concat
$
map
_phylo_groupAncestors
$
concat
groups
)
<>
" ancestors"
)
groups
tracePhyloAncestors
groups
=
trace
(
"-- | Found "
<>
show
(
length
$
concat
$
map
_phylo_groupAncestors
$
concat
groups
)
<>
" ancestors"
)
groups
tracePhyloInfo
::
Phylo
->
Phylo
tracePhyloInfo
::
Phylo
->
Phylo
tracePhyloInfo
phylo
=
trace
(
"
\n
"
<>
"##########################"
<>
"
\n\n
"
<>
"-- | Phylo with
λ
= "
tracePhyloInfo
phylo
=
trace
(
"
\n
"
<>
"##########################"
<>
"
\n\n
"
<>
"-- | Phylo with
level
= "
<>
show
(
getLevel
phylo
)
<>
" applied to "
<>
show
(
getLevel
phylo
)
<>
" applied to "
<>
show
(
length
$
Vector
.
toList
$
getRoots
phylo
)
<>
" foundations"
<>
show
(
length
$
Vector
.
toList
$
getRoots
phylo
)
<>
" foundations"
)
phylo
)
phylo
...
...
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @
e7c244d8
...
@@ -193,7 +193,7 @@ findSeaLadder phylo = case getSeaElevation phylo of
...
@@ -193,7 +193,7 @@ findSeaLadder phylo = case getSeaElevation phylo of
)
[]
$
keys
$
phylo
^.
phylo_periods
)
[]
$
keys
$
phylo
^.
phylo_periods
appendGroups
::
(
a
->
Period
->
(
Text
,
Text
)
->
Scale
->
Int
->
[
Cooc
]
->
Map
Int
Double
->
PhyloGroup
)
->
Scale
->
Map
(
Date
,
Date
)
[
a
]
->
Phylo
->
Phylo
appendGroups
::
(
a
->
Period
->
(
Text
,
Text
)
->
Scale
->
Int
->
[
Cooc
]
->
Map
Int
Double
->
PhyloGroup
)
->
Scale
->
Map
(
Date
,
Date
)
[
a
]
->
Phylo
->
Phylo
appendGroups
f
lvl
m
phylo
=
trace
(
"
\n
"
<>
"-- | Append "
<>
show
(
length
$
concat
$
elems
m
)
<>
" groups to
Level
"
<>
show
(
lvl
)
<>
"
\n
"
)
appendGroups
f
lvl
m
phylo
=
trace
(
"
\n
"
<>
"-- | Append "
<>
show
(
length
$
concat
$
elems
m
)
<>
" groups to
scale
"
<>
show
(
lvl
)
<>
"
\n
"
)
$
over
(
phylo_periods
$
over
(
phylo_periods
.
traverse
.
traverse
.
phylo_periodScales
.
phylo_periodScales
...
@@ -489,19 +489,29 @@ initPhyloScales lvlMax pId =
...
@@ -489,19 +489,29 @@ initPhyloScales lvlMax pId =
fromList
$
map
(
\
lvl
->
((
pId
,
lvl
),
PhyloScale
pId
(
""
,
""
)
lvl
empty
))
[
1
..
lvlMax
]
fromList
$
map
(
\
lvl
->
((
pId
,
lvl
),
PhyloScale
pId
(
""
,
""
)
lvl
empty
))
[
1
..
lvlMax
]
setDefault
::
PhyloConfig
->
TimeUnit
->
PhyloConfig
setDefault
conf
timeScale
=
conf
{
setDefault
::
PhyloConfig
->
TimeUnit
->
Int
->
PhyloConfig
phyloScale
=
2
,
setDefault
conf
timeScale
nbDocs
=
defaultConfig
similarity
=
WeightedLogJaccard
0.5
2
,
{
corpusPath
=
(
corpusPath
conf
)
findAncestors
=
True
,
,
listPath
=
(
listPath
conf
)
phyloSynchrony
=
ByProximityThreshold
0.6
0
SiblingBranches
MergeAllGroups
,
,
outputPath
=
(
outputPath
conf
)
phyloQuality
=
Quality
0.5
3
,
,
corpusParser
=
(
corpusParser
conf
)
timeUnit
=
timeScale
,
,
listParser
=
(
listParser
conf
)
clique
=
Fis
3
5
,
,
phyloName
=
(
phyloName
conf
)
exportLabel
=
[
BranchLabel
MostEmergentTfIdf
2
,
GroupLabel
MostEmergentInclusive
2
],
,
defaultMode
=
True
exportSort
=
ByHierarchy
Desc
,
,
timeUnit
=
timeScale
exportFilter
=
[
ByBranchSize
3
]
,
clique
=
Fis
(
toSupport
nbDocs
)
3
}
}
where
--------------------------------------
toSupport
::
Int
->
Support
toSupport
n
|
n
<
500
=
1
|
n
<
1000
=
2
|
n
<
2000
=
3
|
n
<
3000
=
4
|
n
<
5000
=
5
|
otherwise
=
6
--------------------------------------
-- Init the basic elements of a Phylo
-- Init the basic elements of a Phylo
...
@@ -519,7 +529,7 @@ initPhylo docs conf =
...
@@ -519,7 +529,7 @@ initPhylo docs conf =
(
docsToTermFreq
docs
(
foundations
^.
foundations_roots
))
(
docsToTermFreq
docs
(
foundations
^.
foundations_roots
))
(
docsToLastTermFreq
(
getTimePeriod
timeScale
)
docs
(
foundations
^.
foundations_roots
))
(
docsToLastTermFreq
(
getTimePeriod
timeScale
)
docs
(
foundations
^.
foundations_roots
))
params
=
if
(
defaultMode
conf
)
params
=
if
(
defaultMode
conf
)
then
defaultPhyloParam
{
_phyloParam_config
=
setDefault
conf
timeScale
}
then
defaultPhyloParam
{
_phyloParam_config
=
setDefault
conf
timeScale
(
length
docs
)
}
else
defaultPhyloParam
{
_phyloParam_config
=
conf
}
else
defaultPhyloParam
{
_phyloParam_config
=
conf
}
periods
=
toPeriods
(
sort
$
nub
$
map
date
docs
)
(
getTimePeriod
timeScale
)
(
getTimeStep
timeScale
)
periods
=
toPeriods
(
sort
$
nub
$
map
date
docs
)
(
getTimePeriod
timeScale
)
(
getTimeStep
timeScale
)
in
trace
(
"
\n
"
<>
"-- | Init a phylo out of "
<>
show
(
length
docs
)
<>
" docs
\n
"
)
in
trace
(
"
\n
"
<>
"-- | Init a phylo out of "
<>
show
(
length
docs
)
<>
" docs
\n
"
)
...
...
src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
View file @
e7c244d8
...
@@ -633,7 +633,7 @@ updateLevel level phylo = phylo { _phylo_level = level }
...
@@ -633,7 +633,7 @@ updateLevel level phylo = phylo { _phylo_level = level }
traceToPhylo
::
Scale
->
Phylo
->
Phylo
traceToPhylo
::
Scale
->
Phylo
->
Phylo
traceToPhylo
lvl
phylo
=
traceToPhylo
lvl
phylo
=
trace
(
"
\n
"
<>
"-- | End of phylo making at
level
"
<>
show
(
lvl
)
<>
" with "
trace
(
"
\n
"
<>
"-- | End of phylo making at
scale
"
<>
show
(
lvl
)
<>
" with "
<>
show
(
length
$
getGroupsFromScale
lvl
phylo
)
<>
" groups and "
<>
show
(
length
$
getGroupsFromScale
lvl
phylo
)
<>
" groups and "
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
lvl
phylo
)
<>
" branches"
<>
"
\n
"
)
phylo
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
lvl
phylo
)
<>
" branches"
<>
"
\n
"
)
phylo
...
@@ -697,14 +697,14 @@ toRelatedComponents nodes edges =
...
@@ -697,14 +697,14 @@ toRelatedComponents nodes edges =
traceSynchronyEnd
::
Phylo
->
Phylo
traceSynchronyEnd
::
Phylo
->
Phylo
traceSynchronyEnd
phylo
=
traceSynchronyEnd
phylo
=
trace
(
"-- | End synchronic clustering at
level
"
<>
show
(
getLastLevel
phylo
)
trace
(
"-- | End synchronic clustering at
scale
"
<>
show
(
getLastLevel
phylo
)
<>
" with "
<>
show
(
length
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" groups"
<>
" with "
<>
show
(
length
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" groups"
<>
" and "
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" branches"
<>
" and "
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" branches"
<>
"
\n
"
)
phylo
<>
"
\n
"
)
phylo
traceSynchronyStart
::
Phylo
->
Phylo
traceSynchronyStart
::
Phylo
->
Phylo
traceSynchronyStart
phylo
=
traceSynchronyStart
phylo
=
trace
(
"
\n
"
<>
"-- | Start synchronic clustering at
level
"
<>
show
(
getLastLevel
phylo
)
trace
(
"
\n
"
<>
"-- | Start synchronic clustering at
scale
"
<>
show
(
getLastLevel
phylo
)
<>
" with "
<>
show
(
length
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" groups"
<>
" with "
<>
show
(
length
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" groups"
<>
" and "
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" branches"
<>
" and "
<>
show
(
length
$
nub
$
map
_phylo_groupBranchId
$
getGroupsFromScale
(
getLastLevel
phylo
)
phylo
)
<>
" branches"
<>
"
\n
"
)
phylo
<>
"
\n
"
)
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