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