Revert "[phylo] quality function reparameterized to have high levels for lambda-...
[gargantext.git] / src / Gargantext / API / Metrics.hs
index b70dececbd7f96fc49929cf44dac703bafe12318..1376012f4c31096fd063d9d350b90ab59cf8b531 100644 (file)
@@ -13,33 +13,36 @@ Metrics API
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 
 module Gargantext.API.Metrics
     where
 
 import Control.Lens
+import Data.Text (Text)
 import Data.Time (UTCTime)
-import Servant
-import qualified Data.Map as Map
-
-import Gargantext.API.Ngrams
-import Gargantext.API.Ngrams.NTree
+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 qualified Gargantext.Database.Action.Metrics as Metrics
+import Gargantext.Core.Viz.Chart
+import Gargantext.Core.Viz.Types
 import Gargantext.Database.Action.Flow
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..))
+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.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.Prelude
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
-import Gargantext.Text.Metrics (Scored(..))
-import Gargantext.Viz.Chart
-import Gargantext.Viz.Types
+import Servant
+import qualified Data.HashMap.Strict                as HashMap
+import qualified Gargantext.Database.Action.Metrics as Metrics
 
 -------------------------------------------------------------
 -- | Scatter metrics API
@@ -47,31 +50,42 @@ type ScatterAPI = Summary "SepGen IncExc metrics"
                   :> QueryParam  "list"       ListId
                   :> QueryParamR "ngramsType" TabType
                   :> QueryParam  "limit"      Int
-                  :> Get '[JSON] Metrics
+                  :> 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 Metrics
+  -> 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 { hd_scatter = mChart }) = node ^. node_hyperdata
+  let HyperdataList { _hl_scatter = scatterMap } = node ^. node_hyperdata
+      mChart = HashMap.lookup tabType scatterMap
 
-  case mChart of
+  chart <- case mChart of
     Just chart -> pure chart
     Nothing    -> do
-      s <- updateScatter' cId maybeListId tabType Nothing
-      pure s
+      updateScatter' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
 
 updateScatter :: FlowCmdM env err m =>
   CorpusId
@@ -80,6 +94,10 @@ updateScatter :: FlowCmdM env err m =>
   -> 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 ()
 
@@ -93,23 +111,29 @@ updateScatter' cId maybeListId tabType maybeLimit = do
   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 
   let
