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