Metrics.hs 12.9 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
{-|
Module      : Gargantext.API.Metrics
Description : Server API
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

Metrics API

-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE TypeOperators      #-}

module Gargantext.API.Metrics
    where

21
import Control.Lens
22
import Data.Text (Text)
23
import Data.Time (UTCTime)
24
import Data.Vector (Vector)
25
import Gargantext.API.HashedResponse
26
import Gargantext.API.Ngrams.NgramsTree
27
import Gargantext.API.Ngrams.Types
28
import Gargantext.API.Prelude (GargServer)
29
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
30
import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
31 32
import Gargantext.Core.Viz.Chart
import Gargantext.Core.Viz.Types
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.Action.Flow.Types (FlowCmdM)
37
import Gargantext.Database.Prelude
38
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
39
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
40 41
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
42
import Gargantext.Prelude
43
import Servant
44
import qualified Data.HashMap.Strict                as HashMap
45
import qualified Gargantext.Database.Action.Metrics as Metrics
46

47 48 49
-------------------------------------------------------------
-- | Scatter metrics API
type ScatterAPI = Summary "SepGen IncExc metrics"
50 51 52
                  :> QueryParam  "list"       ListId
                  :> QueryParamR "ngramsType" TabType
                  :> QueryParam  "limit"      Int
53
                  :> Get '[JSON] (HashedResponse Metrics)
54 55 56 57 58
              :<|> Summary "Scatter update"
                  :> QueryParam  "list"       ListId
                  :> QueryParamR "ngramsType" TabType
                  :> QueryParam  "limit"      Int
                  :> Post '[JSON] ()
59 60 61 62
              :<|> "hash" :> Summary "Scatter Hash"
                          :> QueryParam  "list"       ListId
                          :> QueryParamR "ngramsType" TabType
                          :> Get '[JSON] Text
63 64 65 66

scatterApi :: NodeId -> GargServer ScatterAPI
scatterApi id' = getScatter id'
            :<|> updateScatter id'
67
            :<|> getScatterHash id'
68 69

getScatter :: FlowCmdM env err m =>
70 71 72 73
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
74 75
  -> m (HashedResponse Metrics)
getScatter cId maybeListId tabType _maybeLimit = do
76 77 78 79
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
80
  let HyperdataList { _hl_scatter = scatterMap } = node ^. node_hyperdata
81
      mChart = HashMap.lookup tabType scatterMap
82

83
  chart <- case mChart of
84 85
    Just chart -> pure chart
    Nothing    -> do
86 87
      updateScatter' cId maybeListId tabType Nothing

88
  pure $ constructHashedResponse chart
89 90 91 92 93 94 95 96

updateScatter :: FlowCmdM env err m =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> m ()
updateScatter cId maybeListId tabType maybeLimit = do
97 98 99 100
  printDebug "[updateScatter] cId" cId
  printDebug "[updateScatter] maybeListId" maybeListId
  printDebug "[updateScatter] tabType" tabType
  printDebug "[updateScatter] maybeLimit" maybeLimit
101 102 103 104 105 106 107 108 109 110
  _ <- updateScatter' cId maybeListId tabType maybeLimit
  pure ()

updateScatter' :: FlowCmdM env err m =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> m Metrics
updateScatter' cId maybeListId tabType maybeLimit = do
111 112 113
  (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit

  let
114 115 116 117
    metrics      = fmap (\(Scored t s1 s2) -> Metric { m_label = unNgramsTerm t
                                                     , m_x = s1
                                                     , m_y = s2
                                                     , m_cat = listType t ngs' })
Nicolas Pouillard's avatar
Nicolas Pouillard committed
118
                 $ fmap normalizeLocal scores
119
    listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
120 121
    errorMsg     = "API.Node.metrics: key absent"

122 123 124 125
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
126
  let hl = node ^. node_hyperdata
127
      scatterMap = hl ^. hl_scatter
128
  _ <- updateHyperdata listId $ hl { _hl_scatter = HashMap.insert tabType (Metrics metrics) scatterMap }
129

130
  pure $ Metrics metrics
131

132
getScatterHash :: FlowCmdM env err m =>
133 134 135 136
  CorpusId
  -> Maybe ListId
  -> TabType
  -> m Text
137
getScatterHash cId maybeListId tabType = do
138
  hash <$> getScatter cId maybeListId tabType Nothing
139

140

141 142 143 144 145 146 147
-------------------------------------------------------------
-- | Chart metrics API
type ChartApi = Summary " Chart API"
              :> QueryParam "from" UTCTime
              :> QueryParam "to"   UTCTime
              :> QueryParam  "list"       ListId
              :> QueryParamR "ngramsType" TabType
148
              :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
149 150 151 152 153 154 155 156 157
            :<|> Summary "Chart update"
               :> QueryParam  "list"       ListId
               :> QueryParamR "ngramsType" TabType
               :> QueryParam  "limit"      Int
               :> Post '[JSON] ()
            :<|> "hash" :> Summary "Chart Hash"
               :> QueryParam  "list"       ListId
               :> QueryParamR "ngramsType" TabType
               :> Get '[JSON] Text
158 159 160 161

chartApi :: NodeId -> GargServer ChartApi
chartApi id' = getChart id'
          :<|> updateChart id'
162
          :<|> getChartHash id'
163

164
-- TODO add start / end
165 166
getChart :: FlowCmdM env err m =>
            CorpusId
167 168 169 170
         -> Maybe UTCTime
         -> Maybe UTCTime
         -> Maybe ListId
         -> TabType
171
         -> m (HashedResponse (ChartMetrics Histo))
172 173 174 175 176
getChart cId _start _end maybeListId tabType = do
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
177
  let chartMap = node ^. node_hyperdata ^. hl_chart
178
      mChart = HashMap.lookup tabType chartMap
179

180
  chart <- case mChart of
181 182
    Just chart -> pure chart
    Nothing    -> do
183 184 185
      updateChart' cId maybeListId tabType Nothing

  pure $ constructHashedResponse chart
186

187 188 189 190 191 192 193
updateChart :: HasNodeError err =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> Cmd err ()
updateChart cId maybeListId tabType maybeLimit = do
194 195 196 197
  printDebug "[updateChart] cId" cId
  printDebug "[updateChart] maybeListId" maybeListId
  printDebug "[updateChart] tabType" tabType
  printDebug "[updateChart] maybeLimit" maybeLimit
198 199
  _ <- updateChart' cId maybeListId tabType maybeLimit
  pure ()
200

201 202 203 204 205 206
updateChart' :: HasNodeError err =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> Cmd err (ChartMetrics Histo)
207
updateChart' cId maybeListId tabType _maybeLimit = do
208 209 210 211
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
212
  let hl = node ^. node_hyperdata
213
      chartMap = hl ^. hl_chart
214
  h <- histoData cId
215
  _ <- updateHyperdata listId $ hl { _hl_chart = HashMap.insert tabType (ChartMetrics h) chartMap }
216 217

  pure $ ChartMetrics h
218 219


220
getChartHash :: FlowCmdM env err m =>
221 222 223 224
  CorpusId
  -> Maybe ListId
  -> TabType
  -> m Text
225
getChartHash cId maybeListId tabType = do
226
  hash <$> getChart cId Nothing Nothing maybeListId tabType
227
 
228 229 230 231 232 233 234
-------------------------------------------------------------
-- | Pie metrics API
type PieApi = Summary "Pie Chart"
           :> QueryParam "from" UTCTime
           :> QueryParam "to"   UTCTime
           :> QueryParam  "list"       ListId
           :> QueryParamR "ngramsType" TabType
235
           :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
236 237 238 239 240 241 242 243 244
         :<|> Summary "Pie Chart update"
             :> QueryParam  "list"       ListId
             :> QueryParamR "ngramsType" TabType
             :> QueryParam  "limit"      Int
             :> Post '[JSON] ()
         :<|> "hash" :> Summary "Pie Hash"
                     :> QueryParam  "list"       ListId
                     :> QueryParamR "ngramsType" TabType
                     :> Get '[JSON] Text
245 246 247 248

pieApi :: NodeId -> GargServer PieApi
pieApi id' = getPie id'
        :<|> updatePie id'
249
        :<|> getPieHash id'
250 251 252 253 254 255 256

getPie :: FlowCmdM env err m
       => CorpusId
       -> Maybe UTCTime
       -> Maybe UTCTime
       -> Maybe ListId
       -> TabType
257
       -> m (HashedResponse (ChartMetrics Histo))
258 259 260 261 262
getPie cId _start _end maybeListId tabType = do
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
263
  let pieMap = node ^. node_hyperdata ^. hl_pie
264
      mChart = HashMap.lookup tabType pieMap
265

266
  chart <- case mChart of
267 268
    Just chart -> pure chart
    Nothing    -> do
269 270 271
      updatePie' cId maybeListId tabType Nothing

  pure $ constructHashedResponse chart
272

273
updatePie :: FlowCmdM env err m =>
274 275 276 277 278
  CorpusId
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> m ()
279
updatePie cId maybeListId tabType maybeLimit = do
280 281 282 283
  printDebug "[updatePie] cId" cId
  printDebug "[updatePie] maybeListId" maybeListId
  printDebug "[updatePie] tabType" tabType
  printDebug "[updatePie] maybeLimit" maybeLimit
284 285 286 287
  _ <- updatePie' cId maybeListId tabType maybeLimit
  pure ()

updatePie' :: FlowCmdM env err m =>
288
     CorpusId
289 290 291 292 293
  -> Maybe ListId
  -> TabType
  -> Maybe Limit
  -> m (ChartMetrics Histo)
updatePie' cId maybeListId tabType _maybeLimit = do
294 295 296 297
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId
  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
298
  let hl = node ^. node_hyperdata
299
      pieMap = hl ^. hl_pie
300

301
  p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
302
  _ <- updateHyperdata listId $ hl { _hl_pie = HashMap.insert tabType (ChartMetrics p) pieMap }
303

304 305
  pure $ ChartMetrics p

306
getPieHash :: FlowCmdM env err m =>
307 308 309 310
  CorpusId
  -> Maybe ListId
  -> TabType
  -> m Text
311
getPieHash cId maybeListId tabType = do
312 313
  hash <$> getPie cId Nothing Nothing maybeListId tabType

314 315
-------------------------------------------------------------
-- | Tree metrics API
316

317 318 319 320 321 322
type TreeApi = Summary " Tree API"
           :> QueryParam "from" UTCTime
           :> QueryParam "to"   UTCTime
           :> QueryParam  "list"       ListId
           :> QueryParamR "ngramsType" TabType
           :> QueryParamR "listType"   ListType
323
           :> Get '[JSON] (HashedResponse (ChartMetrics (Vector NgramsTree)))
324 325 326 327 328
        :<|> Summary "Tree Chart update"
                :> QueryParam  "list"       ListId
                :> QueryParamR "ngramsType" TabType
                :> QueryParamR "listType"   ListType
                :> Post '[JSON] ()
329
          :<|> "hash" :>
330
                 Summary "Tree Hash"
331 332 333 334 335 336 337
              :> QueryParam  "list"       ListId
              :> QueryParamR "ngramsType" TabType
              :> QueryParamR "listType"   ListType
              :> Get '[JSON] Text
treeApi :: NodeId -> GargServer TreeApi
treeApi id' = getTree id'
         :<|> updateTree id'
338
         :<|> getTreeHash id'
339

340 341 342 343 344 345 346
getTree :: FlowCmdM env err m
        => CorpusId
        -> Maybe UTCTime
        -> Maybe UTCTime
        -> Maybe ListId
        -> TabType
        -> ListType
347
        -> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
348 349 350 351 352 353
getTree cId _start _end maybeListId tabType listType = do
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId

  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
354
  let treeMap = node ^. node_hyperdata ^. hl_tree
355
      mChart = HashMap.lookup tabType treeMap
356 357

  chart <- case mChart of
358 359
    Just chart -> pure chart
    Nothing    -> do
360 361 362
      updateTree' cId maybeListId tabType listType

  pure $ constructHashedResponse chart
363 364 365 366 367 368 369 370

updateTree :: FlowCmdM env err m =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> ListType
  -> m ()
updateTree cId maybeListId tabType listType = do
371 372 373 374
  printDebug "[updateTree] cId" cId
  printDebug "[updateTree] maybeListId" maybeListId
  printDebug "[updateTree] tabType" tabType
  printDebug "[updateTree] listType" listType
375
  _ <- updateTree' cId maybeListId tabType listType
376
  pure ()
377 378 379 380 381 382

updateTree' :: FlowCmdM env err m =>
  CorpusId
  -> Maybe ListId
  -> TabType
  -> ListType
383
  -> m (ChartMetrics (Vector NgramsTree))
384 385 386 387 388 389
updateTree' cId maybeListId tabType listType = do
  listId <- case maybeListId of
    Just lid -> pure lid
    Nothing  -> defaultList cId

  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
390 391
  let hl      = node ^. node_hyperdata
      treeMap = hl  ^. hl_tree
392
  t <- treeData cId (ngramsTypeFromTabType tabType) listType
393
  _ <- updateHyperdata listId $ hl { _hl_tree = HashMap.insert tabType (ChartMetrics t) treeMap }
394 395

  pure $ ChartMetrics t
396

397
getTreeHash :: FlowCmdM env err m =>
398 399 400 401 402
  CorpusId
  -> Maybe ListId
  -> TabType
  -> ListType
  -> m Text
403
getTreeHash cId maybeListId tabType listType = do
404
  hash <$> getTree cId Nothing Nothing maybeListId tabType listType