Measure Phylo time via trackComputeTime

The tracking is not perfect yet, as it keeps storing only the latest
available compute time. Also, there seems to be some precision loss
between that is reported by `timeMeasured` and what gets stored in the
DB.

src/Gargantext/Core/Viz/Phylo.hs

@@ -29,20 +29,20 @@ one 8, e54847.
 
 module Gargantext.Core.Viz.Phylo where
 
+import Control.Lens (over)
 import Data.Swagger
 import Data.Text.Lazy qualified as TextLazy
 import Data.Text (pack)
-import Data.Time.Clock.POSIX (POSIXTime)
 import Data.TreeDiff (ToExpr (..))
 import Data.Vector (Vector)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
+import Gargantext.Utils.UTCTime (ElapsedSeconds)
 import qualified Data.Aeson.Types as JS
+import qualified Data.List.NonEmpty as NE
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Text()
 import Test.QuickCheck.Instances.Vector()
-import Data.Time (nominalDiffTimeToSeconds)
-import Data.Fixed (Fixed(..))
 
 ---------------------
 -- | PhyloConfig | --
@@ -117,18 +117,6 @@ data Synchrony =
 instance ToSchema Synchrony where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 
-newtype ElapsedSeconds = ElapsedSeconds { _Seconds :: POSIXTime }
-  deriving stock (Show, Eq, Generic)
-  deriving newtype (FromJSON, ToJSON)
-
-instance ToExpr ElapsedSeconds where
-  toExpr (ElapsedSeconds x) =
-    let (MkFixed secs) = nominalDiffTimeToSeconds x
-    in toExpr secs
-
-instance ToSchema ElapsedSeconds where
-  declareNamedSchema _ = declareNamedSchema (Proxy @Int)
-
 data TimeUnit =
       Epoch
       { _epoch_period :: Int
@@ -751,7 +739,6 @@ instance NFData PhyloParam
 instance NFData PhyloFoundations
 instance NFData PhyloCounts
 instance NFData PhyloSources
-instance NFData ElapsedSeconds
 instance NFData ComputeTimeHistory
 instance NFData Phylo
 instance NFData PhyloPeriod
@@ -843,3 +830,20 @@ instance Arbitrary Filter where
 
 instance Arbitrary PhyloParam where
   arbitrary = pure defaultPhyloParam
+
+--
+-- Functions that uses the lenses
+--
+
+-- | Adds the input 'ElapsedSeconds' to the 'Philo', in the 'ComputeTimeHistory'.
+trackComputeTime :: ElapsedSeconds -> Phylo -> Phylo
+trackComputeTime elapsedSecs = over phylo_computeTime update_time
+  where
+    -- In case we have more than one historical data available, we take only the last 5
+    -- runs, to not make the list unbounded.
+    update_time :: ComputeTimeHistory -> ComputeTimeHistory
+    update_time NoHistoricalDataAvailable
+      = ComputeTimeHistory (NE.singleton elapsedSecs)
+    update_time (ComputeTimeHistory (r NE.:| runs)) =
+      ComputeTimeHistory (elapsedSecs NE.:| (r : take 3 runs))
+

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -33,7 +33,7 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory)
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
 import Gargantext.Core.Types.Main (ListType(MapTerm))
