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
9dec48f6
Commit
9dec48f6
authored
6 years ago
by
Quentin Lobbé
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
add the foundations to the phylo
parent
6071ffb7
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
132 additions
and
127 deletions
+132
-127
Phylo.hs
src/Gargantext/Viz/Phylo.hs
+8
-12
Cooc.hs
src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs
+2
-2
Document.hs
src/Gargantext/Viz/Phylo/Aggregates/Document.hs
+29
-22
BranchMaker.hs
src/Gargantext/Viz/Phylo/BranchMaker.hs
+2
-2
Example.hs
src/Gargantext/Viz/Phylo/Example.hs
+50
-48
LevelMaker.hs
src/Gargantext/Viz/Phylo/LevelMaker.hs
+16
-6
Clustering.hs
src/Gargantext/Viz/Phylo/Metrics/Clustering.hs
+0
-6
Tools.hs
src/Gargantext/Viz/Phylo/Tools.hs
+25
-29
No files found.
src/Gargantext/Viz/Phylo.hs
View file @
9dec48f6
...
...
@@ -66,15 +66,14 @@ data Software =
------------------------------------------------------------------------
-- | Phylo datatype
descriptor
of a phylomemy
-- Duration
: time Segment of the whole phylomemy (start,end)
--
Ngrams : list of all (possible) terms contained in the phylomemy (with their id
)
--
Steps : list of all steps to build the phylomemy
-- | Phylo datatype of a phylomemy
-- Duration
: time Segment of the whole Phylo
--
Foundations : vector of all the Ngrams contained in a Phylo (build from a list of actants
)
--
Periods : list of all the periods of a Phylo
data
Phylo
=
Phylo
{
_phylo_duration
::
(
Start
,
End
)
,
_phylo_ngrams
::
PhyloNgrams
,
_phylo_periods
::
[
PhyloPeriod
]
,
_phylo_branches
::
[
PhyloBranch
]
Phylo
{
_phylo_duration
::
(
Start
,
End
)
,
_phylo_foundations
::
Vector
Ngrams
,
_phylo_periods
::
[
PhyloPeriod
]
}
deriving
(
Generic
,
Show
)
...
...
@@ -157,12 +156,8 @@ type PhyloBranchId = (Level, Index)
type
Weight
=
Double
-- | Pointer : A weighted linked with a given PhyloGroup
type
Pointer
=
(
PhyloGroupId
,
Weight
)
-- | Ngrams : a contiguous sequence of n terms
type
Ngrams
=
Text
-- | PhyloNgrams : Vector of all the Ngrams (PhyloGroup of level -1) used within a Phylo
type
PhyloNgrams
=
Vector
Ngrams
-- | Clique : Set of ngrams cooccurring in the same Document
...
...
@@ -204,6 +199,7 @@ data Clustering = Louvain | RelatedComponents
data
PairTo
=
Childs
|
Parents
-- | Lenses
makeLenses
''
P
hylo
makeLenses
''
P
hyloParam
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs
View file @
9dec48f6
...
...
@@ -37,7 +37,7 @@ fisToCooc :: Map (Date, Date) [Fis] -> Phylo -> Map (Int, Int) Double
fisToCooc
m
p
=
map
(
/
docs
)
$
foldl
(
\
mem
x
->
adjust
(
+
1
)
(
getKeyPair
x
mem
)
mem
)
cooc
$
concat
$
map
(
\
x
->
listToUnDirectedCombiWith
(
\
x
->
ngramsToIdx
x
p
)
$
(
Set
.
toList
.
fst
)
x
)
$
map
(
\
x
->
listToUnDirectedCombiWith
(
\
x
->
getIdxInFoundations
x
p
)
$
(
Set
.
toList
.
fst
)
x
)
$
(
concat
.
elems
)
m
where
--------------------------------------
...
...
@@ -48,5 +48,5 @@ fisToCooc m p = map (/docs)
docs
=
fromIntegral
$
foldl
(
\
mem
x
->
mem
+
(
snd
x
))
0
$
(
concat
.
elems
)
m
--------------------------------------
cooc
::
Map
(
Int
,
Int
)
(
Double
)
cooc
=
Map
.
fromList
$
map
(
\
x
->
(
x
,
0
))
(
listToUnDirectedCombiWith
(
\
x
->
ngramsToIdx
x
p
)
fisNgrams
)
cooc
=
Map
.
fromList
$
map
(
\
x
->
(
x
,
0
))
(
listToUnDirectedCombiWith
(
\
x
->
getIdxInFoundations
x
p
)
fisNgrams
)
--------------------------------------
\ No newline at end of file
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Aggregates/Document.hs
View file @
9dec48f6
...
...
@@ -34,38 +34,45 @@ import qualified Data.Map as Map
import
qualified
Data.Vector
as
Vector
-- | To init a set of periods out of a given Grain and Step
docsToPeriods
::
(
Ord
date
,
Enum
date
)
=>
(
doc
->
date
)
->
Grain
->
Step
->
[
doc
]
->
Map
(
date
,
date
)
[
doc
]
docsToPeriods
_
_
_
[]
=
panic
"[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
docsToPeriods
f
g
s
es
=
Map
.
fromList
$
zip
hs
$
map
(
inPeriode
f
es
)
hs
-- | To init a list of Periods framed by a starting Date and an ending Date
initPeriods
::
(
Eq
date
,
Enum
date
)
=>
Grain
->
Step
->
(
date
,
date
)
->
[(
date
,
date
)]
initPeriods
g
s
(
start
,
end
)
=
map
(
\
l
->
(
head
l
,
last
l
))
$
chunkAlong
g
s
[
start
..
end
]
-- | To be defined, for the moment it's just the id function
groupNgramsWithTrees
::
Ngrams
->
Ngrams
groupNgramsWithTrees
n
=
n
-- | To group a list of Documents by fixed periods
groupDocsByPeriod
::
(
Ord
date
,
Enum
date
)
=>
(
doc
->
date
)
->
[(
date
,
date
)]
->
[
doc
]
->
Map
(
date
,
date
)
[
doc
]
groupDocsByPeriod
_
_
[]
=
panic
"[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
groupDocsByPeriod
f
pds
es
=
Map
.
fromList
$
zip
pds
$
map
(
inPeriode
f
es
)
pds
where
--------------------------------------
hs
=
steps
g
s
$
both
f
(
head
es
,
last
es
)
--------------------------------------
inPeriode
::
Ord
b
=>
(
t
->
b
)
->
[
t
]
->
(
b
,
b
)
->
[
t
]
inPeriode
f'
h
(
start
,
end
)
=
fst
$
List
.
partition
(
\
d
->
f'
d
>=
start
&&
f'
d
<=
end
)
h
--------------------------------------
steps
::
(
Eq
date
,
Enum
date
)
=>
Grain
->
Step
->
(
date
,
date
)
->
[(
date
,
date
)]
steps
s'
o'
(
start
,
end
)
=
map
(
\
l
->
(
head
l
,
last
l
))
$
chunkAlong
s'
o'
[
start
..
end
]
--------------------------------------
-- | To parse a list of Documents by filtering on a Vector of Ngrams
parseDocs
::
PhyloNgrams
->
[
Document
]
->
[
Document
]
parseDocs
l
docs
=
map
(
\
(
Document
d
t
)
->
Document
d
(
unwords
parseDocs
::
(
Ngrams
->
Ngrams
)
->
Vector
Ngrams
->
[
Document
]
->
[
Document
]
parseDocs
f
l
docs
=
map
(
\
(
Document
d
t
)
->
Document
d
(
unwords
-- | To do : change 'f' for the Ngrams Tree Agregation
$
map
f
$
filter
(
\
x
->
Vector
.
elem
x
l
)
$
monoTexts
t
))
docs
-- | To group a list of Documents by fixed periods
groupDocsByPeriod
::
Grain
->
Step
->
[
Document
]
->
PhyloNgrams
->
Map
(
Date
,
Date
)
[
Document
]
groupDocsByPeriod
g
s
docs
ngrams
=
docsToPeriods
date
g
s
$
parseDocs
ngrams
docs
-- | To transform a corpus of texts into a structured list of Documents
corpusToDocs
::
[(
Date
,
Text
)]
->
[
Document
]
corpusToDocs
l
=
map
(
\
(
d
,
t
)
->
Document
d
t
)
l
\ No newline at end of file
-- | To transform a Corpus of texts into a Map of aggregated Documents grouped by Periods
corpusToDocs
::
(
Ngrams
->
Ngrams
)
->
[(
Date
,
Text
)]
->
Phylo
->
Map
(
Date
,
Date
)
[
Document
]
corpusToDocs
f
c
p
=
groupDocsByPeriod
date
(
getPhyloPeriods
p
)
$
parseDocs
f
(
getFoundations
p
)
docs
where
--------------------------------------
docs
::
[
Document
]
docs
=
map
(
\
(
d
,
t
)
->
Document
d
t
)
c
--------------------------------------
\ No newline at end of file
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/BranchMaker.hs
View file @
9dec48f6
...
...
@@ -60,5 +60,5 @@ groupsToGraph (prox,param) groups p = (groups,edges)
-- | To set all the PhyloBranches for a given Level in a Phylo
setPhyloBranches
::
Level
->
Phylo
->
Phylo
setPhyloBranches
lvl
p
=
alterPhyloBranches
(
\
l
->
l
++
(
graphToBranches
lvl
(
groupsToGraph
(
FromPairs
,
[]
)
(
getGroupsWithLevel
lvl
p
)
p
)
p
)
)
p
\ No newline at end of file
-- setPhyloBranches :: Level -> Phylo -> Phylo
-- setPhyloBranches lvl p = alterPhyloBranches (\l -> l ++ (graphToBranches lvl (groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p) p) ) p
\ No newline at end of file
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Example.hs
View file @
9dec48f6
...
...
@@ -31,7 +31,7 @@ module Gargantext.Viz.Phylo.Example where
import
Control.Lens
hiding
(
makeLenses
,
both
,
Level
)
import
Data.Bool
(
Bool
,
not
)
import
Data.List
(
concat
,
union
,
intersect
,
tails
,
tail
,
head
,
last
,
null
,
zip
,
sort
,
length
,
any
,
(
++
),
(
!!
),
nub
,
sortOn
,
reverse
,
splitAt
,
take
,
delete
,
init
,
groupBy
)
import
Data.List
(
notElem
,
concat
,
union
,
intersect
,
tails
,
tail
,
head
,
last
,
null
,
zip
,
sort
,
length
,
any
,
(
++
),
(
!!
),
nub
,
sortOn
,
reverse
,
splitAt
,
take
,
delete
,
init
,
groupBy
)
import
Data.Map
(
Map
,
elems
,
member
,
adjust
,
singleton
,
empty
,
(
!
),
keys
,
restrictKeys
,
mapWithKey
,
filterWithKey
,
mapKeys
,
intersectionWith
,
unionWith
)
import
Data.Semigroup
(
Semigroup
)
import
Data.Set
(
Set
)
...
...
@@ -76,17 +76,17 @@ getBranchPeriods b = nub $ map (fst . fst) $ getBranchGroupIds b
-- | To get all the single PhyloPeriodIds covered by a PhyloBranch
getBranchGroupIds
::
PhyloBranch
->
[
PhyloGroupId
]
getBranchGroupIds
b
=
_phylo_branchGroups
b
getBranchGroupIds
=
_phylo_branchGroups
-- | To transform a list of Ngrams Indexes into a Label
ngramsToLabel
::
[
Int
]
->
PhyloNgrams
->
Text
ngramsToLabel
l
ngrams
=
unwords
$
ngramsToText
l
ngrams
ngramsToLabel
::
Vector
Ngrams
->
[
Int
]
->
Text
ngramsToLabel
ngrams
l
=
unwords
$
ngramsToText
ngrams
l
-- | To transform a list of Ngrams Indexes into a list of Text
ngramsToText
::
[
Int
]
->
PhyloNgrams
->
[
Text
]
ngramsToText
l
ngrams
=
map
(
\
idx
->
ngrams
Vector
.!
idx
)
l
ngramsToText
::
Vector
Ngrams
->
[
Int
]
->
[
Text
]
ngramsToText
ngrams
l
=
map
(
\
idx
->
ngrams
Vector
.!
idx
)
l
-- | To get the nth most frequent Ngrams in a list of PhyloGroups
...
...
@@ -109,23 +109,33 @@ mostOccNgrams thr group = (nub . concat )
$
reverse
$
sortOn
snd
$
Map
.
toList
$
getGroupCooc
group
freqToLabel
::
Int
->
[
PhyloGroup
]
->
Vector
Ngrams
->
Text
freqToLabel
thr
l
ngs
=
ngramsToLabel
ngs
$
mostFreqNgrams
thr
l
filterLoneBranches
::
Int
->
Int
->
Int
->
[
PhyloPeriod
]
->
[
PhyloBranch
]
-- | To filter a list of Branches by avoiding the lone's one (ie: with just a few phyloGroups in the middle of the whole timeline)
filterLoneBranches
::
Int
->
Int
->
Int
->
[
PhyloPeriodId
]
->
[
PhyloBranch
]
->
[
PhyloBranch
]
filterLoneBranches
nbPinf
nbPsup
nbG
periods
branches
=
filter
(
not
.
isLone
)
branches
where
isLone
::
PhyloBranch
->
Boolean
isLone
b
=
((
length
.
getBranchGroups
)
b
<=
nbG
)
where
--------------------------------------
isLone
::
PhyloBranch
->
Bool
isLone
b
=
((
length
.
getBranchGroupIds
)
b
<=
nbG
)
&&
notElem
((
head
.
getBranchPeriods
)
b
)
(
take
nbPinf
periods
)
&&
notElem
((
head
.
getBranchPeriods
)
b
)
(
take
nbPsup
reverse
periods
)
&&
notElem
((
head
.
getBranchPeriods
)
b
)
(
take
nbPsup
$
reverse
periods
)
--------------------------------------
-- alterBranchLabel :: (Int -> [PhyloGroup] -> Vector Ngrams -> Text) -> PhyloBranch -> Phylo -> PhyloBranch
-- alterBranchLabel f b p = over (phylo_branchLabel) (\lbl -> f 2 (getGroupsFromIds (getBranchGroupIds b) p) (getVector Ngrams p)) b
toPhyloView
::
Level
->
Phylo
->
[
PhyloBranch
]
toPhyloView
lvl
p
=
branchesLbl
where
branchesLbl
=
map
(
\
b
->
over
(
phylo_branchLabel
)
(
\
lbl
->
"toto"
)
b
)
branches
branches
=
filter
(
\
b
->
(
fst
.
_phylo_branchId
)
b
==
lvl
)
$
getPhyloBranches
p
-- toPhyloView1 :: Level -> Phylo -> [PhyloBranch]
-- toPhyloView1 lvl p = bs
-- where
-- bs = map (\b -> alterBranchLabel freqToLabel b p)
-- $ filterLoneBranches 1 1 1 (getPhyloPeriods p)
-- $ filter (\b -> (fst . _phylo_branchId) b == lvl)
-- $ getPhyloBranches p
view1
=
toPhyloView
2
phylo3
-- view1 = toPhyloView1
2 phylo3
------------------------------------------------------------------------
-- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
...
...
@@ -136,8 +146,7 @@ phylo6 = toNthLevel 6 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) (Wei
phylo3
::
Phylo
phylo3
=
setPhyloBranches
3
$
pairGroupsToGroups
Childs
3
(
WeightedLogJaccard
,[
0.01
,
0
])
phylo3
=
pairGroupsToGroups
Childs
3
(
WeightedLogJaccard
,[
0.01
,
0
])
$
pairGroupsToGroups
Parents
3
(
WeightedLogJaccard
,[
0.01
,
0
])
$
setLevelLinks
(
2
,
3
)
$
addPhyloLevel
3
...
...
@@ -149,7 +158,8 @@ phylo3 = setPhyloBranches 3
-- | STEP 10 | -- Cluster the Fis
phyloBranch2
::
Phylo
phyloBranch2
=
setPhyloBranches
2
phylo2_c
phyloBranch2
=
phylo2_c
-- phyloBranch2 = setPhyloBranches 2 phylo2_c
phylo2_c
::
Phylo
...
...
@@ -177,8 +187,10 @@ phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0.01,0]) (RelatedComponent
-- | STEP 9 | -- Find the Branches
phyloBranch1
::
Phylo
phyloBranch1
=
setPhyloBranches
1
phylo1_c
phyloBranch1
=
phylo1_c
-- phyloBranch1 :: Phylo
-- phyloBranch1 = setPhyloBranches 1 phylo1_c
------------------------------------------------------------------------
...
...
@@ -214,7 +226,7 @@ phylo1_1_0 = setLevelLinks (1,0) phylo1
phylo1
::
Phylo
phylo1
=
addPhyloLevel
(
1
)
phyloFis
phylo
0_m1_0
phylo1
=
addPhyloLevel
(
1
)
phyloFis
phylo
------------------------------------------------------------------------
...
...
@@ -226,46 +238,36 @@ phyloFis = filterFisBySupport False 1 (filterFisByNested (docsToFis phyloDocs))
------------------------------------------------------------------------
-- | STEP 4 | -- Link level 0 to level -1 and reverse
phylo0_m1_0
::
Phylo
phylo0_m1_0
=
setLevelLinks
((
-
1
),
0
)
phylo0_0_m1
phylo0_0_m1
::
Phylo
phylo0_0_m1
=
setLevelLinks
(
0
,(
-
1
))
phylo0
-- | STEP 2 | -- Init a Phylo of level 0
------------------------------------------------------------------------
-- | STEP 3 | -- Build level 0 as a copy of level -1
-- | To do : build a real level 0 !
-- phylo' :: Phylo
-- phylo' = initPhylo 5 3 corpus actants groupNgramsWithTrees
-- | To clone the last PhyloLevel of each PhyloPeriod and update it with a new LevelValue
clonePhyloLevel
::
Level
->
Phylo
->
Phylo
clonePhyloLevel
lvl
p
=
alterPhyloLevels
(
\
l
->
l
++
[
setPhyloLevelId
lvl
$
head
l
])
p
phylo
::
Phylo
phylo
=
addPhyloLevel
0
phyloDocs
phyloBase
phylo
0
::
Phylo
phylo
0
=
clonePhyloLevel
0
phylo
phylo
Docs
::
Map
(
Date
,
Date
)
[
Document
]
phylo
Docs
=
corpusToDocs
groupNgramsWithTrees
corpus
phyloBase
------------------------------------------------------------------------
-- | STEP
2 | -- Init a Phylo of level -1 with the Documents
-- | STEP
1 | -- Init the Base of the Phylo from Periods and Foundations
phylo
::
Phylo
phylo
=
addPhyloLevel
(
-
1
)
phyloDocs
$
initPhylo
(
keys
phyloDocs
)
(
initNgrams
actants
)
phyloBase
::
Phylo
phyloBase
=
initPhyloBase
periods
foundations
------------------------------------------------------------------------
-- | STEP 1 | -- Parse all the Documents and group them by Period
periods
::
[(
Date
,
Date
)]
periods
=
initPeriods
5
3
$
both
fst
(
head
corpus
,
last
corpus
)
phyloDocs
::
Map
(
Date
,
Date
)
[
Document
]
phyloDocs
=
groupDocsByPeriod
5
3
(
corpusToDocs
corpus
)
(
initNgrams
actants
)
foundations
::
Vector
Ngrams
foundations
=
initFoundations
actants
------------------------------------------------------------------------
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/LevelMaker.hs
View file @
9dec48f6
...
...
@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.LevelMaker
where
import
Control.Lens
hiding
(
both
,
Level
)
import
Data.List
((
++
),
sort
,
concat
,
nub
,
words
,
zip
)
import
Data.List
((
++
),
sort
,
concat
,
nub
,
words
,
zip
,
head
,
last
)
import
Data.Map
(
Map
,
(
!
),
empty
,
restrictKeys
,
filterWithKey
,
singleton
,
union
)
import
Data.Set
(
Set
)
import
Data.Text
(
Text
,
words
)
...
...
@@ -27,6 +27,7 @@ import Data.Tuple.Extra
import
Gargantext.Prelude
hiding
(
head
)
import
Gargantext.Viz.Phylo.Aggregates.Cluster
import
Gargantext.Viz.Phylo.Aggregates.Cooc
import
Gargantext.Viz.Phylo.Aggregates.Document
import
Gargantext.Viz.Phylo
import
Gargantext.Viz.Phylo.Tools
import
Gargantext.Viz.Phylo.LinkMaker
...
...
@@ -78,8 +79,8 @@ instance PhyloLevelMaker Document
--------------------------------------
-- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
addPhyloLevel
lvl
m
p
|
lvl
<
0
=
toPhyloLevel
lvl
m
p
|
otherwise
=
panic
(
"[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <>
-1
"
)
|
lvl
==
0
=
toPhyloLevel
lvl
m
p
|
otherwise
=
panic
(
"[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <>
0
"
)
--------------------------------------
-- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
toPhyloGroups
lvl
(
d
,
d'
)
l
m
p
=
map
(
\
(
idx
,
ngram
)
->
ngramsToGroup
(
d
,
d'
)
lvl
idx
ngram
[
ngram
]
p
)
...
...
@@ -113,7 +114,7 @@ cliqueToGroup prd lvl idx lbl fis m p =
where
--------------------------------------
ngrams
::
[
Int
]
ngrams
=
sort
$
map
(
\
x
->
ngramsToIdx
x
p
)
ngrams
=
sort
$
map
(
\
x
->
getIdxInFoundations
x
p
)
$
Set
.
toList
$
fst
fis
--------------------------------------
...
...
@@ -126,7 +127,7 @@ cliqueToGroup prd lvl idx lbl fis m p =
-- | To transform a list of Ngrams into a PhyloGroup
ngramsToGroup
::
PhyloPeriodId
->
Level
->
Int
->
Text
->
[
Ngrams
]
->
Phylo
->
PhyloGroup
ngramsToGroup
prd
lvl
idx
lbl
ngrams
p
=
PhyloGroup
((
prd
,
lvl
),
idx
)
lbl
(
sort
$
map
(
\
x
->
ngramsToIdx
x
p
)
ngrams
)
empty
empty
[]
[]
[]
[]
PhyloGroup
((
prd
,
lvl
),
idx
)
lbl
(
sort
$
map
(
\
x
->
getIdxInFoundations
x
p
)
ngrams
)
empty
empty
[]
[]
[]
[]
-- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
...
...
@@ -140,14 +141,23 @@ toPhyloLevel lvl m p = alterPhyloPeriods
)
period
)
p
initPhylo
::
Grain
->
Step
->
[(
Date
,
Text
)]
->
[
Ngrams
]
->
(
Ngrams
->
Ngrams
)
->
Phylo
initPhylo
g
s
c
a
f
=
addPhyloLevel
0
(
corpusToDocs
f
c
base
)
base
where
--------------------------------------
base
::
Phylo
base
=
initPhyloBase
(
initPeriods
g
s
$
both
fst
(
head
c
,
last
c
))
(
initFoundations
a
)
--------------------------------------
-- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
toNthLevel
::
Level
->
(
Proximity
,[
Double
])
->
(
Clustering
,[
Double
])
->
(
Proximity
,[
Double
])
->
Phylo
->
Phylo
toNthLevel
lvlMax
(
prox
,
param1
)
(
clus
,
param2
)
(
prox'
,
param3
)
p
|
lvl
>=
lvlMax
=
p
|
otherwise
=
toNthLevel
lvlMax
(
prox
,
param1
)
(
clus
,
param2
)
(
prox'
,
param3
)
-- $ setPhyloBranches (lvl + 1)
$
pairGroupsToGroups
Childs
(
lvl
+
1
)
(
prox'
,
param3
)
$
pairGroupsToGroups
Parents
(
lvl
+
1
)
(
prox'
,
param3
)
$
setPhyloBranches
(
lvl
+
1
)
$
setLevelLinks
(
lvl
,
lvl
+
1
)
$
addPhyloLevel
(
lvl
+
1
)
(
phyloToClusters
lvl
(
prox
,
param1
)
(
clus
,
param2
)
p
)
p
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Metrics/Clustering.hs
View file @
9dec48f6
...
...
@@ -59,12 +59,6 @@ relatedComp idx curr (nodes,edges) next memo
--------------------------------------
{-
louvain :: (PhyloNodes,PhyloEdges) -> [Cluster]
louvain (nodes,edges) = undefined
-}
louvain
::
(
PhyloNodes
,
PhyloEdges
)
->
IO
[[
PhyloGroup
]]
louvain
(
nodes
,
edges
)
=
map
(
\
community
->
map
(
\
node
->
nodes
!!
(
l_node_id
node
))
community
)
<$>
groupBy
(
\
a
b
->
(
l_community_id
a
)
==
(
l_community_id
b
))
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Viz/Phylo/Tools.hs
View file @
9dec48f6
...
...
@@ -59,8 +59,8 @@ alterPhyloPeriods f p = over ( phylo_periods
-- | To alter the list of PhyloBranches of a Phylo
alterPhyloBranches
::
([
PhyloBranch
]
->
[
PhyloBranch
])
->
Phylo
->
Phylo
alterPhyloBranches
f
p
=
over
(
phylo_branches
)
f
p
--
alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
--
alterPhyloBranches f p = over ( phylo_branches ) f p
-- | To alter a list of PhyloLevels following a given function
...
...
@@ -118,6 +118,18 @@ filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
filterPhyloEdges
thr
edges
=
filter
(
\
((
s
,
t
),
w
)
->
w
>
thr
)
edges
-- | To get the foundations of a Phylo
getFoundations
::
Phylo
->
Vector
Ngrams
getFoundations
=
_phylo_foundations
-- | To get the Index of a Ngrams in the Foundations of a Phylo
getIdxInFoundations
::
Ngrams
->
Phylo
->
Int
getIdxInFoundations
n
p
=
case
(
elemIndex
n
(
getFoundations
p
))
of
Nothing
->
panic
"[ERR][Viz.Phylo.Tools.getFoundationIdx] Ngrams not in Foundations"
Just
idx
->
idx
-- | To get the PhyloGroups Childs of a PhyloGroup
getGroupChilds
::
PhyloGroup
->
Phylo
->
[
PhyloGroup
]
getGroupChilds
g
p
=
getGroupsFromIds
(
map
fst
$
_phylo_groupPeriodChilds
g
)
p
...
...
@@ -193,13 +205,6 @@ getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
-- | To get all the PhyloGroup of a Phylo with a given Period
getGroupsWithPeriod
::
(
Date
,
Date
)
->
Phylo
->
[
PhyloGroup
]
getGroupsWithPeriod
prd
p
=
filterGroups
getGroupPeriod
prd
(
getGroups
p
)
-- | To get the index of an element of a Vector
getIdx
::
Eq
a
=>
a
->
Vector
a
->
Int
getIdx
x
v
=
case
(
elemIndex
x
v
)
of
Nothing
->
panic
"[ERR][Viz.Phylo.Tools.getIndex] Nothing"
Just
i
->
i
-- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
...
...
@@ -236,8 +241,8 @@ getNeighbours directed g e = case directed of
-- | To get the Branches of a Phylo
getPhyloBranches
::
Phylo
->
[
PhyloBranch
]
getPhyloBranches
=
_phylo_branches
--
getPhyloBranches :: Phylo -> [PhyloBranch]
--
getPhyloBranches = _phylo_branches
-- | To get the PhylolevelId of a given PhyloLevel
...
...
@@ -250,11 +255,6 @@ getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
getPhyloLevels
=
view
(
phylo_periodLevels
)
-- | To get the Ngrams of a Phylo
getPhyloNgrams
::
Phylo
->
PhyloNgrams
getPhyloNgrams
=
_phylo_ngrams
-- | To get all the PhyloPeriodIds of a Phylo
getPhyloPeriods
::
Phylo
->
[
PhyloPeriodId
]
getPhyloPeriods
p
=
map
_phylo_periodId
...
...
@@ -266,26 +266,27 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
getPhyloPeriodId
prd
=
_phylo_periodId
prd
-- | To init the foundation of the Phylo as a Vector of Ngrams
initFoundations
::
[
Ngrams
]
->
Vector
Ngrams
initFoundations
l
=
Vector
.
fromList
$
map
toLower
l
-- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
initGroup
::
[
Ngrams
]
->
Text
->
Int
->
Int
->
Int
->
Int
->
Phylo
->
PhyloGroup
initGroup
ngrams
lbl
idx
lvl
from
to
p
=
PhyloGroup
(((
from
,
to
),
lvl
),
idx
)
lbl
(
sort
$
map
(
\
x
->
ngramsToIdx
x
p
)
ngrams
)
(
sort
$
map
(
\
x
->
getIdxInFoundations
x
p
)
ngrams
)
(
Map
.
empty
)
(
Map
.
empty
)
[]
[]
[]
[]
-- | To init
a PhyloNgrams as a Vector of Ngrams
init
Ngrams
::
[
Ngrams
]
->
PhyloNgrams
init
Ngrams
l
=
Vector
.
fromList
$
map
toLower
l
-- | To init
the Base of a Phylo from a List of Periods and Foundations
init
PhyloBase
::
[(
Date
,
Date
)]
->
Vector
Ngrams
->
Phylo
init
PhyloBase
pds
fds
=
Phylo
((
fst
.
head
)
pds
,
(
snd
.
last
)
pds
)
fds
(
map
(
\
pd
->
initPhyloPeriod
pd
[]
)
pds
)
-- | To create a Phylo from a list of PhyloPeriods and Ngrams
initPhylo
::
[(
Date
,
Date
)]
->
PhyloNgrams
->
Phylo
initPhylo
l
ngrams
=
Phylo
((
fst
.
head
)
l
,
(
snd
.
last
)
l
)
ngrams
(
map
(
\
prd
->
initPhyloPeriod
prd
[]
)
l
)
[]
-- | To create a PhyloLevel
initPhyloLevel
::
PhyloLevelId
->
[
PhyloGroup
]
->
PhyloLevel
initPhyloLevel
id
groups
=
PhyloLevel
id
groups
...
...
@@ -323,11 +324,6 @@ listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
listToUnDirectedCombiWith
f
l
=
[
(
f
x
,
f
y
)
|
(
x
:
rest
)
<-
tails
l
,
y
<-
rest
]
-- | To transform an Ngrams into its corresponding index in a Phylo
ngramsToIdx
::
Ngrams
->
Phylo
->
Int
ngramsToIdx
x
p
=
getIdx
x
(
_phylo_ngrams
p
)
-- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
setPhyloLevelId
::
Int
->
PhyloLevel
->
PhyloLevel
setPhyloLevelId
lvl'
(
PhyloLevel
(
id
,
lvl
)
groups
)
...
...
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