wip - disable debug logs for Phylo code

bench/Main.hs

@@ -49,7 +49,7 @@ main = do
           whnfIO (toUserHash $ NewUser "alfredo" "alfredo@well-typed.com" (GargPassword "rabbit"))
       ]
       , bgroup "Phylo" [
-          bench "toPhylo (small)" $ nf toPhylo issue290PhyloSmall
+          bench "toPhylo (small)" $ nf (toPhyloWithOptions (ToPhyloOptions False) issue290PhyloSmall
       ]
       ]
     ]

src/Gargantext/Core/Viz/Phylo/Example.hs

@@ -41,19 +41,22 @@ phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot"
 phyloDot :: DotGraph DotId
 phyloDot = toPhyloExport phyloCleopatre
 
+phyloOpts :: ToPhyloOptions
+phyloOpts = ToPhyloOptions True -- enable debug logs
+
 --------------------------------------------------
 -- | STEP 4 | -- Process the synchronic clustering
 --------------------------------------------------
 
 phyloCleopatre :: Phylo
-phyloCleopatre = synchronicClustering $ toHorizon flatPhylo
+phyloCleopatre = synchronicClustering phyloOpts $ toHorizon flatPhylo
 
 -----------------------------------------------
 -- | STEP 3 | -- Build the Level 1 of the Phylo
 -----------------------------------------------
 
 flatPhylo :: Phylo
-flatPhylo = temporalMatching (getLadder emptyPhylo') emptyPhylo'
+flatPhylo = temporalMatching phyloOpts (getLadder emptyPhylo') emptyPhylo'
 
 emptyPhylo' :: Phylo
 emptyPhylo' = joinRoots

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -11,7 +11,21 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
-module Gargantext.Core.Viz.Phylo.PhyloMaker where
+module Gargantext.Core.Viz.Phylo.PhyloMaker (
+    toPhylo
+  , toPhyloWithOptions
+  , toPhyloWithoutLink
+
+  , appendGroups
+  , clusterToGroup
+  , docsToTimeScaleCooc
+  , docsToTimeScaleNb
+  , findSeaLadder
+  , groupDocsByPeriod
+  , initPhylo
+  , joinRoots
+  , toSeriesOfClustering
+  ) where
 
 
 import Control.Lens hiding (Level)
@@ -43,17 +57,23 @@ data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
             | PhyloN    { _phylo'_flatPhylo :: Phylo}
 
 
+
 toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
 toPhylo' (PhyloN    phylo) = toPhylo'
 toPhylo' (PhyloBase phylo) = toPhylo
 -}
 
--- TODO an adaptative synchronic clustering with a slider
-
 toPhylo :: Phylo -> Phylo
-toPhylo phylowithoutLink = traceToPhylo (phyloScale $ getConfig phylowithoutLink) $
+toPhylo = toPhyloWithOptions (ToPhyloOptions True)
+
+-- TODO an adaptative synchronic clustering with a slider
+-- FIXME(adn) Currently we emit traces from pure code(!!). This is obviously not very nice
+-- and it breaks referencial transparency; we ought to fix it, but in order to smooth out
+-- the compatibility story, for now we keep the status quo.
+toPhyloWithOptions :: ToPhyloOptions -> Phylo -> Phylo
+toPhyloWithOptions phyloOpts phylowithoutLink = traceToPhylo phyloOpts (phyloScale $ getConfig phylowithoutLink) $
     if (phyloScale $ getConfig phylowithoutLink) > 1
-      then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloScale $ getConfig phylowithoutLink)]
+      then foldl' (\phylo' _ -> synchronicClustering phyloOpts phylo') phyloAncestors [2..(phyloScale $ getConfig phylowithoutLink)]
       else phyloAncestors
     where
         --------------------------------------
@@ -64,7 +84,7 @@ toPhylo phylowithoutLink = traceToPhylo (phyloScale $ getConfig phylowithoutLink
               else phyloWithLinks
         --------------------------------------
         phyloWithLinks :: Phylo
-        phyloWithLinks = temporalMatching (getLadder phylowithoutLink) phylowithoutLink
+        phyloWithLinks = temporalMatching phyloOpts (getLadder phylowithoutLink) phylowithoutLink
         --------------------------------------
 
 

src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs

@@ -72,8 +72,8 @@ addPhyloScale lvl phylo =
                                    (PhyloScale (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriodStr) lvl empty))) phylo
 
 
-toNextScale :: Phylo -> [PhyloGroup] -> Phylo
-toNextScale phylo groups =
+toNextScale :: ToPhyloOptions -> Phylo -> [PhyloGroup] -> Phylo
+toNextScale opts phylo groups =
     let curLvl = getLastLevel phylo
         oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
         newGroups = concat $ groupsToBranches'
@@ -86,7 +86,7 @@ toNextScale phylo groups =
                   $ fromListWith (++) $ map (\g -> (getLevelParentId g, [g])) groups
 
         newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups
-    in  traceSynchronyEnd 
+    in  traceSynchronyEnd opts
       $ over ( phylo_periods . traverse . phylo_periodScales . traverse
              --  6) update each period at curLvl + 1
              . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == (curLvl + 1)))
@@ -205,8 +205,8 @@ levelUpAncestors groups =
          in g & phylo_groupAncestors .~ ancestors'
       ) groups
 
-synchronicClustering :: Phylo -> Phylo
-synchronicClustering phylo =
+synchronicClustering :: ToPhyloOptions -> Phylo -> Phylo
+synchronicClustering opts phylo =
     let prox = similarity $ getConfig phylo
         sync = phyloSynchrony $ getConfig phylo
         docs = getDocsByDate phylo
@@ -215,9 +215,9 @@ synchronicClustering phylo =
                      $ map processDynamics
                      $ chooseClusteringStrategy sync
                      $ phyloLastScale 
-                     $ traceSynchronyStart phylo
+                     $ traceSynchronyStart opts phylo
         newBranches' = newBranches `using` parList rdeepseq
-     in toNextScale phylo $ levelUpAncestors $ concat newBranches'
+     in toNextScale opts phylo $ levelUpAncestors $ concat newBranches'
 
 
 -- synchronicDistance :: Phylo -> Level -> String

src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs

@@ -679,9 +679,9 @@ seaLevelRise fdt similarity lambda minBranch frequency ladder rise frame periods
 {- 
 -- start the temporal matching process up, recover the resulting branches and update the groups (at scale 1) consequently
 -}
-temporalMatching :: [Double] -> Phylo -> Phylo
-temporalMatching ladder phylo = updatePhyloGroups 1
-                         (Map.fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches)
+temporalMatching :: ToPhyloOptions -> [Double] -> Phylo -> Phylo
+temporalMatching opts ladder phylo = updatePhyloGroups 1
+                         (Map.fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd opts $ concat branches)
                          (updateQuality quality phylo)
   where
     -------
@@ -718,4 +718,4 @@ temporalMatching ladder phylo = updatePhyloGroups 1
                          (getDocsByDate phylo)
                          (getCoocByDate phylo)
                          ((phylo ^. phylo_foundations) ^. foundations_rootsInGroups)
-                         (traceTemporalMatching $ getGroupsFromScale 1 phylo)
+                         (traceTemporalMatching opts $ getGroupsFromScale 1 phylo)