]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Metrics.hs
[Clean] refact + toGroupedTree WIP
[gargantext.git] / src / Gargantext / API / Metrics.hs
1 {-|
2 Module : Gargantext.API.Metrics
3 Description : Server API
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Metrics API
11
12 -}
13
14 {-# OPTIONS_GHC -fno-warn-orphans #-}
15
16 {-# LANGUAGE TypeOperators #-}
17
18 module Gargantext.API.Metrics
19 where
20
21 import Control.Lens
22 import qualified Data.Map as Map
23 import Data.Text (Text)
24 import Data.Time (UTCTime)
25 import Servant
26
27 import Gargantext.API.HashedResponse
28 import Gargantext.API.Ngrams.NTree
29 import Gargantext.API.Ngrams.Types
30 import Gargantext.API.Prelude (GargServer)
31 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
32 import Gargantext.Database.Action.Flow
33 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
34 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
35 import Gargantext.Database.Admin.Types.Node (NodeId)
36 import Gargantext.Database.Prelude
37 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
38 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
39 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
40 import Gargantext.Database.Schema.Node (node_hyperdata)
41 import Gargantext.Prelude
42 import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
43 import Gargantext.Core.Viz.Chart
44 import Gargantext.Core.Viz.Types
45 import qualified Gargantext.Database.Action.Metrics as Metrics
46
47 -------------------------------------------------------------
48 -- | Scatter metrics API
49 type ScatterAPI = Summary "SepGen IncExc metrics"
50 :> QueryParam "list" ListId
51 :> QueryParamR "ngramsType" TabType
52 :> QueryParam "limit" Int
53 :> Get '[JSON] (HashedResponse Metrics)
54 :<|> Summary "Scatter update"
55 :> QueryParam "list" ListId
56 :> QueryParamR "ngramsType" TabType
57 :> QueryParam "limit" Int
58 :> Post '[JSON] ()
59 :<|> "hash" :> Summary "Scatter Hash"
60 :> QueryParam "list" ListId
61 :> QueryParamR "ngramsType" TabType
62 :> Get '[JSON] Text
63
64 scatterApi :: NodeId -> GargServer ScatterAPI
65 scatterApi id' = getScatter id'
66 :<|> updateScatter id'
67 :<|> getScatterHash id'
68
69 getScatter :: FlowCmdM env err m =>
70 CorpusId
71 -> Maybe ListId
72 -> TabType
73 -> Maybe Limit
74 -> m (HashedResponse Metrics)
75 getScatter cId maybeListId tabType _maybeLimit = do
76 listId <- case maybeListId of
77 Just lid -> pure lid
78 Nothing -> defaultList cId
79 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
80 let HyperdataList { _hl_scatter = scatterMap } = node ^. node_hyperdata
81 mChart = Map.lookup tabType scatterMap
82
83 chart <- case mChart of
84 Just chart -> pure chart
85 Nothing -> do
86 updateScatter' cId maybeListId tabType Nothing
87
88 pure $ constructHashedResponse chart
89
90 updateScatter :: FlowCmdM env err m =>
91 CorpusId
92 -> Maybe ListId
93 -> TabType
94 -> Maybe Limit
95 -> m ()
96 updateScatter cId maybeListId tabType maybeLimit = do
97 printDebug "[updateScatter] cId" cId
98 printDebug "[updateScatter] maybeListId" maybeListId
99 printDebug "[updateScatter] tabType" tabType
100 printDebug "[updateScatter] maybeLimit" maybeLimit
101 _ <- updateScatter' cId maybeListId tabType maybeLimit
102 pure ()
103
104 updateScatter' :: FlowCmdM env err m =>
105 CorpusId
106 -> Maybe ListId
107 -> TabType
108 -> Maybe Limit
109 -> m Metrics
110 updateScatter' cId maybeListId tabType maybeLimit = do
111 (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
112
113 let
114 metrics = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs'))
115 $ map normalizeLocal scores
116 listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
117 errorMsg = "API.Node.metrics: key absent"
118
119 listId <- case maybeListId of
120 Just lid -> pure lid
121 Nothing -> defaultList cId
122 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
123 let hl = node ^. node_hyperdata
124 scatterMap = hl ^. hl_scatter
125 _ <- updateHyperdata listId $ hl { _hl_scatter = Map.insert tabType (Metrics metrics) scatterMap }
126
127 pure $ Metrics metrics
128
129 getScatterHash :: FlowCmdM env err m =>
130 CorpusId
131 -> Maybe ListId
132 -> TabType
133 -> m Text
134 getScatterHash cId maybeListId tabType = do
135 hash <$> getScatter cId maybeListId tabType Nothing
136
137
138 -------------------------------------------------------------
139 -- | Chart metrics API
140 type ChartApi = Summary " Chart API"
141 :> QueryParam "from" UTCTime
142 :> QueryParam "to" UTCTime
143 :> QueryParam "list" ListId
144 :> QueryParamR "ngramsType" TabType
145 :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
146 :<|> Summary "Chart update"
147 :> QueryParam "list" ListId
148 :> QueryParamR "ngramsType" TabType
149 :> QueryParam "limit" Int
150 :> Post '[JSON] ()
151 :<|> "hash" :> Summary "Chart Hash"
152 :> QueryParam "list" ListId
153 :> QueryParamR "ngramsType" TabType
154 :> Get '[JSON] Text
155
156 chartApi :: NodeId -> GargServer ChartApi
157 chartApi id' = getChart id'
158 :<|> updateChart id'
159 :<|> getChartHash id'
160
161 -- TODO add start / end
162 getChart :: FlowCmdM env err m =>
163 CorpusId
164 -> Maybe UTCTime
165 -> Maybe UTCTime
166 -> Maybe ListId
167 -> TabType
168 -> m (HashedResponse (ChartMetrics Histo))
169 getChart cId _start _end maybeListId tabType = do
170 listId <- case maybeListId of
171 Just lid -> pure lid
172 Nothing -> defaultList cId
173 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
174 let chartMap = node ^. node_hyperdata ^. hl_chart
175 mChart = Map.lookup tabType chartMap
176
177 chart <- case mChart of
178 Just chart -> pure chart
179 Nothing -> do
180 updateChart' cId maybeListId tabType Nothing
181
182 pure $ constructHashedResponse chart
183
184 updateChart :: HasNodeError err =>
185 CorpusId
186 -> Maybe ListId
187 -> TabType
188 -> Maybe Limit
189 -> Cmd err ()
190 updateChart cId maybeListId tabType maybeLimit = do
191 printDebug "[updateChart] cId" cId
192 printDebug "[updateChart] maybeListId" maybeListId
193 printDebug "[updateChart] tabType" tabType
194 printDebug "[updateChart] maybeLimit" maybeLimit
195 _ <- updateChart' cId maybeListId tabType maybeLimit
196 pure ()
197
198 updateChart' :: HasNodeError err =>
199 CorpusId
200 -> Maybe ListId
201 -> TabType
202 -> Maybe Limit
203 -> Cmd err (ChartMetrics Histo)
204 updateChart' cId maybeListId tabType _maybeLimit = do
205 listId <- case maybeListId of
206 Just lid -> pure lid
207 Nothing -> defaultList cId
208 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
209 let hl = node ^. node_hyperdata
210 chartMap = hl ^. hl_chart
211 h <- histoData cId
212 _ <- updateHyperdata listId $ hl { _hl_chart = Map.insert tabType (ChartMetrics h) chartMap }
213
214 pure $ ChartMetrics h
215
216
217 getChartHash :: FlowCmdM env err m =>
218 CorpusId
219 -> Maybe ListId
220 -> TabType
221 -> m Text
222 getChartHash cId maybeListId tabType = do
223 hash <$> getChart cId Nothing Nothing maybeListId tabType
224
225 -------------------------------------------------------------
226 -- | Pie metrics API
227 type PieApi = Summary "Pie Chart"
228 :> QueryParam "from" UTCTime
229 :> QueryParam "to" UTCTime
230 :> QueryParam "list" ListId
231 :> QueryParamR "ngramsType" TabType
232 :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
233 :<|> Summary "Pie Chart update"
234 :> QueryParam "list" ListId
235 :> QueryParamR "ngramsType" TabType
236 :> QueryParam "limit" Int
237 :> Post '[JSON] ()
238 :<|> "hash" :> Summary "Pie Hash"
239 :> QueryParam "list" ListId
240 :> QueryParamR "ngramsType" TabType
241 :> Get '[JSON] Text
242
243 pieApi :: NodeId -> GargServer PieApi
244 pieApi id' = getPie id'
245 :<|> updatePie id'
246 :<|> getPieHash id'
247
248 getPie :: FlowCmdM env err m
249 => CorpusId
250 -> Maybe UTCTime
251 -> Maybe UTCTime
252 -> Maybe ListId
253 -> TabType
254 -> m (HashedResponse (ChartMetrics Histo))
255 getPie cId _start _end maybeListId tabType = do
256 listId <- case maybeListId of
257 Just lid -> pure lid
258 Nothing -> defaultList cId
259 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
260 let pieMap = node ^. node_hyperdata ^. hl_pie
261 mChart = Map.lookup tabType pieMap
262
263 chart <- case mChart of
264 Just chart -> pure chart
265 Nothing -> do
266 updatePie' cId maybeListId tabType Nothing
267
268 pure $ constructHashedResponse chart
269
270 updatePie :: FlowCmdM env err m =>
271 CorpusId
272 -> Maybe ListId
273 -> TabType
274 -> Maybe Limit
275 -> m ()
276 updatePie cId maybeListId tabType maybeLimit = do
277 printDebug "[updatePie] cId" cId
278 printDebug "[updatePie] maybeListId" maybeListId
279 printDebug "[updatePie] tabType" tabType
280 printDebug "[updatePie] maybeLimit" maybeLimit
281 _ <- updatePie' cId maybeListId tabType maybeLimit
282 pure ()
283
284 updatePie' :: FlowCmdM env err m =>
285 CorpusId
286 -> Maybe ListId
287 -> TabType
288 -> Maybe Limit
289 -> m (ChartMetrics Histo)
290 updatePie' cId maybeListId tabType _maybeLimit = do
291 listId <- case maybeListId of
292 Just lid -> pure lid
293 Nothing -> defaultList cId
294 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
295 let hl = node ^. node_hyperdata
296 pieMap = hl ^. hl_pie
297
298 p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
299 _ <- updateHyperdata listId $ hl { _hl_pie = Map.insert tabType (ChartMetrics p) pieMap }
300
301 pure $ ChartMetrics p
302
303 getPieHash :: FlowCmdM env err m =>
304 CorpusId
305 -> Maybe ListId
306 -> TabType
307 -> m Text
308 getPieHash cId maybeListId tabType = do
309 hash <$> getPie cId Nothing Nothing maybeListId tabType
310
311 -------------------------------------------------------------
312 -- | Tree metrics API
313
314 type TreeApi = Summary " Tree API"
315 :> QueryParam "from" UTCTime
316 :> QueryParam "to" UTCTime
317 :> QueryParam "list" ListId
318 :> QueryParamR "ngramsType" TabType
319 :> QueryParamR "listType" ListType
320 :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
321 :<|> Summary "Tree Chart update"
322 :> QueryParam "list" ListId
323 :> QueryParamR "ngramsType" TabType
324 :> QueryParamR "listType" ListType
325 :> Post '[JSON] ()
326 :<|> "hash" :>
327 Summary "Tree Hash"
328 :> QueryParam "list" ListId
329 :> QueryParamR "ngramsType" TabType
330 :> QueryParamR "listType" ListType
331 :> Get '[JSON] Text
332
333 -- Depending on the Type of the Node, we could post
334 -- New documents for a corpus
335 -- New map list terms
336 -- :<|> "process" :> MultipartForm MultipartData :> Post '[JSON] Text
337
338 treeApi :: NodeId -> GargServer TreeApi
339 treeApi id' = getTree id'
340 :<|> updateTree id'
341 :<|> getTreeHash id'
342
343 getTree :: FlowCmdM env err m
344 => CorpusId
345 -> Maybe UTCTime
346 -> Maybe UTCTime
347 -> Maybe ListId
348 -> TabType
349 -> ListType
350 -> m (HashedResponse (ChartMetrics [MyTree]))
351 getTree cId _start _end maybeListId tabType listType = do
352 listId <- case maybeListId of
353 Just lid -> pure lid
354 Nothing -> defaultList cId
355
356 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
357 let treeMap = node ^. node_hyperdata ^. hl_tree
358 mChart = Map.lookup tabType treeMap
359
360 chart <- case mChart of
361 Just chart -> pure chart
362 Nothing -> do
363 updateTree' cId maybeListId tabType listType
364
365 pure $ constructHashedResponse chart
366
367 updateTree :: FlowCmdM env err m =>
368 CorpusId
369 -> Maybe ListId
370 -> TabType
371 -> ListType
372 -> m ()
373 updateTree cId maybeListId tabType listType = do
374 printDebug "[updateTree] cId" cId
375 printDebug "[updateTree] maybeListId" maybeListId
376 printDebug "[updateTree] tabType" tabType
377 printDebug "[updateTree] listType" listType
378 _ <- updateTree' cId maybeListId tabType listType
379 pure ()
380
381 updateTree' :: FlowCmdM env err m =>
382 CorpusId
383 -> Maybe ListId
384 -> TabType
385 -> ListType
386 -> m (ChartMetrics [MyTree])
387 updateTree' cId maybeListId tabType listType = do
388 listId <- case maybeListId of
389 Just lid -> pure lid
390 Nothing -> defaultList cId
391
392 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
393 let hl = node ^. node_hyperdata
394 treeMap = hl ^. hl_tree
395 t <- treeData cId (ngramsTypeFromTabType tabType) listType
396 _ <- updateHyperdata listId $ hl { _hl_tree = Map.insert tabType (ChartMetrics t) treeMap }
397
398 pure $ ChartMetrics t
399
400 getTreeHash :: FlowCmdM env err m =>
401 CorpusId
402 -> Maybe ListId
403 -> TabType
404 -> ListType
405 -> m Text
406 getTreeHash cId maybeListId tabType listType = do
407 hash <$> getTree cId Nothing Nothing maybeListId tabType listType