1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
{-|
Module : Gargantext.Core.Viz.Graph
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.Viz.Graph.API
where
import Control.Lens (set, _Just, (^?), at)
import Data.HashMap.Strict qualified as HashMap
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Routes.Named.Viz qualified as Named
import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
import Gargantext.Core.NodeStory.Types ( HasNodeStory, a_version, unNodeStory, NodeListStory )
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types.Main ( ListType(MapTerm) )
import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Core.Viz.Graph.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config ( userMaster )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd, DBCmd')
import Gargantext.Database.Query.Table.Node ( getOrMkList, getNodeWith, defaultList, getClosestParentIdByType )
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata, node_name)
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant
import Servant.Server.Generic (AsServerT)
------------------------------------------------------------------------
--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
getGraph :: HasNodeStory env err m
=> NodeId
-> m HyperdataGraphAPI
getGraph nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
camera = nodeGraph ^. node_hyperdata . hyperdataCamera
mcId <- getClosestParentIdByType nId NodeCorpus
let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
-- printDebug "[getGraph] getting list for cId" cId
listId <- defaultList cId
repo <- getRepo [listId]
-- TODO Similarity in Graph params
case graph of
Nothing -> do
let defaultMetric = Order1
let defaultPartitionMethod = Spinglass
let defaultEdgesStrength = Strong
let defaultBridgenessMethod = BridgenessMethod_Basic
graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
mt <- defaultGraphMetadata cId listId "Title" repo defaultMetric defaultEdgesStrength
let
graph'' = set graph_metadata (Just mt) graph'
hg = HyperdataGraphAPI graph'' camera
-- _ <- updateHyperdata nId hg
_ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
pure $ trace ("[G.V.G.API] Graph empty, computing" :: Text) hg
Just graph' -> pure $ trace ("[G.V.G.API] Graph exists, returning" :: Text) $
HyperdataGraphAPI graph' camera
--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
recomputeGraph :: HasNodeStory env err m
=> NodeId
-> PartitionMethod
-> BridgenessMethod
-> Maybe GraphMetric
-> Maybe Strength
-> NgramsType
-> NgramsType
-> Bool
-> m Graph
recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force' = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
camera = nodeGraph ^. node_hyperdata . hyperdataCamera
graphMetadata = graph ^? _Just . graph_metadata . _Just
listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
graphMetric = case maybeSimilarity of
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
Just _ -> maybeSimilarity
similarity = case graphMetric of
Nothing -> withMetric Order1
Just m -> withMetric m
strength = case maybeStrength of
Nothing -> case graph ^? _Just . graph_metadata . _Just . gm_edgesStrength of
Nothing -> Strong
Just mr -> fromMaybe Strong mr
Just r -> r
mcId <- getClosestParentIdByType nId NodeCorpus
let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
listId <- defaultList cId
repo <- getRepo [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
let computeG mt = do
!g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
let g' = set graph_metadata mt g
_nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
pure g'
case graph of
Nothing -> do
mt <- defaultGraphMetadata cId listId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
g <- computeG $ Just mt
pure $ trace ("[G.V.G.API.recomputeGraph] Graph empty, computed" :: Text) g
Just graph' -> if (listVersion == Just v) && (not force')
then pure graph'
else do
g <- computeG graphMetadata
pure $ trace ("[G.V.G.API] Graph exists, recomputing" :: Text) g
-- TODO remove repo
computeGraph :: HasNodeError err
=> CorpusId
-> PartitionMethod
-> BridgenessMethod
-> Similarity
-> Strength
-> (NgramsType, NgramsType)
-> NodeListStory
-> DBCmd err Graph
computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
-- Getting the Node parameters
lId <- defaultList corpusId
lIds <- selectNodesWithUsername NodeList userMaster
-- Getting the Ngrams to compute with and grouping it according to the lists
let
groupedContextsByNgrams nt corpusId' (lists_master, lists_user) = do
let
ngs = filterListWithRoot [MapTerm] $ mapTermListRoot lists_user nt repo
groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser corpusId'
(lists_user <> lists_master) nt (HashMap.keys ngs)
-- Optim if nt1 == nt2 : do not compute twice
(m1,m2) <- do
m1 <- groupedContextsByNgrams nt1 corpusId (lIds, [lId])
if nt1 == nt2
then
pure (m1,m1)
else do
m2 <- groupedContextsByNgrams nt2 corpusId (lIds, [lId])
pure (m1,m2)
-- Removing the hapax (ngrams with 1 cooc)
let !myCooc = {- HashMap.filter (>0)
$ -} getCoocByNgrams'' (Diagonal True) (identity, identity) (m1,m2)
-- TODO MultiPartite Here
liftBase
$ cooc2graphWith partitionMethod bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
(Partite (HashMap.keysSet m2) nt2)
)
similarity 0 strength myCooc
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> ListId
-> Text
-> NodeListStory
-> GraphMetric
-> Strength
-> DBCmd err GraphMetadata
defaultGraphMetadata cId lId t repo gm str = do
pure $ GraphMetadata { _gm_title = t
, _gm_metric = gm
, _gm_edgesStrength = Just str
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version)
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
graphAsync :: NodeId -> Named.GraphAsyncAPI (AsServerT (GargM Env BackendInternalError))
graphAsync n = Named.GraphAsyncAPI $
serveJobsAPI RecomputeGraphJob $ \jHandle _ -> graphRecompute n jHandle
--graphRecompute :: UserId
-- -> NodeId
-- -> (JobLog -> GargNoServer ())
-- -> GargNoServer JobLog
-- TODO get Graph Metadata to recompute
graphRecompute :: (HasNodeStory env err m, MonadJobStatus m)
=> NodeId
-> JobHandle m
-> m ()
graphRecompute n jobHandle = do
markStarted 1 jobHandle
_g <- recomputeGraph n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
markComplete jobHandle
graphVersions :: (HasNodeStory env err m)
=> UserId
-> NodeId
-> m GraphVersions
graphVersions u nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graph = nodeGraph
^. node_hyperdata
. hyperdataGraph
listVersion = graph
^? _Just
. graph_metadata
. _Just
. gm_list
. lfg_version
mcId <- getClosestParentIdByType nId NodeCorpus
let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
listId <- getOrMkList cId u
repo <- getRepo [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
-- printDebug "graphVersions" v
pure $ GraphVersions { gv_graph = listVersion
, gv_repo = v }
recomputeVersions :: HasNodeStory env err m
=> NodeId
-> m Graph
recomputeVersions nId = recomputeGraph nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
------------------------------------------------------------
graphClone :: (HasNodeError err)
=> UserId
-> NodeId
-> HyperdataGraphAPI
-> DBCmd' env err NodeId
graphClone userId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
, _hyperdataAPICamera = camera }) = do
let nodeType = NodeGraph
nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
nIds <- mkNodeWithParent nodeType (Just pId) userId $ nodeParent ^. node_name
case nIds of
[] -> pure pId
(nId:_) -> do
let graphP = graph
let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
_ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
pure nId
------------------------------------------------------------
--getGraphGexf :: UserId
-- -> NodeId
-- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf :: HasNodeStory env err m
=> NodeId
-> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf nId = do
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph nId
pure $ addHeader "attachment; filename=graph.gexf" graph
------------------------------------------------------------
updateGraphLegend :: HasNodeError err
=> NodeId
-> GraphLegendAPI
-> DBCmd err NodeId
updateGraphLegend nId (GraphLegendAPI lg ) = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
case graph of
Nothing -> pure nId
Just g -> do
let graph' = set (graph_metadata . _Just . gm_legend) lg g
_ <- updateHyperdata nId (HyperdataGraph (Just graph') (nodeGraph ^. node_hyperdata . hyperdataCamera))
pure nId