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