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 TemplateHaskell    #-}
  17 {-# LANGUAGE TypeOperators      #-}
  18
  19 module Gargantext.API.Metrics
  20     where
  21
  22 import Control.Lens
  23 import Data.Time (UTCTime)
  24 import Servant
  25 import qualified Data.Map as Map
  26
  27 import Gargantext.API.Ngrams
  28 import Gargantext.API.Ngrams.NTree
  29 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
  30 import qualified Gargantext.Database.Action.Metrics as Metrics
  31 import Gargantext.Database.Action.Flow
  32 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..))
  33 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
  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.Prelude
  38 import Gargantext.Database.Schema.Node (node_hyperdata)
  39 import Gargantext.Prelude
  40 import Gargantext.Text.Metrics (Scored(..))
  41 import Gargantext.Viz.Chart
  42 import Gargantext.Viz.Types
  43
  44 -------------------------------------------------------------
  45 -- | Scatter metrics API
  46 type ScatterAPI = Summary "SepGen IncExc metrics"
  47                   :> QueryParam  "list"       ListId
  48                   :> QueryParamR "ngramsType" TabType
  49                   :> QueryParam  "limit"      Int
  50                   :> Get '[JSON] Metrics
  51               :<|> Summary "Scatter update"
  52                   :> QueryParam  "list"       ListId
  53                   :> QueryParamR "ngramsType" TabType
  54                   :> QueryParam  "limit"      Int
  55                   :> Post '[JSON] ()
  56
  57 getScatter :: FlowCmdM env err m =>
  58   CorpusId
  59   -> Maybe ListId
  60   -> TabType
  61   -> Maybe Limit
  62   -> m Metrics
  63 getScatter cId maybeListId tabType _maybeLimit = do
  64   listId <- case maybeListId of
  65     Just lid -> pure lid
  66     Nothing  -> defaultList cId
  67   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
  68   let (HyperdataList { hd_scatter = mChart }) = node ^. node_hyperdata
  69
  70   case mChart of
  71     Just chart -> pure chart
  72     Nothing    -> do
  73       s <- updateScatter' cId maybeListId tabType Nothing
  74       pure s
  75
  76 updateScatter :: FlowCmdM env err m =>
  77   CorpusId
  78   -> Maybe ListId
  79   -> TabType
  80   -> Maybe Limit
  81   -> m ()
  82 updateScatter cId maybeListId tabType maybeLimit = do
  83   _ <- updateScatter' cId maybeListId tabType maybeLimit
  84   pure ()
  85
  86 updateScatter' :: FlowCmdM env err m =>
  87   CorpusId
  88   -> Maybe ListId
  89   -> TabType
  90   -> Maybe Limit
  91   -> m Metrics
  92 updateScatter' cId maybeListId tabType maybeLimit = do
  93   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
  94
  95   let
  96     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
  97     log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
  98     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
  99     errorMsg     = "API.Node.metrics: key absent"
 100
 101   listId <- case maybeListId of
 102     Just lid -> pure lid
 103     Nothing  -> defaultList cId
 104   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 105   let (HyperdataList { hd_chart = hdc
 106                      , hd_list = hdl
 107                      , hd_pie = hdp
 108                      , hd_tree = hdt }) = node ^. node_hyperdata
 109   _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp (Just $ Metrics metrics) hdt
 110
 111   pure $ Metrics metrics
 112
 113
 114 -------------------------------------------------------------
 115 -- | Chart metrics API
 116 type ChartApi = Summary " Chart API"
 117               :> QueryParam "from" UTCTime
 118               :> QueryParam "to"   UTCTime
 119               :> QueryParam  "list"       ListId
 120               :> QueryParamR "ngramsType" TabType
 121               :> Get '[JSON] (ChartMetrics Histo)
 122         :<|> Summary "Chart update"
 123                 :> QueryParam  "list"       ListId
 124                 :> QueryParamR "ngramsType" TabType
 125                 :> QueryParam  "limit"      Int
 126                 :> Post '[JSON] ()
 127
 128 -- TODO add start / end
 129 getChart :: HasNodeError err
 130          => CorpusId
 131          -> Maybe UTCTime
 132          -> Maybe UTCTime
 133          -> Maybe ListId
 134          -> TabType
 135          -> Cmd err (ChartMetrics Histo)
 136 getChart cId _start _end maybeListId tabType = do
 137   listId <- case maybeListId of
 138     Just lid -> pure lid
 139     Nothing  -> defaultList cId
 140   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 141   let (HyperdataList { hd_chart = mChart }) = node ^. node_hyperdata
 142
 143   case mChart of
 144     Just chart -> pure chart
 145     Nothing    -> do
 146       h <- updateChart' cId maybeListId tabType Nothing
 147       pure h
 148
 149 updateChart :: HasNodeError err =>
 150   CorpusId
 151   -> Maybe ListId
 152   -> TabType
 153   -> Maybe Limit
 154   -> Cmd err ()
 155 updateChart cId maybeListId tabType maybeLimit = do
 156   _ <- updateChart' cId maybeListId tabType maybeLimit
 157   pure ()
 158
 159 updateChart' :: HasNodeError err =>
 160   CorpusId
 161   -> Maybe ListId
 162   -> TabType
 163   -> Maybe Limit
 164   -> Cmd err (ChartMetrics Histo)
 165 updateChart' cId maybeListId _tabType _maybeLimit = 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 { hd_list = hdl
 171                      , hd_pie = hdp
 172                      , hd_scatter = hds
 173                      , hd_tree = hdt }) = node ^. node_hyperdata
 174   h <- histoData cId
 175   _ <- updateHyperdata listId $ HyperdataList (Just $ ChartMetrics h) hdl hdp hds hdt
 176
 177   pure $ ChartMetrics h
 178 -------------------------------------------------------------
 179 -- | Pie metrics API
 180 type PieApi = Summary "Pie Chart"
 181            :> QueryParam "from" UTCTime
 182            :> QueryParam "to"   UTCTime
 183            :> QueryParam  "list"       ListId
 184            :> QueryParamR "ngramsType" TabType
 185            :> Get '[JSON] (ChartMetrics Histo)
 186         :<|> Summary "Pie Chart update"
 187                 :> QueryParam  "list"       ListId
 188                 :> QueryParamR "ngramsType" TabType
 189                 :> QueryParam  "limit"      Int
 190                 :> Post '[JSON] ()
 191
 192 getPie :: FlowCmdM env err m
 193        => CorpusId
 194        -> Maybe UTCTime
 195        -> Maybe UTCTime
 196        -> Maybe ListId
 197        -> TabType
 198        -> m (ChartMetrics Histo)
 199 getPie cId _start _end maybeListId tabType = do
 200   listId <- case maybeListId of
 201     Just lid -> pure lid
 202     Nothing  -> defaultList cId
 203   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 204   let (HyperdataList { hd_pie = mChart }) = node ^. node_hyperdata
 205
 206   case mChart of
 207     Just chart -> pure chart
 208     Nothing    -> do
 209       p <- updatePie' cId maybeListId tabType Nothing
 210       pure p
 211
 212 updatePie :: FlowCmdM env err m =>
 213   CorpusId
 214   -> Maybe ListId
 215   -> TabType
 216   -> Maybe Limit
 217   -> m ()
 218 updatePie cId maybeListId tabType maybeLimit = do
 219   _ <- updatePie' cId maybeListId tabType maybeLimit
 220   pure ()
 221
 222 updatePie' :: FlowCmdM env err m =>
 223   CorpusId
 224   -> Maybe ListId
 225   -> TabType
 226   -> Maybe Limit
 227   -> m (ChartMetrics Histo)
 228 updatePie' cId maybeListId tabType _maybeLimit = do
 229   listId <- case maybeListId of
 230     Just lid -> pure lid
 231     Nothing  -> defaultList cId
 232   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 233   let (HyperdataList { hd_chart = hdc
 234                      , hd_list = hdl
 235                      , hd_scatter = hds
 236                      , hd_tree = hdt }) = node ^. node_hyperdata
 237
 238   p <- pieData cId (ngramsTypeFromTabType tabType) MapTerm
 239   _ <- updateHyperdata listId $ HyperdataList hdc hdl (Just $ ChartMetrics p) hds hdt
 240
 241   pure $ ChartMetrics p
 242
 243 -------------------------------------------------------------
 244 -- | Tree metrics API
 245
 246 type TreeApi = Summary " Tree API"
 247            :> QueryParam "from" UTCTime
 248            :> QueryParam "to"   UTCTime
 249            :> QueryParam  "list"       ListId
 250            :> QueryParamR "ngramsType" TabType
 251            :> QueryParamR "listType"   ListType
 252            :> Get '[JSON] (ChartMetrics [MyTree])
 253         :<|> Summary "Tree Chart update"
 254                 :> QueryParam  "list"       ListId
 255                 :> QueryParamR "ngramsType" TabType
 256                 :> QueryParamR "listType"   ListType
 257                 :> Post '[JSON] ()
 258
 259                 -- Depending on the Type of the Node, we could post
 260                 -- New documents for a corpus
 261                 -- New map list terms
 262              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 263
 264 getTree :: FlowCmdM env err m
 265         => CorpusId
 266         -> Maybe UTCTime
 267         -> Maybe UTCTime
 268         -> Maybe ListId
 269         -> TabType
 270         -> ListType
 271         -> m (ChartMetrics [MyTree])
 272 getTree cId _start _end maybeListId tabType listType = do
 273   listId <- case maybeListId of
 274     Just lid -> pure lid
 275     Nothing  -> defaultList cId
 276
 277   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 278   let (HyperdataList { hd_tree = mChart }) = node ^. node_hyperdata
 279   case mChart of
 280     Just chart -> pure chart
 281     Nothing    -> do
 282       t <- updateTree' cId maybeListId tabType listType
 283       pure t
 284
 285 updateTree :: FlowCmdM env err m =>
 286   CorpusId
 287   -> Maybe ListId
 288   -> TabType
 289   -> ListType
 290   -> m ()
 291 updateTree cId maybeListId tabType listType = do
 292   _ <- updateTree' cId maybeListId tabType listType
 293   pure ()
 294
 295 updateTree' :: FlowCmdM env err m =>
 296   CorpusId
 297   -> Maybe ListId
 298   -> TabType
 299   -> ListType
 300   -> m (ChartMetrics [MyTree])
 301 updateTree' cId maybeListId tabType listType = do
 302   listId <- case maybeListId of
 303     Just lid -> pure lid
 304     Nothing  -> defaultList cId
 305
 306   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 307   let (HyperdataList { hd_chart = hdc
 308                      , hd_list = hdl
 309                      , hd_scatter = hds
 310                      , hd_pie = hdp }) = node ^. node_hyperdata
 311   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 312   _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp hds (Just $ ChartMetrics t)
 313
 314   pure $ ChartMetrics t