Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
H
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
Przemyslaw Kaminski
haskell-gargantext
Commits
3ebf93a4
Commit
3ebf93a4
authored
Jan 21, 2019
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[GRAPH] API connected (needs bridgeness).
parent
f9c5e6da
Changes
3
Show whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
44 additions
and
44 deletions
+44
-44
Node.hs
src/Gargantext/API/Node.hs
+4
-6
Flow.hs
src/Gargantext/Database/Flow.hs
+13
-13
Flow.hs
src/Gargantext/Text/Flow.hs
+27
-25
No files found.
src/Gargantext/API/Node.hs
View file @
3ebf93a4
...
...
@@ -262,16 +262,14 @@ graphAPI nId = do
,
LegendField
5
"#FFF"
"Energy / Environment"
]
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
myCooc
<-
getCoocByDocDev
nId
<$>
defaultList
(
maybe
(
panic
"no parentId"
)
identity
$
_node_parentId
nodeGraph
)
myCooc'
<-
myCooc
--{-
let
cId
=
maybe
(
panic
"no parentId"
)
identity
$
_node_parentId
nodeGraph
lId
<-
defaultList
cId
myCooc
<-
getCoocByDocDev
cId
lId
liftIO
$
set
graph_metadata
(
Just
metadata
)
<$>
cooc2graph
myCooc
'
<$>
cooc2graph
myCooc
-- <$> maybe defaultGraph identity
-- <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
-- t <- textFlow (Mono EN) (Contexts contextText)
-- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
-- TODO what do we get about the node? to replace contextText
...
...
src/Gargantext/Database/Flow.hs
View file @
3ebf93a4
...
...
@@ -93,7 +93,7 @@ flowInsertAnnuaire name children = do
(
userId
,
_
,
userCorpusId
)
<-
subFlowAnnuaire
userArbitrary
name
_
<-
add
userCorpusId
(
map
reId
ids
)
printDebug
"AnnuaireID"
userCorpusId
--
printDebug "AnnuaireID" userCorpusId
pure
(
ids
,
masterUserId
,
masterCorpusId
,
userId
,
userCorpusId
)
...
...
@@ -102,11 +102,11 @@ flowCorpus' :: HasNodeError err
=>
NodeType
->
[
HyperdataDocument
]
->
([
ReturnId
],
UserId
,
CorpusId
,
UserId
,
CorpusId
)
->
Cmd
err
CorpusId
flowCorpus'
NodeCorpus
hyperdataDocuments
(
ids
,
masterUserId
,
masterCorpusId
,
userId
,
userCorpusId
)
=
do
flowCorpus'
NodeCorpus
hyperdataDocuments
(
ids
,
_masterUserId
,
_
masterCorpusId
,
userId
,
userCorpusId
)
=
do
--------------------------------------------------
-- List Ngrams Flow
userListId
<-
flowListUser
userId
userCorpusId
30
00
printDebug
"Working on User ListId : "
userListId
--userListId <- flowListUser userId userCorpusId 5
00
--
printDebug "Working on User ListId : " userListId
let
documentsWithId
=
mergeData
(
toInserted
ids
)
(
toInsert
hyperdataDocuments
)
-- printDebug "documentsWithId" documentsWithId
...
...
@@ -120,8 +120,8 @@ flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, user
-- printDebug "inserted ngrams" indexedNgrams
_
<-
insertToNodeNgrams
indexedNgrams
listId2
<-
flowList
masterUserId
masterCorpusId
indexedNgrams
printDebug
"Working on ListId : "
listId2
--
listId2 <- flowList masterUserId masterCorpusId indexedNgrams
--
printDebug "Working on ListId : " listId2
--}
--------------------------------------------------
_
<-
mkDashboard
userCorpusId
userId
...
...
@@ -170,8 +170,8 @@ subFlowCorpus username cName = do
corpusId
<-
maybe
(
nodeError
NoCorpusFound
)
pure
(
head
corpusId'
)
printDebug
"(username, userId, rootId, corpusId)"
(
username
,
userId
,
rootId
,
corpusId
)
--
printDebug "(username, userId, rootId, corpusId)"
--
(username, userId, rootId, corpusId)
pure
(
userId
,
rootId
,
corpusId
)
...
...
@@ -197,8 +197,8 @@ subFlowAnnuaire username _cName = do
corpusId
<-
maybe
(
nodeError
NoCorpusFound
)
pure
(
head
corpusId'
)
printDebug
"(username, userId, rootId, corpusId)"
(
username
,
userId
,
rootId
,
corpusId
)
--
printDebug "(username, userId, rootId, corpusId)"
--
(username, userId, rootId, corpusId)
pure
(
userId
,
rootId
,
corpusId
)
------------------------------------------------------------------------
...
...
@@ -267,7 +267,7 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
------------------------------------------------------------------------
flowList
::
HasNodeError
err
=>
UserId
->
CorpusId
->
Map
NgramsIndexed
(
Map
NgramsType
(
Map
NodeId
Int
))
->
Cmd
err
ListId
flowList
uId
cId
ngs
=
do
flowList
uId
cId
_
ngs
=
do
-- printDebug "ngs:" ngs
lId
<-
getOrMkList
cId
uId
--printDebug "ngs" (DM.keys ngs)
...
...
@@ -277,8 +277,8 @@ flowList uId cId ngs = do
-- _ <- insertGroups lId groupEd
-- compute Candidate / Map
is
<-
insertLists
lId
$
ngrams2list
ngs
printDebug
"listNgrams inserted :"
is
--
is <- insertLists lId $ ngrams2list ngs
--
printDebug "listNgrams inserted :" is
pure
lId
...
...
src/Gargantext/Text/Flow.hs
View file @
3ebf93a4
...
...
@@ -25,10 +25,10 @@ import Data.Text.IO (readFile)
import
Data.Map.Strict
(
Map
)
import
Data.Maybe
(
catMaybes
)
import
qualified
Data.Set
as
DS
--
import qualified Data.Set as DS
import
Data.Text
(
Text
)
import
qualified
Data.Array.Accelerate
as
A
--
import qualified Data.Array.Accelerate as A
import
qualified
Data.Map.Strict
as
M
----------------------------------------------
import
Database.PostgreSQL.Simple
(
Connection
)
...
...
@@ -50,7 +50,7 @@ import Gargantext.Core.Types (CorpusId)
import
Gargantext.Text.Parsers.CSV
import
Data.Graph.Clustering.Louvain.CplusPlus
(
cLouvain
,
l_community_id
)
import
Data.Graph.Clustering.Louvain.CplusPlus
(
cLouvain
)
{-
____ _ _
...
...
@@ -105,26 +105,26 @@ textFlow' termType contexts = do
-- TermsType = Mono | Multi | MonoMulti
-- myterms # filter (\t -> not . elem t stopList)
-- # groupBy (Stem|GroupList|Ontology)
printDebug
"terms"
myterms
printDebug
"myterms"
(
sum
$
map
length
myterms
)
--
printDebug "terms" myterms
--
printDebug "myterms" (sum $ map length myterms)
-- Bulding the map list
-- compute copresences of terms, i.e. cooccurrences of terms in same context of text
-- Cooc = Map (Term, Term) Int
let
myCooc1
=
cooc
myterms
printDebug
"myCooc1 size"
(
M
.
size
myCooc1
)
--
printDebug "myCooc1 size" (M.size myCooc1)
-- Remove Apax: appears one time only => lighting the matrix
let
myCooc2
=
M
.
filter
(
>
0
)
myCooc1
printDebug
"myCooc2 size"
(
M
.
size
myCooc2
)
printDebug
"myCooc2"
myCooc2
--
printDebug "myCooc2 size" (M.size myCooc2)
--
printDebug "myCooc2" myCooc2
g
<-
cooc2graph
myCooc2
pure
g
-- TODO use Text only here instead of [Text]
cooc2graph
::
(
Map
([
Text
],
[
Text
])
Int
)
->
IO
Graph
cooc2graph
myCooc
=
do
--printDebug "myCooc" myCooc
-- Filtering terms with inclusion/Exclusion and Specificity/Genericity scores
let
myCooc3
=
filterCooc
(
FilterConfig
(
MapListSize
350
)
(
InclusionSize
500
)
...
...
@@ -132,39 +132,41 @@ cooc2graph myCooc = do
(
Clusters
3
)
(
DefaultValue
0
)
)
myCooc
printDebug
"myCooc3 size"
$
M
.
size
myCooc3
printDebug
"myCooc3"
myCooc3
--
printDebug "myCooc3 size" $ M.size myCooc3
--
printDebug "myCooc3" myCooc3
-- Cooc -> Matrix
let
(
ti
,
_
)
=
createIndices
myCooc3
printDebug
"ti size"
$
M
.
size
ti
printDebug
"ti"
ti
--
printDebug "ti size" $ M.size ti
--
printDebug "ti" ti
let
myCooc4
=
toIndex
ti
myCooc3
printDebug
"myCooc4 size"
$
M
.
size
myCooc4
printDebug
"myCooc4"
myCooc4
--
printDebug "myCooc4 size" $ M.size myCooc4
--
printDebug "myCooc4" myCooc4
let
matCooc
=
map2mat
(
0
)
(
M
.
size
ti
)
myCooc4
printDebug
"matCooc shape"
$
A
.
arrayShape
matCooc
printDebug
"matCooc"
matCooc
--
printDebug "matCooc shape" $ A.arrayShape matCooc
--
printDebug "matCooc" matCooc
-- Matrix -> Clustering
let
distanceMat
=
measureConditional
matCooc
--let distanceMat = distributional matCooc
printDebug
"distanceMat shape"
$
A
.
arrayShape
distanceMat
printDebug
"distanceMat"
distanceMat
--
printDebug "distanceMat shape" $ A.arrayShape distanceMat
--
printDebug "distanceMat" distanceMat
--let distanceMap = M.filter (>0) $ mat2map distanceMat
let
distanceMap
=
M
.
map
(
\
_
->
1
)
$
M
.
filter
(
>
0
)
$
mat2map
distanceMat
printDebug
"distanceMap size"
$
M
.
size
distanceMap
printDebug
"distanceMap"
distanceMap
--
printDebug "distanceMap size" $ M.size distanceMap
--
printDebug "distanceMap" distanceMap
-- let distance = fromIndex fi distanceMap
--
printDebug "distance" $ M.size distance
--
printDebug "distance" $ M.size distance
partitions
<-
cLouvain
distanceMap
partitions
<-
case
M
.
size
distanceMap
>
0
of
True
->
cLouvain
distanceMap
False
->
panic
"Text.Flow: DistanceMap is empty"
-- Building : -> Graph -> JSON
printDebug
"partitions"
$
DS
.
size
$
DS
.
fromList
$
map
(
l_community_id
)
partitions
--
printDebug "partitions" $ DS.size $ DS.fromList $ map (l_community_id) partitions
--printDebug "partitions" partitions
pure
$
data2graph
(
M
.
toList
ti
)
myCooc4
distanceMap
partitions
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