[FIX] Order 1 and Order 2, node size ok.
[gargantext.git] / src / Gargantext / API / Metrics.hs
index 8eb067653d80b8126bc522307268144b287ff64a..357653740a71b71f45929c141e6f2c579a84f7c6 100644 (file)
@@ -13,100 +13,392 @@ Metrics API
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RankNTypes         #-}
-{-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 
 module Gargantext.API.Metrics
     where
 
-import Data.Aeson.TH (deriveJSON)
-import Data.Swagger
-import Data.Time (UTCTime)
+import Control.Lens
 import Data.Text (Text)
-import GHC.Generics (Generic)
-import Gargantext.Core.Types (ListType(..))
-import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Utils
-import Gargantext.Core.Types (CorpusId)
+import Data.Time (UTCTime)
+import Data.Vector (Vector)
+import Gargantext.API.HashedResponse
+import Gargantext.API.Ngrams.NgramsTree
+import Gargantext.API.Ngrams.Types
+import Gargantext.API.Prelude (GargServer)
+import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
+import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
+import Gargantext.Core.Viz.Chart
+import Gargantext.Core.Viz.Types
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
+import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
+import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
-import Gargantext.Viz.Chart
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-
-data Metrics = Metrics
-  { metrics_data :: [Metric]}
-  deriving (Generic, Show)
-
-instance ToSchema Metrics
-instance Arbitrary Metrics
-  where
-    arbitrary = Metrics <$> arbitrary
-
-data Metric = Metric
-  { m_label :: !Text
-  , m_x     :: !Double
-  , m_y     :: !Double
-  , m_cat   :: !ListType
-  } deriving (Generic, Show)
-
-instance ToSchema Metric
-instance Arbitrary Metric
-  where
-    arbitrary = Metric <$> arbitrary
-                       <*> arbitrary
-                       <*> arbitrary
-                       <*> arbitrary
-
-deriveJSON (unPrefix "metrics_") ''Metrics
-deriveJSON (unPrefix "m_") ''Metric
-
+import Servant
+import qualified Data.HashMap.Strict                as HashMap
+import qualified Gargantext.Database.Action.Metrics as Metrics
 
 -------------------------------------------------------------
+-- | Scatter metrics API
+type ScatterAPI = Summary "SepGen IncExc metrics"
+                  :> QueryParam  "list"       ListId
+                  :> QueryParamR "ngramsType" TabType
+                  :> QueryParam  "limit"      Int
+                  :> Get '[JSON] (HashedResponse Metrics)
+              :<|> Summary "Scatter update"
+                  :> QueryParam  "list"       ListId
+                  :> QueryParamR "ngramsType" TabType
+                  :> QueryParam  "limit"      Int
+                  :> Post '[JSON] ()
+              :<|> "hash" :> Summary "Scatter Hash"
+                          :> QueryParam  "list"       ListId
+                          :> QueryParamR "ngramsType" TabType
+                          :> Get '[JSON] Text
+
+scatterApi :: NodeId -> GargServer ScatterAPI
+scatterApi id' = getScatter id'
+            :<|> updateScatter id'
+            :<|> getScatterHash id'
+
+getScatter :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m (HashedResponse Metrics)
+getScatter cId maybeListId tabType _maybeLimit = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let HyperdataList { _hl_scatter = scatterMap } = node ^. node_hyperdata
+      mChart = HashMap.lookup tabType scatterMap
+
+  chart <- case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      updateScatter' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
+
+updateScatter :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m ()
+updateScatter cId maybeListId tabType maybeLimit = do
+  printDebug "[updateScatter] cId" cId
+  printDebug "[updateScatter] maybeListId" maybeListId
+  printDebug "[updateScatter] tabType" tabType
+  printDebug "[updateScatter] maybeLimit" maybeLimit
+  _ <- updateScatter' cId maybeListId tabType maybeLimit
+  pure ()
+
+updateScatter' :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m Metrics
+updateScatter' cId maybeListId tabType maybeLimit = do
+  (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 
-data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
-  deriving (Generic, Show)
+  let
+    metrics      = fmap (\(Scored t s1 s2) -> Metric { m_label = unNgramsTerm t
+                                                     , m_x = s1
+                                                     , m_y = s2
+                                                     , m_cat = listType t ngs' })
+                 $ fmap normalizeLocal scores
+    listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
+    errorMsg     = "API.Node.metrics: key absent"
 
-instance (ToSchema a) => ToSchema (ChartMetrics a)
-instance (Arbitrary a) => Arbitrary (ChartMetrics a)
-  where
-    arbitrary = ChartMetrics <$> arbitrary
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let hl = node ^. node_hyperdata
+      scatterMap = hl ^. hl_scatter
+  _ <- updateHyperdata listId $ hl { _hl_scatter = HashMap.insert tabType (Metrics metrics) scatterMap }
+
+  pure $ Metrics metrics
+
+getScatterHash :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> m Text
+getScatterHash cId maybeListId tabType = do
+  hash <$> getScatter cId maybeListId tabType Nothing
 
-deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
 
 -------------------------------------------------------------
-instance ToSchema Histo
-instance Arbitrary Histo
-  where
-    arbitrary = elements [ Histo ["2012"] [1]
-                         , Histo ["2013"] [1]
-                         ]
-deriveJSON (unPrefix "histo_") ''Histo
+-- | Chart metrics API
+type ChartApi = Summary " Chart API"
+              :> QueryParam "from" UTCTime
+              :> QueryParam "to"   UTCTime
+              :> QueryParam  "list"       ListId
+              :> QueryParamR "ngramsType" TabType
+              :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
+            :<|> Summary "Chart update"
+               :> QueryParam  "list"       ListId
+               :> QueryParamR "ngramsType" TabType
+               :> QueryParam  "limit"      Int
+               :> Post '[JSON] ()
+            :<|> "hash" :> Summary "Chart Hash"
+               :> QueryParam  "list"       ListId
+               :> QueryParamR "ngramsType" TabType
+               :> Get '[JSON] Text
 
+chartApi :: NodeId -> GargServer ChartApi
+chartApi id' = getChart id'
+          :<|> updateChart id'
+          :<|> getChartHash id'
 
 -- TODO add start / end
-getChart :: CorpusId -> Maybe UTCTime -> Maybe UTCTime -> Cmd err (ChartMetrics Histo)
-getChart cId _start _end = do
+getChart :: FlowCmdM env err m =>
+            CorpusId
+         -> Maybe UTCTime
+         -> Maybe UTCTime
+         -> Maybe ListId
+         -> TabType
+         -> m (HashedResponse (ChartMetrics Histo))
+getChart cId _start _end maybeListId tabType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let chartMap = node ^. node_hyperdata ^. hl_chart
+      mChart = HashMap.lookup tabType chartMap
+
+  chart <- case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      updateChart' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
+
+updateChart :: HasNodeError err =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> Cmd err ()
+updateChart cId maybeListId tabType maybeLimit = do
+  printDebug "[updateChart] cId" cId
+  printDebug "[updateChart] maybeListId" maybeListId
+  printDebug "[updateChart] tabType" tabType
+  printDebug "[updateChart] maybeLimit" maybeLimit
+  _ <- updateChart' cId maybeListId tabType maybeLimit
+  pure ()
+
+updateChart' :: HasNodeError err =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> Cmd err (ChartMetrics Histo)
+updateChart' cId maybeListId tabType _maybeLimit = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let hl = node ^. node_hyperdata
+      chartMap = hl ^. hl_chart
   h <- histoData cId
-  pure (ChartMetrics h)
+  _ <- updateHyperdata listId $ hl { _hl_chart = HashMap.insert tabType (ChartMetrics h) chartMap }
+
+  pure $ ChartMetrics h
 
 
+getChartHash :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> m Text
+getChartHash cId maybeListId tabType = do
+  hash <$> getChart cId Nothing Nothing maybeListId tabType
+-------------------------------------------------------------
+-- | Pie metrics API
+type PieApi = Summary "Pie Chart"
+           :> QueryParam "from" UTCTime
+           :> QueryParam "to"   UTCTime
+           :> QueryParam  "list"       ListId
+           :> QueryParamR "ngramsType" TabType
+           :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
+         :<|> Summary "Pie Chart update"
+             :> QueryParam  "list"       ListId
+             :> QueryParamR "ngramsType" TabType
+             :> QueryParam  "limit"      Int
+             :> Post '[JSON] ()
+         :<|> "hash" :> Summary "Pie Hash"
+                     :> QueryParam  "list"       ListId
+                     :> QueryParamR "ngramsType" TabType
+                     :> Get '[JSON] Text
 
-{-
-data FacetChart = FacetChart { facetChart_time  :: UTCTime'
-                             , facetChart_count :: Double
-                        }
-        deriving (Show, Generic)
-$(deriveJSON (unPrefix "facetChart_") ''FacetChart)
-instance ToSchema FacetChart
+pieApi :: NodeId -> GargServer PieApi
+pieApi id' = getPie id'
+        :<|> updatePie id'
+        :<|> getPieHash id'
 
-instance Arbitrary FacetChart where
-    arbitrary = FacetChart <$> arbitrary <*> arbitrary
+getPie :: FlowCmdM env err m
+       => CorpusId
+       -> Maybe UTCTime
+       -> Maybe UTCTime
+       -> Maybe ListId
+       -> TabType
+       -> m (HashedResponse (ChartMetrics Histo))
+getPie cId _start _end maybeListId tabType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let pieMap = node ^. node_hyperdata ^. hl_pie
+      mChart = HashMap.lookup tabType pieMap
 
--}
+  chart <- case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      updatePie' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
+
+updatePie :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m ()
+updatePie cId maybeListId tabType maybeLimit = do
+  printDebug "[updatePie] cId" cId
+  printDebug "[updatePie] maybeListId" maybeListId
+  printDebug "[updatePie] tabType" tabType
+  printDebug "[updatePie] maybeLimit" maybeLimit
+  _ <- updatePie' cId maybeListId tabType maybeLimit
+  pure ()
+
+updatePie' :: FlowCmdM env err m =>
+     CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m (ChartMetrics Histo)
+updatePie' cId maybeListId tabType _maybeLimit = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let hl = node ^. node_hyperdata
+      pieMap = hl ^. hl_pie
+
+  p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
+  _ <- updateHyperdata listId $ hl { _hl_pie = HashMap.insert tabType (ChartMetrics p) pieMap }
+
+  pure $ ChartMetrics p
+
+getPieHash :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> m Text
+getPieHash cId maybeListId tabType = do
+  hash <$> getPie cId Nothing Nothing maybeListId tabType
+
+-------------------------------------------------------------
+-- | Tree metrics API
+
+type TreeApi = Summary " Tree API"
+           :> QueryParam "from" UTCTime
+           :> QueryParam "to"   UTCTime
+           :> QueryParam  "list"       ListId
+           :> QueryParamR "ngramsType" TabType
+           :> QueryParamR "listType"   ListType
+           :> Get '[JSON] (HashedResponse (ChartMetrics (Vector NgramsTree)))
+        :<|> Summary "Tree Chart update"
+                :> QueryParam  "list"       ListId
+                :> QueryParamR "ngramsType" TabType
+                :> QueryParamR "listType"   ListType
+                :> Post '[JSON] ()
+          :<|> "hash" :>
+                 Summary "Tree Hash"
+              :> QueryParam  "list"       ListId
+              :> QueryParamR "ngramsType" TabType
+              :> QueryParamR "listType"   ListType
+              :> Get '[JSON] Text
+treeApi :: NodeId -> GargServer TreeApi
+treeApi id' = getTree id'
+         :<|> updateTree id'
+         :<|> getTreeHash id'
+
+getTree :: FlowCmdM env err m
+        => CorpusId
+        -> Maybe UTCTime
+        -> Maybe UTCTime
+        -> Maybe ListId
+        -> TabType
+        -> ListType
+        -> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
+getTree cId _start _end maybeListId tabType listType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let treeMap = node ^. node_hyperdata ^. hl_tree
+      mChart = HashMap.lookup tabType treeMap
+
+  chart <- case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      updateTree' cId maybeListId tabType listType
+
+  pure $ constructHashedResponse chart
+
+updateTree :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> ListType
+  -> m ()
+updateTree cId maybeListId tabType listType = do
+  printDebug "[updateTree] cId" cId
+  printDebug "[updateTree] maybeListId" maybeListId
+  printDebug "[updateTree] tabType" tabType
+  printDebug "[updateTree] listType" listType
+  _ <- updateTree' cId maybeListId tabType listType
+  pure ()
+
+updateTree' :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> ListType
+  -> m (ChartMetrics (Vector NgramsTree))
+updateTree' cId maybeListId tabType listType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let hl      = node ^. node_hyperdata
+      treeMap = hl  ^. hl_tree
+  t <- treeData cId (ngramsTypeFromTabType tabType) listType
+  _ <- updateHyperdata listId $ hl { _hl_tree = HashMap.insert tabType (ChartMetrics t) treeMap }
+
+  pure $ ChartMetrics t
 
+getTreeHash :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> ListType
+  -> m Text
+getTreeHash cId maybeListId tabType listType = do
+  hash <$> getTree cId Nothing Nothing maybeListId tabType listType