-import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
+import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo, trackComputeTime)
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
@@ -49,7 +49,7 @@ import Gargantext.Database.Schema.Context ( ContextPoly(_context_hyperdata, _con
 import Gargantext.Database.Schema.Node ( NodePoly(_node_hyperdata), node_hyperdata )
 import Gargantext.Prelude hiding (to)
 import Gargantext.System.Logging ( MonadLogger, LogLevel(DEBUG), logLocM )
-import Gargantext.Utils.UTCTime (timeMeasured)
+import Gargantext.Utils.UTCTime (timeMeasured, timeMeasured'')
 import Prelude qualified
 import System.FilePath ((</>))
 import System.IO.Temp (withTempDirectory)
@@ -113,17 +113,15 @@ phylo2dot phylo = do
 flowPhyloAPI :: (HasNodeStory env err m, HasNodeError err, MonadLogger m)
              => PhyloConfig -> CorpusId -> m Phylo
 flowPhyloAPI config cId = do
-  corpus <- corpusIdtoDocuments (timeUnit config) cId
-  let !phyloWithCliques = toPhyloWithoutLink corpus config
+  corpus <- timeMeasured "flowPhyloAPI.corpusIdtoDocuments" $ corpusIdtoDocuments (timeUnit config) cId
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   $(logLocM) DEBUG $ "PhyloConfig old: " <> show config
 
-  _ <- timeMeasured "flowPhyloAPI.phyloWithCliques" (pure $! phyloWithCliques)
+  (t1, phyloWithCliques) <- timeMeasured'' DEBUG "flowPhyloAPI.phyloWithCliques" (pure $! toPhyloWithoutLink corpus config)
+  (t2, phyloConfigured)  <- timeMeasured'' DEBUG "flowPhyloAPI.phyloConfigured" (pure $! setConfig config phyloWithCliques)
+  (t3, finalPhylo)       <- timeMeasured'' DEBUG "flowPhyloAPI.toPhylo" (pure $! toPhylo phyloConfigured)
 
-  let !phyloConfigured = setConfig config phyloWithCliques
-  _ <- timeMeasured "flowPhyloAPI.phyloConfigured" (pure $! phyloConfigured)
-
-  pure $! toPhylo phyloConfigured
+  pure $! trackComputeTime (t1 + t2 + t3) finalPhylo
 
 --------------------------------------------------------------------
 corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)

src/Gargantext/Utils/UTCTime.hs

@@ -12,6 +12,8 @@ Portability : POSIX
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.Utils.UTCTime where
 
@@ -19,13 +21,15 @@ import Data.Morpheus.Kind (SCALAR)
 import Data.Morpheus.Types (GQLType(..), DecodeScalar(..), EncodeScalar(..))
 import Data.Morpheus.Types qualified as DMT
 import Data.String (fromString)
-import Data.Swagger (ToSchema)
+import Data.Swagger (ToSchema (..))
 import Data.Text qualified as T
-import Data.Time (UTCTime)
-import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time (UTCTime, nominalDiffTimeToSeconds)
+import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
 import Gargantext.Prelude
 import Gargantext.System.Logging
 import Prelude (String)
+import Data.TreeDiff.Class
+import Data.Fixed (Fixed(..))
 
 
 newtype NUTCTime = NUTCTime UTCTime
@@ -43,6 +47,20 @@ instance FromJSON NUTCTime
 instance ToJSON NUTCTime
 instance ToSchema NUTCTime
 
+newtype ElapsedSeconds = ElapsedSeconds { _Seconds :: POSIXTime }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype (FromJSON, ToJSON, Num)
+
+instance NFData ElapsedSeconds
+
+instance ToExpr ElapsedSeconds where
+  toExpr (ElapsedSeconds x) =
+    let (MkFixed secs) = nominalDiffTimeToSeconds x
+    in toExpr secs
+
+instance ToSchema ElapsedSeconds where
+  declareNamedSchema _ = declareNamedSchema (Proxy @Int)
+
 timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => String
              -- ^ A label
@@ -51,18 +69,31 @@ timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              -> m a
 timeMeasured = withFrozenCallStack $ timeMeasured' DEBUG
 
-timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+-- | A version of timeMeasured that also returns the elapsed time, in seconds.
+timeMeasured'' :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => LogLevel
              -- ^ The severity of the log
              -> String
              -- ^ A label to identify the action.
              -> m a
              -- ^ The action to run
-             -> m a
-timeMeasured' severity label action = withFrozenCallStack $ do
+             -> m (ElapsedSeconds, a)
+timeMeasured'' severity label action = withFrozenCallStack $ do
   startTime <- liftBase getPOSIXTime
   res       <- action
   endTime   <- liftBase getPOSIXTime
-  let msg = label <> " took " <> (show $ endTime - startTime) <> " seconds to execute."
+  let finalTime = endTime - startTime
+  let msg = label <> " took " <> (show finalTime) <> " seconds to execute."
   $(logLocM) severity (fromString msg)
-  return res
+  pure (ElapsedSeconds finalTime, res)
+
+timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+             => LogLevel
+             -- ^ The severity of the log
+             -> String
+             -- ^ A label to identify the action.
+             -> m a
+             -- ^ The action to run
+             -> m a
+timeMeasured' severity label action = withFrozenCallStack $
+  snd <$> timeMeasured'' severity label action