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