]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Metrics.hs
seuil
[gargantext.git] / 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.Time (UTCTime)
31 import Data.Text (Text)
32 import GHC.Generics (Generic)
33 import Gargantext.Core.Types (ListType(..))
34 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
35 import Gargantext.Database.Utils
36 import Gargantext.Core.Types (CorpusId, ListId, Limit)
37 import Gargantext.Prelude
38 import Gargantext.API.Ngrams
39 import Gargantext.Text.Metrics (Scored(..))
40 import Gargantext.API.Ngrams.NTree
41 import Gargantext.Database.Flow
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.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