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 qualified Data.Map as Map
  23 import Data.Time (UTCTime)
  24 import Data.Text (Text)
  25 import Servant
  26
  27 import Gargantext.API.HashedResponse
  28 import Gargantext.API.Ngrams
  29 import Gargantext.API.Ngrams.NTree
  30 import Gargantext.API.Prelude (GargServer)
  31 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
  32 import Gargantext.Database.Action.Flow
  33 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..))
  34 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
  35 import Gargantext.Database.Admin.Types.Node (NodeId)
  36 import Gargantext.Database.Prelude
  37 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
  38 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  39 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  40 import Gargantext.Database.Schema.Node (node_hyperdata)
  41 import Gargantext.Prelude
  42 import Gargantext.Core.Text.Metrics (Scored(..))
  43 import Gargantext.Core.Viz.Chart
  44 import Gargantext.Core.Viz.Types
  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" :>
  60                      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 = mChart } = node ^. node_hyperdata
  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   _ <- updateScatter' cId maybeListId tabType maybeLimit
  98   pure ()
  99
 100 updateScatter' :: FlowCmdM env err m =>
 101   CorpusId
 102   -> Maybe ListId
 103   -> TabType
 104   -> Maybe Limit
 105   -> m Metrics
 106 updateScatter' cId maybeListId tabType maybeLimit = do
 107   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 108
 109   let
 110     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
 111     log' n x     = 1 + (if x <= 0 then 0 else log $ (10^(n::Int)) * x)
 112     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 113     errorMsg     = "API.Node.metrics: key absent"
 114
 115   listId <- case maybeListId of
 116     Just lid -> pure lid
 117     Nothing  -> defaultList cId
 118   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 119   let hl = node ^. node_hyperdata
 120   _ <- updateHyperdata listId $ hl { _hl_scatter = Just $ Metrics metrics }
 121
 122   pure $ Metrics metrics
 123
 124 getScatterHash :: FlowCmdM env err m =>
 125   CorpusId
 126   -> Maybe ListId
 127   -> TabType
 128   -> m Text
 129 getScatterHash cId maybeListId tabType = do
 130   hash <$> getScatter cId maybeListId tabType Nothing
 131
 132
 133 -------------------------------------------------------------
 134 -- | Chart metrics API
 135 type ChartApi = Summary " Chart API"
 136               :> QueryParam "from" UTCTime
 137               :> QueryParam "to"   UTCTime
 138               :> QueryParam  "list"       ListId
 139               :> QueryParamR "ngramsType" TabType
 140               :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 141         :<|> Summary "Chart update"
 142                 :> QueryParam  "list"       ListId
 143                 :> QueryParamR "ngramsType" TabType
 144                 :> QueryParam  "limit"      Int
 145                 :> Post '[JSON] ()
 146               :<|> "hash" :>
 147                      Summary "Chart Hash"
 148                   :> QueryParam  "list"       ListId
 149                   :> QueryParamR "ngramsType" TabType
 150                   :> Get '[JSON] Text
 151
 152 chartApi :: NodeId -> GargServer ChartApi
 153 chartApi id' = getChart id'
 154           :<|> updateChart id'
 155           :<|> getChartHash id'
 156
 157 -- TODO add start / end
 158 getChart :: FlowCmdM env err m =>
 159             CorpusId
 160          -> Maybe UTCTime
 161          -> Maybe UTCTime
 162          -> Maybe ListId
 163          -> TabType
 164          -> m (HashedResponse (ChartMetrics Histo))
 165 getChart cId _start _end maybeListId tabType = do
 166   listId <- case maybeListId of
 167     Just lid -> pure lid
 168     Nothing  -> defaultList cId
 169   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 170   let HyperdataList { _hl_chart = mChart } = node ^. node_hyperdata
 171
 172   chart <- case mChart of
 173     Just chart -> pure chart
 174     Nothing    -> do
 175       updateChart' cId maybeListId tabType Nothing
 176
 177   pure $ constructHashedResponse chart
 178
 179 updateChart :: HasNodeError err =>
 180   CorpusId
 181   -> Maybe ListId
 182   -> TabType
 183   -> Maybe Limit
 184   -> Cmd err ()
 185 updateChart cId maybeListId tabType maybeLimit = do
 186   _ <- updateChart' cId maybeListId tabType maybeLimit
 187   pure ()
 188
 189 updateChart' :: HasNodeError err =>
 190   CorpusId
 191   -> Maybe ListId
 192   -> TabType
 193   -> Maybe Limit
 194   -> Cmd err (ChartMetrics Histo)
 195 updateChart' cId maybeListId _tabType _maybeLimit = do
 196   listId <- case maybeListId of
 197     Just lid -> pure lid
 198     Nothing  -> defaultList cId
 199   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 200   let hl = node ^. node_hyperdata
 201   h <- histoData cId
 202   _ <- updateHyperdata listId $ hl { _hl_chart = Just $ ChartMetrics h }
 203
 204   pure $ ChartMetrics h
 205
 206
 207 getChartHash :: FlowCmdM env err m =>
 208   CorpusId
 209   -> Maybe ListId
 210   -> TabType
 211   -> m Text
 212 getChartHash cId maybeListId tabType = do
 213   hash <$> getChart cId Nothing Nothing maybeListId tabType
 214
 215 -------------------------------------------------------------
 216 -- | Pie metrics API
 217 type PieApi = Summary "Pie Chart"
 218            :> QueryParam "from" UTCTime
 219            :> QueryParam "to"   UTCTime
 220            :> QueryParam  "list"       ListId
 221            :> QueryParamR "ngramsType" TabType
 222            :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 223         :<|> Summary "Pie Chart update"
 224                 :> QueryParam  "list"       ListId
 225                 :> QueryParamR "ngramsType" TabType
 226                 :> QueryParam  "limit"      Int
 227                 :> Post '[JSON] ()
 228               :<|> "hash" :>
 229                      Summary "Pie Hash"
 230                   :> QueryParam  "list"       ListId
 231                   :> QueryParamR "ngramsType" TabType
 232                   :> Get '[JSON] Text
 233
 234 pieApi :: NodeId -> GargServer PieApi
 235 pieApi id' = getPie id'
 236         :<|> updatePie id'
 237         :<|> getPieHash id'
 238
 239 getPie :: FlowCmdM env err m
 240        => CorpusId
 241        -> Maybe UTCTime
 242        -> Maybe UTCTime
 243        -> Maybe ListId
 244        -> TabType
 245        -> m (HashedResponse (ChartMetrics Histo))
 246 getPie cId _start _end maybeListId tabType = do
 247   listId <- case maybeListId of
 248     Just lid -> pure lid
 249     Nothing  -> defaultList cId
 250   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 251   let HyperdataList { _hl_pie = mChart } = node ^. node_hyperdata
 252
 253   chart <- case mChart of
 254     Just chart -> pure chart
 255     Nothing    -> do
 256       updatePie' cId maybeListId tabType Nothing
 257
 258   pure $ constructHashedResponse chart
 259
 260 updatePie :: FlowCmdM env err m =>
 261   CorpusId
 262   -> Maybe ListId
 263   -> TabType
 264   -> Maybe Limit
 265   -> m ()
 266 updatePie cId maybeListId tabType maybeLimit = do
 267   _ <- updatePie' cId maybeListId tabType maybeLimit
 268   pure ()
 269
 270 updatePie' :: FlowCmdM env err m =>
 271   CorpusId
 272   -> Maybe ListId
 273   -> TabType
 274   -> Maybe Limit
 275   -> m (ChartMetrics Histo)
 276 updatePie' cId maybeListId tabType _maybeLimit = do
 277   listId <- case maybeListId of
 278     Just lid -> pure lid
 279     Nothing  -> defaultList cId
 280   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 281   let hl = node ^. node_hyperdata
 282
 283   p <- pieData cId (ngramsTypeFromTabType tabType) MapTerm
 284   _ <- updateHyperdata listId $ hl { _hl_pie = Just $ ChartMetrics p }
 285
 286   pure $ ChartMetrics p
 287
 288 getPieHash :: FlowCmdM env err m =>
 289   CorpusId
 290   -> Maybe ListId
 291   -> TabType
 292   -> m Text
 293 getPieHash cId maybeListId tabType = do
 294   hash <$> getPie cId Nothing Nothing maybeListId tabType
 295
 296 -------------------------------------------------------------
 297 -- | Tree metrics API
 298
 299 type TreeApi = Summary " Tree API"
 300            :> QueryParam "from" UTCTime
 301            :> QueryParam "to"   UTCTime
 302            :> QueryParam  "list"       ListId
 303            :> QueryParamR "ngramsType" TabType
 304            :> QueryParamR "listType"   ListType
 305            :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
 306         :<|> Summary "Tree Chart update"
 307                 :> QueryParam  "list"       ListId
 308                 :> QueryParamR "ngramsType" TabType
 309                 :> QueryParamR "listType"   ListType
 310                 :> Post '[JSON] ()
 311           :<|> "hash" :>
 312                   Summary "Tree Hash"
 313               :> QueryParam  "list"       ListId
 314               :> QueryParamR "ngramsType" TabType
 315               :> QueryParamR "listType"   ListType
 316               :> Get '[JSON] Text
 317
 318                 -- Depending on the Type of the Node, we could post
 319                 -- New documents for a corpus
 320                 -- New map list terms
 321              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 322
 323 treeApi :: NodeId -> GargServer TreeApi
 324 treeApi id' = getTree id'
 325          :<|> updateTree id'
 326          :<|> getTreeHash id'
 327
 328 getTree :: FlowCmdM env err m
 329         => CorpusId
 330         -> Maybe UTCTime
 331         -> Maybe UTCTime
 332         -> Maybe ListId
 333         -> TabType
 334         -> ListType
 335         -> m (HashedResponse (ChartMetrics [MyTree]))
 336 getTree cId _start _end maybeListId tabType listType = do
 337   listId <- case maybeListId of
 338     Just lid -> pure lid
 339     Nothing  -> defaultList cId
 340
 341   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 342   let HyperdataList { _hl_tree = mChart } = node ^. node_hyperdata
 343
 344   chart <- case mChart of
 345     Just chart -> pure chart
 346     Nothing    -> do
 347       updateTree' cId maybeListId tabType listType
 348
 349   pure $ constructHashedResponse chart
 350
 351 updateTree :: FlowCmdM env err m =>
 352   CorpusId
 353   -> Maybe ListId
 354   -> TabType
 355   -> ListType
 356   -> m ()
 357 updateTree cId maybeListId tabType listType = do
 358   _ <- updateTree' cId maybeListId tabType listType
 359   pure ()
 360
 361 updateTree' :: FlowCmdM env err m =>
 362   CorpusId
 363   -> Maybe ListId
 364   -> TabType
 365   -> ListType
 366   -> m (ChartMetrics [MyTree])
 367 updateTree' cId maybeListId tabType listType = do
 368   listId <- case maybeListId of
 369     Just lid -> pure lid
 370     Nothing  -> defaultList cId
 371
 372   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 373   let hl = node ^. node_hyperdata
 374   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 375   _ <- updateHyperdata listId $ hl { _hl_tree = Just $ ChartMetrics t }
 376
 377   pure $ ChartMetrics t
 378
 379 getTreeHash :: FlowCmdM env err m =>
 380   CorpusId
 381   -> Maybe ListId
 382   -> TabType
 383   -> ListType
 384   -> m Text
 385 getTreeHash cId maybeListId tabType listType = do
 386   hash <$> getTree cId Nothing Nothing maybeListId tabType listType