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.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 import Gargantext.Core.Viz.Chart
  32 import Gargantext.Core.Viz.Types
  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 Servant
  44 import qualified Data.HashMap.Strict                as HashMap
  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 = HashMap.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      = fmap (\(Scored t s1 s2) -> Metric (unNgramsTerm t) s1 s2 (listType t ngs'))
 115                  $ fmap normalizeLocal scores
 116     listType t m = maybe (panic errorMsg) fst $ HashMap.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 = HashMap.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 = HashMap.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 = HashMap.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 = HashMap.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 = HashMap.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 (Vector NgramsTree)))
 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 treeApi :: NodeId -> GargServer TreeApi
 333 treeApi id' = getTree id'
 334          :<|> updateTree id'
 335          :<|> getTreeHash id'
 336
 337 getTree :: FlowCmdM env err m
 338         => CorpusId
 339         -> Maybe UTCTime
 340         -> Maybe UTCTime
 341         -> Maybe ListId
 342         -> TabType
 343         -> ListType
 344         -> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
 345 getTree cId _start _end maybeListId tabType listType = do
 346   listId <- case maybeListId of
 347     Just lid -> pure lid
 348     Nothing  -> defaultList cId
 349
 350   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 351   let treeMap = node ^. node_hyperdata ^. hl_tree
 352       mChart = HashMap.lookup tabType treeMap
 353
 354   chart <- case mChart of
 355     Just chart -> pure chart
 356     Nothing    -> do
 357       updateTree' cId maybeListId tabType listType
 358
 359   pure $ constructHashedResponse chart
 360
 361 updateTree :: FlowCmdM env err m =>
 362   CorpusId
 363   -> Maybe ListId
 364   -> TabType
 365   -> ListType
 366   -> m ()
 367 updateTree cId maybeListId tabType listType = do
 368   printDebug "[updateTree] cId" cId
 369   printDebug "[updateTree] maybeListId" maybeListId
 370   printDebug "[updateTree] tabType" tabType
 371   printDebug "[updateTree] listType" listType
 372   _ <- updateTree' cId maybeListId tabType listType
 373   pure ()
 374
 375 updateTree' :: FlowCmdM env err m =>
 376   CorpusId
 377   -> Maybe ListId
 378   -> TabType
 379   -> ListType
 380   -> m (ChartMetrics (Vector NgramsTree))
 381 updateTree' cId maybeListId tabType listType = do
 382   listId <- case maybeListId of
 383     Just lid -> pure lid
 384     Nothing  -> defaultList cId
 385
 386   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 387   let hl      = node ^. node_hyperdata
 388       treeMap = hl  ^. hl_tree
 389   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 390   _ <- updateHyperdata listId $ hl { _hl_tree = HashMap.insert tabType (ChartMetrics t) treeMap }
 391
 392   pure $ ChartMetrics t
 393
 394 getTreeHash :: FlowCmdM env err m =>
 395   CorpusId
 396   -> Maybe ListId
 397   -> TabType
 398   -> ListType
 399   -> m Text
 400 getTreeHash cId maybeListId tabType listType = do
 401   hash <$> getTree cId Nothing Nothing maybeListId tabType listType