]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Metrics.hs
Merge branch 'dev-doc-annotation-issue' of ssh://gitlab.iscpif.fr:20022/gargantext...
[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.Time (UTCTime)
24 import Data.Text (Text)
25 import Servant
26
27 import Gargantext.API.HashedResponse
28 import Gargantext.API.Ngrams
29 import Gargantext.API.Ngrams.NTree
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(..))
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(..))
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 = mChart } = node ^. node_hyperdata
81
82 chart <- case mChart of
83 Just chart -> pure chart
84 Nothing -> do
85 updateScatter' cId maybeListId tabType Nothing
86
87 pure $ constructHashedResponse chart
88
89 updateScatter :: FlowCmdM env err m =>
90 CorpusId
91 -> Maybe ListId
92 -> TabType
93 -> Maybe Limit
94 -> m ()
95 updateScatter cId maybeListId tabType maybeLimit = do
96 _ <- updateScatter' cId maybeListId tabType maybeLimit
97 pure ()
98
99 updateScatter' :: FlowCmdM env err m =>
100 CorpusId
101 -> Maybe ListId
102 -> TabType
103 -> Maybe Limit
104 -> m Metrics
105 updateScatter' cId maybeListId tabType maybeLimit = do
106 (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
107
108 let
109 metrics = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
110 log' n x = 1 + (if x <= 0 then 0 else log $ (10^(n::Int)) * x)
111 listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
112 errorMsg = "API.Node.metrics: key absent"
113
114 listId <- case maybeListId of
115 Just lid -> pure lid
116 Nothing -> defaultList cId
117 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
118 let hl = node ^. node_hyperdata
119 _ <- updateHyperdata listId $ hl { _hl_scatter = Just $ Metrics metrics }
120
121 pure $ Metrics metrics
122
123 getScatterHash :: FlowCmdM env err m =>
124 CorpusId
125 -> Maybe ListId
126 -> TabType
127 -> m Text
128 getScatterHash cId maybeListId tabType = do
129 hash <$> getScatter cId maybeListId tabType Nothing
130
131
132 -------------------------------------------------------------
133 -- | Chart metrics API
134 type ChartApi = Summary " Chart API"
135 :> QueryParam "from" UTCTime
136 :> QueryParam "to" UTCTime
137 :> QueryParam "list" ListId
138 :> QueryParamR "ngramsType" TabType
139 :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
140 :<|> Summary "Chart update"
141 :> QueryParam "list" ListId
142 :> QueryParamR "ngramsType" TabType
143 :> QueryParam "limit" Int
144 :> Post '[JSON] ()
145 :<|> "hash" :> Summary "Chart Hash"
146 :> QueryParam "list" ListId
147 :> QueryParamR "ngramsType" TabType
148 :> Get '[JSON] Text
149
150 chartApi :: NodeId -> GargServer ChartApi
151 chartApi id' = getChart id'
152 :<|> updateChart id'
153 :<|> getChartHash id'
154
155 -- TODO add start / end
156 getChart :: FlowCmdM env err m =>
157 CorpusId
158 -> Maybe UTCTime
159 -> Maybe UTCTime
160 -> Maybe ListId
161 -> TabType
162 -> m (HashedResponse (ChartMetrics Histo))
163 getChart cId _start _end maybeListId tabType = do
164 listId <- case maybeListId of
165 Just lid -> pure lid
166 Nothing -> defaultList cId
167 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
168 let HyperdataList { _hl_chart = mChart } = node ^. node_hyperdata
169
170 chart <- case mChart of
171 Just chart -> pure chart
172 Nothing -> do
173 updateChart' cId maybeListId tabType Nothing
174
175 pure $ constructHashedResponse chart
176
177 updateChart :: HasNodeError err =>
178 CorpusId
179 -> Maybe ListId
180 -> TabType
181 -> Maybe Limit
182 -> Cmd err ()
183 updateChart cId maybeListId tabType maybeLimit = do
184 _ <- updateChart' cId maybeListId tabType maybeLimit
185 pure ()
186
187 updateChart' :: HasNodeError err =>
188 CorpusId
189 -> Maybe ListId
190 -> TabType
191 -> Maybe Limit
192 -> Cmd err (ChartMetrics Histo)
193 updateChart' cId maybeListId _tabType _maybeLimit = do
194 listId <- case maybeListId of
195 Just lid -> pure lid
196 Nothing -> defaultList cId
197 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
198 let hl = node ^. node_hyperdata
199 h <- histoData cId
200 _ <- updateHyperdata listId $ hl { _hl_chart = Just $ ChartMetrics h }
201
202 pure $ ChartMetrics h
203
204
205 getChartHash :: FlowCmdM env err m =>
206 CorpusId
207 -> Maybe ListId
208 -> TabType
209 -> m Text
210 getChartHash cId maybeListId tabType = do
211 hash <$> getChart cId Nothing Nothing maybeListId tabType
212
213 -------------------------------------------------------------
214 -- | Pie metrics API
215 type PieApi = Summary "Pie Chart"
216 :> QueryParam "from" UTCTime
217 :> QueryParam "to" UTCTime
218 :> QueryParam "list" ListId
219 :> QueryParamR "ngramsType" TabType
220 :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
221 :<|> Summary "Pie Chart update"
222 :> QueryParam "list" ListId
223 :> QueryParamR "ngramsType" TabType
224 :> QueryParam "limit" Int
225 :> Post '[JSON] ()
226 :<|> "hash" :> Summary "Pie Hash"
227 :> QueryParam "list" ListId
228 :> QueryParamR "ngramsType" TabType
229 :> Get '[JSON] Text
230
231 pieApi :: NodeId -> GargServer PieApi
232 pieApi id' = getPie id'
233 :<|> updatePie id'
234 :<|> getPieHash id'
235
236 getPie :: FlowCmdM env err m
237 => CorpusId
238 -> Maybe UTCTime
239 -> Maybe UTCTime
240 -> Maybe ListId
241 -> TabType
242 -> m (HashedResponse (ChartMetrics Histo))
243 getPie cId _start _end maybeListId tabType = do
244 listId <- case maybeListId of
245 Just lid -> pure lid
246 Nothing -> defaultList cId
247 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
248 let HyperdataList { _hl_pie = mChart } = node ^. node_hyperdata
249
250 chart <- case mChart of
251 Just chart -> pure chart
252 Nothing -> do
253 updatePie' cId maybeListId tabType Nothing
254
255 pure $ constructHashedResponse chart
256
257 updatePie :: FlowCmdM env err m =>
258 CorpusId
259 -> Maybe ListId
260 -> TabType
261 -> Maybe Limit
262 -> m ()
263 updatePie cId maybeListId tabType maybeLimit = do
264 _ <- updatePie' cId maybeListId tabType maybeLimit
265 pure ()
266
267 updatePie' :: FlowCmdM env err m =>
268 CorpusId
269 -> Maybe ListId
270 -> TabType
271 -> Maybe Limit
272 -> m (ChartMetrics Histo)
273 updatePie' cId maybeListId tabType _maybeLimit = do
274 listId <- case maybeListId of
275 Just lid -> pure lid
276 Nothing -> defaultList cId
277 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
278 let hl = node ^. node_hyperdata
279
280 p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
281 _ <- updateHyperdata listId $ hl { _hl_pie = Just $ ChartMetrics p }
282
283 pure $ ChartMetrics p
284
285 getPieHash :: FlowCmdM env err m =>
286 CorpusId
287 -> Maybe ListId
288 -> TabType
289 -> m Text
290 getPieHash cId maybeListId tabType = do
291 hash <$> getPie cId Nothing Nothing maybeListId tabType
292
293 -------------------------------------------------------------
294 -- | Tree metrics API
295
296 type TreeApi = Summary " Tree API"
297 :> QueryParam "from" UTCTime
298 :> QueryParam "to" UTCTime
299 :> QueryParam "list" ListId
300 :> QueryParamR "ngramsType" TabType
301 :> QueryParamR "listType" ListType
302 :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
303 :<|> Summary "Tree Chart update"
304 :> QueryParam "list" ListId
305 :> QueryParamR "ngramsType" TabType
306 :> QueryParamR "listType" ListType
307 :> Post '[JSON] ()
308 :<|> "hash" :>
309 Summary "Tree Hash"
310 :> QueryParam "list" ListId
311 :> QueryParamR "ngramsType" TabType
312 :> QueryParamR "listType" ListType
313 :> Get '[JSON] Text
314
315 -- Depending on the Type of the Node, we could post
316 -- New documents for a corpus
317 -- New map list terms
318 -- :<|> "process" :> MultipartForm MultipartData :> Post '[JSON] Text
319
320 treeApi :: NodeId -> GargServer TreeApi
321 treeApi id' = getTree id'
322 :<|> updateTree id'
323 :<|> getTreeHash id'
324
325 getTree :: FlowCmdM env err m
326 => CorpusId
327 -> Maybe UTCTime
328 -> Maybe UTCTime
329 -> Maybe ListId
330 -> TabType
331 -> ListType
332 -> m (HashedResponse (ChartMetrics [MyTree]))
333 getTree cId _start _end maybeListId tabType listType = do
334 listId <- case maybeListId of
335 Just lid -> pure lid
336 Nothing -> defaultList cId
337
338 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
339 let HyperdataList { _hl_tree = mChart } = node ^. node_hyperdata
340
341 chart <- case mChart of
342 Just chart -> pure chart
343 Nothing -> do
344 updateTree' cId maybeListId tabType listType
345
346 pure $ constructHashedResponse chart
347
348 updateTree :: FlowCmdM env err m =>
349 CorpusId
350 -> Maybe ListId
351 -> TabType
352 -> ListType
353 -> m ()
354 updateTree cId maybeListId tabType listType = do
355 _ <- updateTree' cId maybeListId tabType listType
356 pure ()
357
358 updateTree' :: FlowCmdM env err m =>
359 CorpusId
360 -> Maybe ListId
361 -> TabType
362 -> ListType
363 -> m (ChartMetrics [MyTree])
364 updateTree' cId maybeListId tabType listType = do
365 listId <- case maybeListId of
366 Just lid -> pure lid
367 Nothing -> defaultList cId
368
369 node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
370 let hl = node ^. node_hyperdata
371 t <- treeData cId (ngramsTypeFromTabType tabType) listType
372 _ <- updateHyperdata listId $ hl { _hl_tree = Just $ ChartMetrics t }
373
374 pure $ ChartMetrics t
375
376 getTreeHash :: FlowCmdM env err m =>
377 CorpusId
378 -> Maybe ListId
379 -> TabType
380 -> ListType
381 -> m Text
382 getTreeHash cId maybeListId tabType listType = do
383 hash <$> getTree cId Nothing Nothing maybeListId tabType listType