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.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 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 { m_label = unNgramsTerm t
 115                                                      , m_x = s1
 116                                                      , m_y = s2
 117                                                      , m_cat = listType t ngs' })
 118                  $ fmap normalizeLocal scores
 119     listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
 120     errorMsg     = "API.Node.metrics: key absent"
 121
 122   listId <- case maybeListId of
 123     Just lid -> pure lid
 124     Nothing  -> defaultList cId
 125   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   CorpusId
 134   -> Maybe ListId
 135   -> TabType
 136   -> m Text
 137 getScatterHash cId maybeListId tabType = do
 138   hash <$> getScatter cId maybeListId tabType Nothing
 139
 140
 141 -------------------------------------------------------------
 142 -- | Chart metrics API
 143 type ChartApi = Summary " Chart API"
 144               :> QueryParam "from" UTCTime
 145               :> QueryParam "to"   UTCTime
 146               :> QueryParam  "list"       ListId
 147               :> QueryParamR "ngramsType" TabType
 148               :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 149             :<|> Summary "Chart update"
 150                :> QueryParam  "list"       ListId
 151                :> QueryParamR "ngramsType" TabType
 152                :> QueryParam  "limit"      Int
 153                :> Post '[JSON] ()
 154             :<|> "hash" :> Summary "Chart Hash"
 155                :> QueryParam  "list"       ListId
 156                :> QueryParamR "ngramsType" TabType
 157                :> Get '[JSON] Text
 158
 159 chartApi :: NodeId -> GargServer ChartApi
 160 chartApi id' = getChart id'
 161           :<|> updateChart id'
 162           :<|> getChartHash id'
 163
 164 -- TODO add start / end
 165 getChart :: FlowCmdM env err m =>
 166             CorpusId
 167          -> Maybe UTCTime
 168          -> Maybe UTCTime
 169          -> Maybe ListId
 170          -> TabType
 171          -> m (HashedResponse (ChartMetrics Histo))
 172 getChart cId _start _end maybeListId tabType = do
 173   listId <- case maybeListId of
 174     Just lid -> pure lid
 175     Nothing  -> defaultList cId
 176   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     Just chart -> pure chart
 182     Nothing    -> do
 183       updateChart' cId maybeListId tabType Nothing
 184
 185   pure $ constructHashedResponse chart
 186
 187 updateChart :: HasNodeError err =>
 188   CorpusId
 189   -> Maybe ListId
 190   -> TabType
 191   -> Maybe Limit
 192   -> Cmd err ()
 193 updateChart cId maybeListId tabType maybeLimit = do
 194   printDebug "[updateChart] cId" cId
 195   printDebug "[updateChart] maybeListId" maybeListId
 196   printDebug "[updateChart] tabType" tabType
 197   printDebug "[updateChart] maybeLimit" maybeLimit
 198   _ <- updateChart' cId maybeListId tabType maybeLimit
 199   pure ()
 200
 201 updateChart' :: HasNodeError err =>
 202   CorpusId
 203   -> Maybe ListId
 204   -> TabType
 205   -> Maybe Limit
 206   -> Cmd err (ChartMetrics Histo)
 207 updateChart' cId maybeListId tabType _maybeLimit = do
 208   listId <- case maybeListId of
 209     Just lid -> pure lid
 210     Nothing  -> defaultList cId
 211   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   CorpusId
 222   -> Maybe ListId
 223   -> TabType
 224   -> m Text
 225 getChartHash cId maybeListId tabType = do
 226   hash <$> getChart cId Nothing Nothing maybeListId tabType
 227
 228 -------------------------------------------------------------
 229 -- | Pie metrics API
 230 type PieApi = Summary "Pie Chart"
 231            :> QueryParam "from" UTCTime
 232            :> QueryParam "to"   UTCTime
 233            :> QueryParam  "list"       ListId
 234            :> QueryParamR "ngramsType" TabType
 235            :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 236          :<|> Summary "Pie Chart update"
 237              :> QueryParam  "list"       ListId
 238              :> QueryParamR "ngramsType" TabType
 239              :> QueryParam  "limit"      Int
 240              :> Post '[JSON] ()
 241          :<|> "hash" :> Summary "Pie Hash"
 242                      :> QueryParam  "list"       ListId
 243                      :> QueryParamR "ngramsType" TabType
 244                      :> Get '[JSON] Text
 245
 246 pieApi :: NodeId -> GargServer PieApi
 247 pieApi id' = getPie id'
 248         :<|> updatePie id'
 249         :<|> getPieHash id'
 250
 251 getPie :: FlowCmdM env err m
 252        => CorpusId
 253        -> Maybe UTCTime
 254        -> Maybe UTCTime
 255        -> Maybe ListId
 256        -> TabType
 257        -> m (HashedResponse (ChartMetrics Histo))
 258 getPie cId _start _end maybeListId tabType = do
 259   listId <- case maybeListId of
 260     Just lid -> pure lid
 261     Nothing  -> defaultList cId
 262   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     Just chart -> pure chart
 268     Nothing    -> do
 269       updatePie' cId maybeListId tabType Nothing
 270
 271   pure $ constructHashedResponse chart
 272
 273 updatePie :: FlowCmdM env err m =>
 274   CorpusId
 275   -> Maybe ListId
 276   -> TabType
 277   -> Maybe Limit
 278   -> m ()
 279 updatePie cId maybeListId tabType maybeLimit = do
 280   printDebug "[updatePie] cId" cId
 281   printDebug "[updatePie] maybeListId" maybeListId
 282   printDebug "[updatePie] tabType" tabType
 283   printDebug "[updatePie] maybeLimit" maybeLimit
 284   _ <- updatePie' cId maybeListId tabType maybeLimit
 285   pure ()
 286
 287 updatePie' :: FlowCmdM env err m =>
 288      CorpusId
 289   -> Maybe ListId
 290   -> TabType
 291   -> Maybe Limit
 292   -> m (ChartMetrics Histo)
 293 updatePie' cId maybeListId tabType _maybeLimit = do
 294   listId <- case maybeListId of
 295     Just lid -> pure lid
 296     Nothing  -> defaultList cId
 297   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   pure $ ChartMetrics p
 305
 306 getPieHash :: FlowCmdM env err m =>
 307   CorpusId
 308   -> Maybe ListId
 309   -> TabType
 310   -> m Text
 311 getPieHash cId maybeListId tabType = do
 312   hash <$> getPie cId Nothing Nothing maybeListId tabType
 313
 314 -------------------------------------------------------------
 315 -- | Tree metrics API
 316
 317 type TreeApi = Summary " Tree API"
 318            :> QueryParam "from" UTCTime
 319            :> QueryParam "to"   UTCTime
 320            :> QueryParam  "list"       ListId
 321            :> QueryParamR "ngramsType" TabType
 322            :> QueryParamR "listType"   ListType
 323            :> Get '[JSON] (HashedResponse (ChartMetrics (Vector NgramsTree)))
 324         :<|> Summary "Tree Chart update"
 325                 :> QueryParam  "list"       ListId
 326                 :> QueryParamR "ngramsType" TabType
 327                 :> QueryParamR "listType"   ListType
 328                 :> Post '[JSON] ()
 329           :<|> "hash" :>
 330                  Summary "Tree Hash"
 331               :> QueryParam  "list"       ListId
 332               :> QueryParamR "ngramsType" TabType
 333               :> QueryParamR "listType"   ListType
 334               :> Get '[JSON] Text
 335 treeApi :: NodeId -> GargServer TreeApi
 336 treeApi id' = getTree id'
 337          :<|> updateTree id'
 338          :<|> getTreeHash id'
 339
 340 getTree :: FlowCmdM env err m
 341         => CorpusId
 342         -> Maybe UTCTime
 343         -> Maybe UTCTime
 344         -> Maybe ListId
 345         -> TabType
 346         -> ListType
 347         -> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
 348 getTree cId _start _end maybeListId tabType listType = do
 349   listId <- case maybeListId of
 350     Just lid -> pure lid
 351     Nothing  -> defaultList cId
 352
 353   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     Just chart -> pure chart
 359     Nothing    -> do
 360       updateTree' cId maybeListId tabType listType
 361
 362   pure $ constructHashedResponse chart
 363
 364 updateTree :: FlowCmdM env err m =>
 365   CorpusId
 366   -> Maybe ListId
 367   -> TabType
 368   -> ListType
 369   -> m ()
 370 updateTree cId maybeListId tabType listType = do
 371   printDebug "[updateTree] cId" cId
 372   printDebug "[updateTree] maybeListId" maybeListId
 373   printDebug "[updateTree] tabType" tabType
 374   printDebug "[updateTree] listType" listType
 375   _ <- updateTree' cId maybeListId tabType listType
 376   pure ()
 377
 378 updateTree' :: FlowCmdM env err m =>
 379   CorpusId
 380   -> Maybe ListId
 381   -> TabType
 382   -> ListType
 383   -> m (ChartMetrics (Vector NgramsTree))
 384 updateTree' cId maybeListId tabType listType = do
 385   listId <- case maybeListId of
 386     Just lid -> pure lid
 387     Nothing  -> defaultList cId
 388
 389   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 390   let hl      = node ^. node_hyperdata
 391       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   CorpusId
 399   -> Maybe ListId
 400   -> TabType
 401   -> ListType
 402   -> m Text
 403 getTreeHash cId maybeListId tabType listType = do
 404   hash <$> getTree cId Nothing Nothing maybeListId tabType listType