-    metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
-    log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
-    listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
+    metrics      = fmap (\(Scored t s1 s2) -> Metric (unNgramsTerm t) s1 s2 (listType t ngs'))
+                 $ fmap normalizeLocal scores
+    listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
     errorMsg     = "API.Node.metrics: key absent"
 
   listId <- case maybeListId of
     Just lid -> pure lid
     Nothing  -> defaultList cId
   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
-  let (HyperdataList { hd_chart = hdc
-                     , hd_list = hdl
-                     , hd_pie = hdp
-                     , hd_tree = hdt }) = node ^. node_hyperdata
-  _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp (Just $ Metrics metrics) hdt
+  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
+
 
 -------------------------------------------------------------
 -- | Chart metrics API
@@ -118,33 +142,44 @@ type ChartApi = Summary " Chart API"
               :> QueryParam "to"   UTCTime
               :> QueryParam  "list"       ListId
               :> QueryParamR "ngramsType" TabType
-              :> Get '[JSON] (ChartMetrics Histo)
-        :<|> Summary "Chart update"
-                :> QueryParam  "list"       ListId
-                :> QueryParamR "ngramsType" TabType
-                :> QueryParam  "limit"      Int
-                :> Post '[JSON] ()
-               
+              :> 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 :: HasNodeError err
-         => CorpusId
+getChart :: FlowCmdM env err m =>
+            CorpusId
          -> Maybe UTCTime
          -> Maybe UTCTime
          -> Maybe ListId
          -> TabType
-         -> Cmd err (ChartMetrics Histo)
+         -> 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 (HyperdataList { hd_chart = mChart }) = node ^. node_hyperdata
+  let chartMap = node ^. node_hyperdata ^. hl_chart
+      mChart = HashMap.lookup tabType chartMap
 
-  case mChart of
+  chart <- case mChart of
     Just chart -> pure chart
     Nothing    -> do
-      h <- updateChart' cId maybeListId tabType Nothing
-      pure h
+      updateChart' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
 
 updateChart :: HasNodeError err =>
   CorpusId
@@ -153,6 +188,10 @@ updateChart :: HasNodeError err =>
   -> 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 ()
 
@@ -162,19 +201,27 @@ updateChart' :: HasNodeError err =>
   -> TabType
   -> Maybe Limit
   -> Cmd err (ChartMetrics Histo)
-updateChart' cId maybeListId _tabType _maybeLimit = do
+updateChart' cId maybeListId tabType _maybeLimit = do
   listId <- case maybeListId of
     Just lid -> pure lid
     Nothing  -> defaultList cId
   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
-  let (HyperdataList { hd_list = hdl
-                     , hd_pie = hdp
-                     , hd_scatter = hds
-                     , hd_tree = hdt }) = node ^. node_hyperdata
+  let hl = node ^. node_hyperdata
+      chartMap = hl ^. hl_chart
   h <- histoData cId
-  _ <- updateHyperdata listId $ HyperdataList (Just $ ChartMetrics h) hdl hdp hds hdt
+  _ <- 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"
@@ -182,12 +229,21 @@ type PieApi = Summary "Pie Chart"
            :> QueryParam "to"   UTCTime
            :> QueryParam  "list"       ListId
            :> QueryParamR "ngramsType" TabType
-           :> Get '[JSON] (ChartMetrics Histo)
-        :<|> Summary "Pie Chart update"
-                :> QueryParam  "list"       ListId
-                :> QueryParamR "ngramsType" TabType
-                :> QueryParam  "limit"      Int
-                :> Post '[JSON] ()
+           :> 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
+
+pieApi :: NodeId -> GargServer PieApi
+pieApi id' = getPie id'
+        :<|> updatePie id'
+        :<|> getPieHash id'
 
 getPie :: FlowCmdM env err m
        => CorpusId
@@ -195,19 +251,21 @@ getPie :: FlowCmdM env err m
        -> Maybe UTCTime
        -> Maybe ListId
        -> TabType
-       -> m (ChartMetrics Histo)
+       -> 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 (HyperdataList { hd_pie = mChart }) = node ^. node_hyperdata
+  let pieMap = node ^. node_hyperdata ^. hl_pie
+      mChart = HashMap.lookup tabType pieMap
 
-  case mChart of
+  chart <- case mChart of
     Just chart -> pure chart
     Nothing    -> do
-      p <- updatePie' cId maybeListId tabType Nothing
-      pure p
+      updatePie' cId maybeListId tabType Nothing
+
+  pure $ constructHashedResponse chart
 
 updatePie :: FlowCmdM env err m =>
   CorpusId
@@ -216,6 +274,10 @@ updatePie :: FlowCmdM env err m =>
   -> 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 ()
 
@@ -230,16 +292,22 @@ updatePie' cId maybeListId tabType _maybeLimit = do
     Just lid -> pure lid
     Nothing  -> defaultList cId
   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
-  let (HyperdataList { hd_chart = hdc
-                     , hd_list = hdl
-                     , hd_scatter = hds
-                     , hd_tree = hdt }) = node ^. node_hyperdata
+  let hl = node ^. node_hyperdata
+      pieMap = hl ^. hl_pie
 
-  p <- pieData cId (ngramsTypeFromTabType tabType) GraphTerm
-  _ <- updateHyperdata listId $ HyperdataList hdc hdl (Just $ ChartMetrics p) hds hdt
+  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
 
@@ -249,17 +317,22 @@ type TreeApi = Summary " Tree API"
            :> QueryParam  "list"       ListId
            :> QueryParamR "ngramsType" TabType
            :> QueryParamR "listType"   ListType
-           :> Get '[JSON] (ChartMetrics [MyTree])
+           :> Get '[JSON] (HashedResponse (ChartMetrics (Vector NgramsTree)))
         :<|> Summary "Tree Chart update"
                 :> QueryParam  "list"       ListId
                 :> QueryParamR "ngramsType" TabType
                 :> QueryParamR "listType"   ListType
                 :> Post '[JSON] ()
-
-                -- Depending on the Type of the Node, we could post
-                -- New documents for a corpus
-                -- New map list terms
-             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
+          :<|> "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
@@ -268,19 +341,22 @@ getTree :: FlowCmdM env err m
         -> Maybe ListId
         -> TabType
         -> ListType
-        -> m (ChartMetrics [MyTree])
+        -> 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 (HyperdataList { hd_tree = mChart }) = node ^. node_hyperdata
-  case mChart of
+  let treeMap = node ^. node_hyperdata ^. hl_tree
+      mChart = HashMap.lookup tabType treeMap
+
+  chart <- case mChart of
     Just chart -> pure chart
     Nothing    -> do
-      t <- updateTree' cId maybeListId tabType listType
-      pure t
+      updateTree' cId maybeListId tabType listType
+
+  pure $ constructHashedResponse chart
 
 updateTree :: FlowCmdM env err m =>
   CorpusId
@@ -289,6 +365,10 @@ updateTree :: FlowCmdM env err m =>
   -> 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 ()
 
@@ -297,18 +377,25 @@ updateTree' :: FlowCmdM env err m =>
   -> Maybe ListId
   -> TabType
   -> ListType
-  -> m (ChartMetrics [MyTree])
+  -> 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 (HyperdataList { hd_chart = hdc
-                     , hd_list = hdl
-                     , hd_scatter = hds
-                     , hd_pie = hdp }) = node ^. node_hyperdata
+  let hl      = node ^. node_hyperdata
+      treeMap = hl  ^. hl_tree
   t <- treeData cId (ngramsTypeFromTabType tabType) listType
-  _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp hds (Just $ ChartMetrics t)
+  _ <- 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