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" :> 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" :> Summary "Chart Hash"
 146                :> QueryParam  "list"       ListId
 147                :> QueryParamR "ngramsType" TabType
 148                :> Get '[JSON] Text
 149
 150 chartApi :: NodeId -> GargServer ChartApi
 151 chartApi id' = getChart id'
 152           :<|> updateChart id'
 153           :<|> getChartHash id'
 154
 155 -- TODO add start / end
 156 getChart :: FlowCmdM env err m =>
 157             CorpusId
 158          -> Maybe UTCTime
 159          -> Maybe UTCTime
 160          -> Maybe ListId
 161          -> TabType
 162          -> m (HashedResponse (ChartMetrics Histo))
 163 getChart cId _start _end maybeListId tabType = do
 164   listId <- case maybeListId of
 165     Just lid -> pure lid
 166     Nothing  -> defaultList cId
 167   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 168   let HyperdataList { _hl_chart = mChart } = node ^. node_hyperdata
 169
 170   chart <- case mChart of
 171     Just chart -> pure chart
 172     Nothing    -> do
 173       updateChart' cId maybeListId tabType Nothing
 174
 175   pure $ constructHashedResponse chart
 176
 177 updateChart :: HasNodeError err =>
 178   CorpusId
 179   -> Maybe ListId
 180   -> TabType
 181   -> Maybe Limit
 182   -> Cmd err ()
 183 updateChart cId maybeListId tabType maybeLimit = do
 184   _ <- updateChart' cId maybeListId tabType maybeLimit
 185   pure ()
 186
 187 updateChart' :: HasNodeError err =>
 188   CorpusId
 189   -> Maybe ListId
 190   -> TabType
 191   -> Maybe Limit
 192   -> Cmd err (ChartMetrics Histo)
 193 updateChart' cId maybeListId _tabType _maybeLimit = do
 194   listId <- case maybeListId of
 195     Just lid -> pure lid
 196     Nothing  -> defaultList cId
 197   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 198   let hl = node ^. node_hyperdata
 199   h <- histoData cId
 200   _ <- updateHyperdata listId $ hl { _hl_chart = Just $ ChartMetrics h }
 201
 202   pure $ ChartMetrics h
 203
 204
 205 getChartHash :: FlowCmdM env err m =>
 206   CorpusId
 207   -> Maybe ListId
 208   -> TabType
 209   -> m Text
 210 getChartHash cId maybeListId tabType = do
 211   hash <$> getChart cId Nothing Nothing maybeListId tabType
 212
 213 -------------------------------------------------------------
 214 -- | Pie metrics API
 215 type PieApi = Summary "Pie Chart"
 216            :> QueryParam "from" UTCTime
 217            :> QueryParam "to"   UTCTime
 218            :> QueryParam  "list"       ListId
 219            :> QueryParamR "ngramsType" TabType
 220            :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 221          :<|> Summary "Pie Chart update"
 222              :> QueryParam  "list"       ListId
 223              :> QueryParamR "ngramsType" TabType
 224              :> QueryParam  "limit"      Int
 225              :> Post '[JSON] ()
 226          :<|> "hash" :> Summary "Pie Hash"
 227                      :> QueryParam  "list"       ListId
 228                      :> QueryParamR "ngramsType" TabType
 229                      :> Get '[JSON] Text
 230
 231 pieApi :: NodeId -> GargServer PieApi
 232 pieApi id' = getPie id'
 233         :<|> updatePie id'
 234         :<|> getPieHash id'
 235
 236 getPie :: FlowCmdM env err m
 237        => CorpusId
 238        -> Maybe UTCTime
 239        -> Maybe UTCTime
 240        -> Maybe ListId
 241        -> TabType
 242        -> m (HashedResponse (ChartMetrics Histo))
 243 getPie cId _start _end maybeListId tabType = do
 244   listId <- case maybeListId of
 245     Just lid -> pure lid
 246     Nothing  -> defaultList cId
 247   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 248   let HyperdataList { _hl_pie = mChart } = node ^. node_hyperdata
 249
 250   chart <- case mChart of
 251     Just chart -> pure chart
 252     Nothing    -> do
 253       updatePie' cId maybeListId tabType Nothing
 254
 255   pure $ constructHashedResponse chart
 256
 257 updatePie :: FlowCmdM env err m =>
 258   CorpusId
 259   -> Maybe ListId
 260   -> TabType
 261   -> Maybe Limit
 262   -> m ()
 263 updatePie cId maybeListId tabType maybeLimit = do
 264   _ <- updatePie' cId maybeListId tabType maybeLimit
 265   pure ()
 266
 267 updatePie' :: FlowCmdM env err m =>
 268   CorpusId
 269   -> Maybe ListId
 270   -> TabType
 271   -> Maybe Limit
 272   -> m (ChartMetrics Histo)
 273 updatePie' cId maybeListId tabType _maybeLimit = do
 274   listId <- case maybeListId of
 275     Just lid -> pure lid
 276     Nothing  -> defaultList cId
 277   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 278   let hl = node ^. node_hyperdata
 279
 280   p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
 281   _ <- updateHyperdata listId $ hl { _hl_pie = Just $ ChartMetrics p }
 282
 283   pure $ ChartMetrics p
 284
 285 getPieHash :: FlowCmdM env err m =>
 286   CorpusId
 287   -> Maybe ListId
 288   -> TabType
 289   -> m Text
 290 getPieHash cId maybeListId tabType = do
 291   hash <$> getPie cId Nothing Nothing maybeListId tabType
 292
 293 -------------------------------------------------------------
 294 -- | Tree metrics API
 295
 296 type TreeApi = Summary " Tree API"
 297            :> QueryParam "from" UTCTime
 298            :> QueryParam "to"   UTCTime
 299            :> QueryParam  "list"       ListId
 300            :> QueryParamR "ngramsType" TabType
 301            :> QueryParamR "listType"   ListType
 302            :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
 303         :<|> Summary "Tree Chart update"
 304                 :> QueryParam  "list"       ListId
 305                 :> QueryParamR "ngramsType" TabType
 306                 :> QueryParamR "listType"   ListType
 307                 :> Post '[JSON] ()
 308           :<|> "hash" :>
 309                   Summary "Tree Hash"
 310               :> QueryParam  "list"       ListId
 311               :> QueryParamR "ngramsType" TabType
 312               :> QueryParamR "listType"   ListType
 313               :> Get '[JSON] Text
 314
 315                 -- Depending on the Type of the Node, we could post
 316                 -- New documents for a corpus
 317                 -- New map list terms
 318              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 319
 320 treeApi :: NodeId -> GargServer TreeApi
 321 treeApi id' = getTree id'
 322          :<|> updateTree id'
 323          :<|> getTreeHash id'
 324
 325 getTree :: FlowCmdM env err m
 326         => CorpusId
 327         -> Maybe UTCTime
 328         -> Maybe UTCTime
 329         -> Maybe ListId
 330         -> TabType
 331         -> ListType
 332         -> m (HashedResponse (ChartMetrics [MyTree]))
 333 getTree cId _start _end maybeListId tabType listType = do
 334   listId <- case maybeListId of
 335     Just lid -> pure lid
 336     Nothing  -> defaultList cId
 337
 338   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 339   let HyperdataList { _hl_tree = mChart } = node ^. node_hyperdata
 340
 341   chart <- case mChart of
 342     Just chart -> pure chart
 343     Nothing    -> do
 344       updateTree' cId maybeListId tabType listType
 345
 346   pure $ constructHashedResponse chart
 347
 348 updateTree :: FlowCmdM env err m =>
 349   CorpusId
 350   -> Maybe ListId
 351   -> TabType
 352   -> ListType
 353   -> m ()
 354 updateTree cId maybeListId tabType listType = do
 355   _ <- updateTree' cId maybeListId tabType listType
 356   pure ()
 357
 358 updateTree' :: FlowCmdM env err m =>
 359   CorpusId
 360   -> Maybe ListId
 361   -> TabType
 362   -> ListType
 363   -> m (ChartMetrics [MyTree])
 364 updateTree' cId maybeListId tabType listType = do
 365   listId <- case maybeListId of
 366     Just lid -> pure lid
 367     Nothing  -> defaultList cId
 368
 369   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 370   let hl = node ^. node_hyperdata
 371   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 372   _ <- updateHyperdata listId $ hl { _hl_tree = Just $ ChartMetrics t }
 373
 374   pure $ ChartMetrics t
 375
 376 getTreeHash :: FlowCmdM env err m =>
 377   CorpusId
 378   -> Maybe ListId
 379   -> TabType
 380   -> ListType
 381   -> m Text
 382 getTreeHash cId maybeListId tabType listType = do
 383   hash <$> getTree cId Nothing Nothing maybeListId tabType listType