Add bench for toPyhlo

bench/Main.hs

@@ -2,18 +2,54 @@
 {-# LANGUAGE TypeApplications  #-}
 module Main where
 
+import Control.DeepSeq
 import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types.Phylo
+import Gargantext.Core.Viz.Phylo
+import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo)
+import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo)
+import Gargantext.Core.Viz.Phylo.PhyloTools
 import Gargantext.Prelude.Crypto.Auth (createPasswordHash)
 
 import Test.Tasty.Bench
+import Paths_gargantext
+
+phyloConfig :: PhyloConfig
+phyloConfig = PhyloConfig {
+    corpusPath = "corpus.csv"
+  , listPath = "list.csv"
+  , outputPath = "data/"
+  , corpusParser = Csv {_csv_limit = 150000}
+  , listParser = V4
+  , phyloName = "Phylo Name"
+  , phyloScale = 2
+  , similarity = WeightedLogJaccard {_wlj_sensibility = 0.5, _wlj_minSharedNgrams = 2}
+  , seaElevation = Constante {_cons_start = 0.1, _cons_gap = 0.1}
+  , defaultMode = True
+  , findAncestors = True
+  , phyloSynchrony = ByProximityThreshold {_bpt_threshold = 0.5, _bpt_sensibility = 0.0, _bpt_scope = AllBranches, _bpt_strategy = MergeAllGroups}
+  , phyloQuality = Quality {_qua_granularity = 0.8, _qua_minBranch = 3}
+  , timeUnit = Year {_year_period = 3, _year_step = 1, _year_matchingFrame = 5}
+  , clique = MaxClique {_mcl_size = 5, _mcl_threshold = 1.0e-4, _mcl_filter = ByThreshold}
+  , exportLabel = [ BranchLabel {_branch_labelTagger = MostEmergentTfIdf, _branch_labelSize = 2}
+                  , GroupLabel {_group_labelTagger = MostEmergentInclusive, _group_labelSize = 2}
+                  ]
+  , exportSort = ByHierarchy {_sort_order = Desc}
+  , exportFilter = [ByBranchSize {_branch_size = 3.0}]
+  }
 
 main :: IO ()
