]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Viz/Graph/API.hs
[FEAT] Adding Visio micro-service (Jitsi)
[gargantext.git] / src / Gargantext / Core / Viz / Graph / API.hs
1 {-|
2 Module : Gargantext.Core.Viz.Graph
3 Description :
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12
13 {-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
14 {-# LANGUAGE TypeOperators #-}
15
16 module Gargantext.Core.Viz.Graph.API
17 where
18
19 import Control.Lens (set, (^.), _Just, (^?))
20 import Data.Aeson
21 import Data.Maybe (fromMaybe)
22 import Data.Swagger
23 import Data.Text
24 import Debug.Trace (trace)
25 import GHC.Generics (Generic)
26 import Gargantext.API.Admin.Orchestrator.Types
27 import Gargantext.API.Ngrams.Tools
28 import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
29 import Gargantext.API.Prelude
30 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
31 import Gargantext.Core.Types.Main
32 import Gargantext.Core.Viz.Graph
33 import Gargantext.Core.Viz.Graph.GEXF ()
34 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
35 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
36 import Gargantext.Database.Action.Node (mkNodeWithParent)
37 import Gargantext.Database.Admin.Config
38 import Gargantext.Database.Admin.Types.Node
39 import Gargantext.Database.Prelude (Cmd)
40 import Gargantext.Database.Query.Table.Node
41 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
42 import Gargantext.Database.Query.Table.Node.Select
43 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
44 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
45 import Gargantext.Database.Schema.Ngrams
46 import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata, node_name, node_user_id)
47 import Gargantext.Prelude
48 import Servant
49 import Servant.Job.Async
50 import Servant.XML
51 import qualified Data.HashMap.Strict as HashMap
52 ------------------------------------------------------------------------
53 -- | There is no Delete specific API for Graph since it can be deleted
54 -- as simple Node.
55 type GraphAPI = Get '[JSON] HyperdataGraphAPI
56 :<|> "async" :> GraphAsyncAPI
57 :<|> "clone"
58 :> ReqBody '[JSON] HyperdataGraphAPI
59 :> Post '[JSON] NodeId
60 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
61 :<|> "versions" :> GraphVersionsAPI
62
63 data GraphVersions =
64 GraphVersions { gv_graph :: Maybe Int
65 , gv_repo :: Int
66 }
67 deriving (Show, Generic)
68
69 instance ToJSON GraphVersions
70 instance ToSchema GraphVersions
71
72 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
73 graphAPI u n = getGraph u n
74 :<|> graphAsync u n
75 :<|> graphClone u n
76 :<|> getGraphGexf u n
77 :<|> graphVersionsAPI u n
78
79 ------------------------------------------------------------------------
80 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
81 getGraph _uId nId = do
82 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
83 repo <- getRepo
84
85 let
86 graph = nodeGraph ^. node_hyperdata . hyperdataGraph
87 camera = nodeGraph ^. node_hyperdata . hyperdataCamera
88 cId = maybe (panic "[G.V.G.API] Node has no parent")
89 identity
90 $ nodeGraph ^. node_parent_id
91
92 -- TODO Distance in Graph params
93 case graph of
94 Nothing -> do
95 let defaultMetric = Order1
96 graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
97 mt <- defaultGraphMetadata cId "Title" repo defaultMetric
98 let
99 graph'' = set graph_metadata (Just mt) graph'
100 hg = HyperdataGraphAPI graph'' camera
101 -- _ <- updateHyperdata nId hg
102 _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
103 pure $ trace "[G.V.G.API] Graph empty, computing" hg
104
105 Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
106 HyperdataGraphAPI graph' camera
107
108
109 recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
110 recomputeGraph _uId nId maybeDistance = do
111 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
112 let
113 graph = nodeGraph ^. node_hyperdata . hyperdataGraph
114 camera = nodeGraph ^. node_hyperdata . hyperdataCamera
115 graphMetadata = graph ^? _Just . graph_metadata . _Just
116 listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
117 graphMetric = case maybeDistance of
118 Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
119 _ -> maybeDistance
120
121 repo <- getRepo
122 let
123 v = repo ^. r_version
124 cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
125 identity
126 $ nodeGraph ^. node_parent_id
127 similarity = case graphMetric of
128 Nothing -> withMetric Order1
129 Just m -> withMetric m
130
131 case graph of
132 Nothing -> do
133 graph' <- computeGraph cId similarity NgramsTerms repo
134 mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
135 let graph'' = set graph_metadata (Just mt) graph'
136 _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
137 pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
138
139 Just graph' -> if listVersion == Just v
140 then pure graph'
141 else do
142 graph'' <- computeGraph cId similarity NgramsTerms repo
143 let graph''' = set graph_metadata graphMetadata graph''
144 _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
145 pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
146
147
148 -- TODO use Database Monad only here ?
149 computeGraph :: HasNodeError err
150 => CorpusId
151 -> Distance
152 -> NgramsType
153 -> NgramsRepo
154 -> Cmd err Graph
155 computeGraph cId d nt repo = do
156 lId <- defaultList cId
157 lIds <- selectNodesWithUsername NodeList userMaster
158
159 let ngs = filterListWithRoot MapTerm
160 $ mapTermListRoot [lId] nt repo
161
162 myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
163 <$> getCoocByNgrams (Diagonal True)
164 <$> groupNodesByNgrams ngs
165 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
166
167 -- printDebug "myCooc" myCooc
168 -- saveAsFileDebug "debug/my-cooc" myCooc
169
170 graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
171 -- saveAsFileDebug "debug/graph" graph
172 pure graph
173
174
175 defaultGraphMetadata :: HasNodeError err
176 => CorpusId
177 -> Text
178 -> NgramsRepo
179 -> GraphMetric
180 -> Cmd err GraphMetadata
181 defaultGraphMetadata cId t repo gm = do
182 lId <- defaultList cId
183
184 pure $ GraphMetadata {
185 _gm_title = t
186 , _gm_metric = gm
187 , _gm_corpusId = [cId]
188 , _gm_legend = [
189 LegendField 1 "#FFF" "Cluster1"
190 , LegendField 2 "#FFF" "Cluster2"
191 , LegendField 3 "#FFF" "Cluster3"
192 , LegendField 4 "#FFF" "Cluster4"
193 ]
194 , _gm_list = (ListForGraph lId (repo ^. r_version))
195 , _gm_startForceAtlas = True
196 }
197 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
198
199
200 ------------------------------------------------------------
201 type GraphAsyncAPI = Summary "Recompute graph"
202 :> "recompute"
203 :> AsyncJobsAPI JobLog () JobLog
204
205
206 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
207 graphAsync u n =
208 serveJobsAPI $
209 JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
210
211
212 graphRecompute :: UserId
213 -> NodeId
214 -> (JobLog -> GargNoServer ())
215 -> GargNoServer JobLog
216 graphRecompute u n logStatus = do
217 logStatus JobLog { _scst_succeeded = Just 0
218 , _scst_failed = Just 0
219 , _scst_remaining = Just 1
220 , _scst_events = Just []
221 }
222 _g <- trace (show u) $ recomputeGraph u n Nothing
223 pure JobLog { _scst_succeeded = Just 1
224 , _scst_failed = Just 0
225 , _scst_remaining = Just 0
226 , _scst_events = Just []
227 }
228
229 ------------------------------------------------------------
230 type GraphVersionsAPI = Summary "Graph versions"
231 :> Get '[JSON] GraphVersions
232 :<|> Summary "Recompute graph version"
233 :> Post '[JSON] Graph
234
235 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
236 graphVersionsAPI u n =
237 graphVersions n
238 :<|> recomputeVersions u n
239
240 graphVersions :: NodeId -> GargNoServer GraphVersions
241 graphVersions nId = do
242 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
243 let
244 graph = nodeGraph
245 ^. node_hyperdata
246 . hyperdataGraph
247
248 listVersion = graph
249 ^? _Just
250 . graph_metadata
251 . _Just
252 . gm_list
253 . lfg_version
254
255 repo <- getRepo
256 let v = repo ^. r_version
257
258 pure $ GraphVersions { gv_graph = listVersion
259 , gv_repo = v }
260
261 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
262 recomputeVersions uId nId = recomputeGraph uId nId Nothing
263
264 ------------------------------------------------------------
265 graphClone :: UserId
266 -> NodeId
267 -> HyperdataGraphAPI
268 -> GargNoServer NodeId
269 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
270 , _hyperdataAPICamera = camera }) = do
271 let nodeType = NodeGraph
272 nodeUser <- getNodeUser (NodeId uId)
273 nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
274 let uId' = nodeUser ^. node_user_id
275 nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
276 case nIds of
277 [] -> pure pId
278 (nId:_) -> do
279 let graphP = graph
280 let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
281
282 _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
283
284 pure nId
285
286 ------------------------------------------------------------
287 getGraphGexf :: UserId
288 -> NodeId
289 -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
290 getGraphGexf uId nId = do
291 HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
292 pure $ addHeader "attachment; filename=graph.gexf" graph
293
294
295
296
297
298