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 DataKinds          #-}
  17 {-# LANGUAGE DeriveGeneric      #-}
  18 {-# LANGUAGE FlexibleContexts   #-}
  19 {-# LANGUAGE NoImplicitPrelude  #-}
  20 {-# LANGUAGE OverloadedStrings  #-}
  21 {-# LANGUAGE RankNTypes         #-}
  22 {-# LANGUAGE TemplateHaskell    #-}
  23 {-# LANGUAGE TypeOperators      #-}
  24
  25 module Gargantext.API.Metrics
  26     where
  27
  28 import Data.Aeson.TH (deriveJSON)
  29 import Data.Swagger
  30 import Data.Text (Text)
  31 import Data.Time (UTCTime)
  32 import GHC.Generics (Generic)
  33 import Gargantext.API.Ngrams
  34 import Gargantext.API.Ngrams.NTree
  35 import Gargantext.Core.Types (CorpusId, ListId, Limit)
  36 import Gargantext.Core.Types (ListType(..))
  37 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  38 import Gargantext.Database.Action.Flow
  39 import Gargantext.Database.Admin.Utils
  40 import Gargantext.Prelude
  41 import Gargantext.Text.Metrics (Scored(..))
  42 import Gargantext.Viz.Chart
  43 import Servant
  44 import Test.QuickCheck (elements)
  45 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  46 import qualified Data.Map as Map
  47 import qualified Gargantext.Database.Action.Metrics as Metrics
  48
  49 data Metrics = Metrics
  50   { metrics_data :: [Metric]}
  51   deriving (Generic, Show)
  52
  53 instance ToSchema Metrics where
  54   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "metrics_")
  55 instance Arbitrary Metrics
  56   where
  57     arbitrary = Metrics <$> arbitrary
  58
  59 data Metric = Metric
  60   { m_label :: !Text
  61   , m_x     :: !Double
  62   , m_y     :: !Double
  63   , m_cat   :: !ListType
  64   } deriving (Generic, Show)
  65
  66 instance ToSchema Metric where
  67   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "m_")
  68 instance Arbitrary Metric
  69   where
  70     arbitrary = Metric <$> arbitrary
  71                        <*> arbitrary
  72                        <*> arbitrary
  73                        <*> arbitrary
  74
  75 deriveJSON (unPrefix "metrics_") ''Metrics
  76 deriveJSON (unPrefix "m_") ''Metric
  77
  78 -------------------------------------------------------------
  79
  80 data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
  81   deriving (Generic, Show)
  82
  83 instance (ToSchema a) => ToSchema (ChartMetrics a) where
  84   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "chartMetrics_")
  85 instance (Arbitrary a) => Arbitrary (ChartMetrics a)
  86   where
  87     arbitrary = ChartMetrics <$> arbitrary
  88
  89 deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
  90
  91 -------------------------------------------------------------
  92 instance ToSchema Histo where
  93   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "histo_")
  94 instance Arbitrary Histo
  95   where
  96     arbitrary = elements [ Histo ["2012"] [1]
  97                          , Histo ["2013"] [1]
  98                          ]
  99 deriveJSON (unPrefix "histo_") ''Histo
 100
 101
 102
 103 -------------------------------------------------------------
 104 -- | Scatter metrics API
 105 type ScatterAPI = Summary "SepGen IncExc metrics"
 106                 :> QueryParam  "list"       ListId
 107                 :> QueryParamR "ngramsType" TabType
 108                 :> QueryParam  "limit"      Int
 109                 :> Get '[JSON] Metrics
 110
 111 getScatter :: FlowCmdM env err m =>
 112   CorpusId
 113   -> Maybe ListId
 114   -> TabType
 115   -> Maybe Limit
 116   -> m Metrics
 117 getScatter cId maybeListId tabType maybeLimit = do
 118   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 119
 120   let
 121     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
 122     log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
 123     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 124     errorMsg     = "API.Node.metrics: key absent"
 125
 126   pure $ Metrics metrics
 127
 128
 129
 130 -- TODO add start / end
 131 getChart :: CorpusId -> Maybe UTCTime -> Maybe UTCTime -> Cmd err (ChartMetrics Histo)
 132 getChart cId _start _end = do
 133   h <- histoData cId
 134   pure (ChartMetrics h)
 135
 136 getPie :: FlowCmdM env err m => CorpusId -> Maybe UTCTime -> Maybe UTCTime -> TabType -> m (ChartMetrics Histo)
 137 getPie cId _start _end tt = do
 138   p <- pieData cId (ngramsTypeFromTabType tt) GraphTerm
 139   pure (ChartMetrics p)
 140
 141 getTree :: FlowCmdM env err m => CorpusId -> Maybe UTCTime -> Maybe UTCTime -> TabType -> ListType -> m (ChartMetrics [MyTree])
 142 getTree cId _start _end tt lt = do
 143   p <- treeData cId (ngramsTypeFromTabType tt) lt
 144   pure (ChartMetrics p)
 145
 146
 147