-main = defaultMain
-  [ bgroup "Benchmarks"
-    [ bgroup "User creation" [
-      bench "createPasswordHash"  $ whnfIO (createPasswordHash "rabbit")
-    , bench "toUserHash"  $
-        whnfIO (toUserHash $ NewUser "alfredo" "alfredo@well-typed.com" (GargPassword "rabbit"))
-    ]
+main = do
+  issue290Phylo <- force . setConfig phyloConfig <$> (readPhylo =<< getDataFileName "bench-data/phylo/issue-290.json")
+  defaultMain
+    [ bgroup "Benchmarks"
+      [ bgroup "User creation" [
+        bench "createPasswordHash"  $ whnfIO (createPasswordHash "rabbit")
+      , bench "toUserHash"  $
+          whnfIO (toUserHash $ NewUser "alfredo" "alfredo@well-typed.com" (GargPassword "rabbit"))
+      ]
+      , bgroup "Phylo" [
+          bench "toPhylo" $ nf toPhylo issue290Phylo
+      ]
+      ]
     ]
-  ]

gargantext.cabal

@@ -17,6 +17,7 @@ license:        AGPL-3
 license-file:   LICENSE
 build-type:     Simple
 data-files:
+    bench-data/phylo/issue-290.json
     devops/postgres/extensions.sql
     devops/postgres/schema.sql
     ekg-assets/index.html
@@ -1157,6 +1158,7 @@ benchmark garg-bench
   type:          exitcode-stdio-1.0
   build-depends: base
                , bytestring
+               , deepseq
                , gargantext
                , gargantext-prelude
                , tasty-bench

src/Gargantext/Core/Types/Phylo.hs

@@ -26,6 +26,7 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
 
 module Gargantext.Core.Types.Phylo where
 
+import Control.DeepSeq
 import Control.Lens (makeLenses)
 import Control.Monad.Fail (fail)
 import Data.Aeson
@@ -51,6 +52,8 @@ data Phylo = Phylo { _phylo_Duration :: (Start, End)
                    , _phylo_Periods  :: [PhyloPeriod]
                    } deriving (Generic)
 
+instance NFData Phylo
+
 -- | UTCTime in seconds since UNIX epoch
 type Start   = POSIXTime
 type End     = POSIXTime
@@ -66,6 +69,8 @@ data PhyloPeriod = PhyloPeriod { _phylo_PeriodId     :: PhyloPeriodId
                                , _phylo_PeriodLevels :: [PhyloLevel]
                                } deriving (Generic)
 
+instance NFData PhyloPeriod
+
 type PhyloPeriodId = (Start, End)
 
 -- | PhyloLevel : levels of phylomemy on level axis
@@ -78,6 +83,8 @@ data PhyloLevel = PhyloLevel { _phylo_LevelId     :: PhyloLevelId
                              , _phylo_LevelGroups :: [PhyloGroup]
                              } deriving (Generic)
 
+instance NFData PhyloLevel
+
 type PhyloLevelId = (PhyloPeriodId, Int)
 
 -- | PhyloGroup : group of ngrams at each level and step
@@ -88,14 +95,16 @@ type PhyloLevelId = (PhyloPeriodId, Int)
 data PhyloGroup = PhyloGroup { _phylo_GroupId            :: PhyloGroupId
                              , _phylo_GroupLabel         :: Maybe Text
                              , _phylo_GroupNgrams        :: [NgramId]
-                   
+
                              , _phylo_GroupPeriodParents :: [Edge]
                              , _phylo_GroupPeriodChilds  :: [Edge]
-                   
+
                              , _phylo_GroupLevelParents  :: [Edge]
                              , _phylo_GroupLevelChilds   :: [Edge]
                              } deriving (Generic)
 
+instance NFData PhyloGroup
+
 type PhyloGroupId = (PhyloLevelId, Int)
 type Edge         = (PhyloGroupId, Weight)
 type Weight       = Double

src/Gargantext/Core/Viz/Phylo.hs

@@ -26,6 +26,7 @@ one 8, e54847.
 
 module Gargantext.Core.Viz.Phylo where
 
+import Control.DeepSeq
 import Control.Lens (makeLenses)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
@@ -62,7 +63,7 @@ data SeaElevation =
     | Adaptative
       { _adap_steps :: Double }
     | Evolving
-      { _evol_neighborhood :: Bool }      
+      { _evol_neighborhood :: Bool }
     deriving (Show,Generic,Eq)
 
 instance ToSchema SeaElevation
@@ -74,8 +75,8 @@ data PhyloSimilarity =
     | WeightedLogSim
       { _wls_sensibility     :: Double
       , _wls_minSharedNgrams :: Int }
-    | Hamming 
-      { _hmg_sensibility     :: Double 
+    | Hamming
+      { _hmg_sensibility     :: Double
       , _hmg_minSharedNgrams :: Int}
 
     deriving (Show,Generic,Eq)
@@ -188,7 +189,6 @@ data PhyloConfig =
             , exportFilter   :: [Filter]
             } deriving (Show,Generic,Eq)
 
-
 --------------------------------
 -- | SubConfig API & 1Click | --
 --------------------------------
@@ -205,8 +205,8 @@ data PhyloSubConfigAPI =
 
 
 subConfigAPI2config :: PhyloSubConfigAPI -> PhyloConfig
-subConfigAPI2config subConfig = defaultConfig 
-                                           { similarity     = WeightedLogJaccard (_sc_phyloProximity subConfig) 2 
+subConfigAPI2config subConfig = defaultConfig
+                                           { similarity     = WeightedLogJaccard (_sc_phyloProximity subConfig) 2
                                            , phyloSynchrony = ByProximityThreshold (_sc_phyloSynchrony subConfig) 0 AllBranches MergeAllGroups
                                            , phyloQuality   = Quality (_sc_phyloQuality   subConfig) 3
                                            , timeUnit       = _sc_timeUnit       subConfig
@@ -217,7 +217,7 @@ subConfigAPI2config subConfig = defaultConfig
 
 --------------------------
 -- | SubConfig 1Click | --
---------------------------  
+--------------------------
 
 defaultConfig :: PhyloConfig
 defaultConfig =
@@ -474,7 +474,6 @@ data PhyloScale =
 instance ToSchema PhyloScale where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
 
-
 type PhyloGroupId  = (PhyloScaleId, Int)
 
 -- | BranchId : (a scale, a sequence of branch index)
@@ -552,19 +551,16 @@ data Filter = ByBranchSize { _branch_size :: Double } deriving (Show,Generic,Eq)
 instance ToSchema Filter where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 
-
 data Order = Asc | Desc deriving (Show,Generic,Eq, ToSchema)
 
 data Sort = ByBirthDate { _sort_order :: Order } | ByHierarchy {_sort_order :: Order } deriving (Show,Generic,Eq)
 instance ToSchema Sort where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_sort_")
 
-
 data Tagger = MostInclusive | MostEmergentInclusive | MostEmergentTfIdf deriving (Show,Generic,Eq)
 instance ToSchema Tagger where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 
-
 data PhyloLabel =
       BranchLabel
       { _branch_labelTagger :: Tagger
@@ -654,3 +650,30 @@ instance FromJSON PhyloGroup
 instance ToJSON PhyloGroup
 
 $(deriveJSON (unPrefix "_foundations_"  ) ''PhyloFoundations)
+
+-- NFData instances
+
+instance NFData CorpusParser
+instance NFData ListParser
+instance NFData SeaElevation
+instance NFData PhyloSimilarity
+instance NFData SynchronyScope
+instance NFData SynchronyStrategy
+instance NFData Synchrony
+instance NFData MaxCliqueFilter
+instance NFData Cluster
+instance NFData Quality
+instance NFData PhyloConfig
+instance NFData Software
+instance NFData PhyloParam
+instance NFData PhyloFoundations
+instance NFData PhyloCounts
+instance NFData PhyloSources
+instance NFData Phylo
+instance NFData PhyloPeriod
+instance NFData PhyloScale
+instance NFData Filter
+instance NFData Order
+instance NFData Sort
+instance NFData Tagger
+instance NFData PhyloLabel

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

@@ -19,7 +19,7 @@ module Gargantext.Core.Viz.Phylo.API.Tools
   where
 
 import Control.Lens hiding (Context)
-import Data.Aeson (Value, decodeFileStrict, eitherDecode, encode)
+import Data.Aeson (Value, decodeFileStrict, encode, eitherDecodeFileStrict')
 import Data.ByteString.Lazy qualified as Lazy
 import Data.Map.Strict qualified as Map
 import Data.Proxy
@@ -54,6 +54,7 @@ import Prelude qualified
 import System.FilePath ((</>))
 import System.IO.Temp (withTempDirectory)
 import System.Process qualified as Shell
+import Gargantext.Utils.UTCTime (timeMeasured)
 
 --------------------------------------------------------------------
 getPhyloData :: HasNodeError err
@@ -99,7 +100,12 @@ flowPhyloAPI config cId = do
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   $(logLocM) DEBUG $ "PhyloConfig old: " <> show config
 
-  pure $! toPhylo $! setConfig config phyloWithCliques
+  _ <- timeMeasured "flowPhyloAPI.phyloWithCliques" (pure $! phyloWithCliques)
+
+  let !phyloConfigured = setConfig config phyloWithCliques
+  _ <- timeMeasured "flowPhyloAPI.phyloConfigured" (pure $! phyloConfigured)
+
+  pure $! toPhylo phyloConfigured
 
 --------------------------------------------------------------------
 corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)
@@ -195,13 +201,8 @@ writePhylo path phylo = Lazy.writeFile path $ encode phylo
 
 readPhylo :: [Char] -> IO Phylo
 readPhylo path = do
-  phyloJson <- (eitherDecode <$> readJson path) :: IO (Either Prelude.String Phylo)
-  case phyloJson of
-    Left err -> do
-      putStrLn err
-      undefined
-    Right phylo -> pure phylo
-
+  phyloJson <- eitherDecodeFileStrict' @Phylo path
+  either errorTrace pure phyloJson
 
 -- | To read and decode a Json file
 readJson :: FilePath -> IO Lazy.ByteString