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/PhyloTools.hs

@@ -8,11 +8,89 @@ Stability   : experimental
 Portability : POSIX
 -}
 
+{-# LANGUAGE ViewPatterns              #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
-{-# LANGUAGE ViewPatterns      #-}
-
-module Gargantext.Core.Viz.Phylo.PhyloTools where
+module Gargantext.Core.Viz.Phylo.PhyloTools (
+
+   -- * Types
+     ToPhyloOptions(..)
+
+  , addMemoryPointers
+  , addPointers
+  , commonPrefix
+  , coocToDiago
+  , elemIndex'
+  , filterSimilarity
+  , findDefaultLevel
+  , findMaxima
+  , getConfig
+  , getCoocByDate
+  , getDocsByDate
+  , getGroupId
+  , getGroupNgrams
+  , getGroupsFromScale
+  , getGroupsFromScalePeriods
+  , getInMap
+  , getLadder
+  , getLastLevel
+  , getLastRootsFreq
+  , getLevel
+  , getLevelParentId
+  , getMinSharedNgrams
+  , getPeriodIds
+  , getPeriodPointers
+  , getPhyloSeaRiseStart
+  , getPhyloSeaRiseSteps
+  , getRoots
+  , getRootsCountByDate
+  , getRootsFreq
+  , getSeaElevation
+  , getSimilarity
+  , getSources
+  , getTimeFrame
+  , getTimePeriod
+  , getTimeScale
+  , getTimeStep
+  , groupByField
+  , groupsToBranches'
+  , idToPrd
+  , idxToLabel
+  , idxToLabel'
+  , isNested
+  , isRoots
+  , keepFilled
+  , listToCombi'
+  , listToMatrix
+  , listToSeq
+  , mergeBranchIds
+  , mergeMeta
+  , ngramsToCooc
+  , ngramsToDensity
+  , ngramsToIdx
+  , ngramsToLabel
+  , periodsToYears
+  , phyloLastScale
+  , relatedComponents
+  , setConfig
+  , sourcesToIdx
+  , sumCooc
+  , toFstDate
+  , toLstDate
+  , toPeriods
+  , toRelatedComponents
+  , toTimeScale
+  , traceSynchronyEnd
+  , traceSynchronyStart
+  , updatePeriods
+  , updatePhyloGroups
+  , updateQuality
+
+  -- * Tracing the Phylo algorithm (deprecated, trace from pure code is bade)
+  , traceMatchEnd
+  , traceTemporalMatching
+  , traceToPhylo
+  ) where
 
 import Control.Lens hiding (Level)
 import Data.List (union, nub, init, tail, partition, nubBy, (!!))
@@ -32,6 +110,14 @@ import Gargantext.Prelude hiding (empty)
 import Prelude (read)
 import Text.Printf
 
+-- | Options to use with the 'toPhylo' function and others.
+newtype ToPhyloOptions
+  = ToPhyloOptions
+  { -- | If 'True', enable debug logs.
+    tpoptsDebugLogs :: Bool
+  } deriving (Show, Eq)
+
+
 ------------
 -- | Io | --
 ------------
@@ -55,10 +141,6 @@ printIOComment cmt =
 -- | Misc | --
 --------------
 
--- truncate' :: Double -> Int -> Double
--- truncate' x n = (fromIntegral (floor (x * t))) / t
---     where t = 10^n
-
 truncate' :: Double -> Int -> Double
 truncate' x n = (fromIntegral $ (floor (x * t) :: Int)) / t
     where
@@ -634,13 +716,15 @@ updateQuality quality phylo = phylo { _phylo_quality = quality }
 updateLevel :: Double -> Phylo -> Phylo
 updateLevel level phylo = phylo { _phylo_level = level }
 
-traceToPhylo :: Scale -> Phylo -> Phylo
-traceToPhylo lvl phylo =
-    trace ("\n" <> "-- | End of phylo making at scale " <> show (lvl) <> " with "
+traceToPhylo :: ToPhyloOptions -> Scale -> Phylo -> Phylo
+traceToPhylo ToPhyloOptions{..} lvl phylo =
+    traceIt ("\n" <> "-- | End of phylo making at scale " <> show (lvl) <> " with "
                 <> show (length $ getGroupsFromScale lvl phylo) <> " groups and "
                 <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale lvl phylo)
                 <> " branches" <> "\n" :: Text
           ) phylo
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
 --------------------
 -- | Clustering | --
@@ -700,21 +784,25 @@ toRelatedComponents nodes edges =
    in map (\cluster -> map (\gId -> ref ! gId) cluster) clusters
 
 
-traceSynchronyEnd :: Phylo -> Phylo
-traceSynchronyEnd phylo =
-    trace ( "-- | End synchronic clustering at scale " <> show (getLastLevel phylo)
+traceSynchronyEnd :: ToPhyloOptions -> Phylo -> Phylo
+traceSynchronyEnd ToPhyloOptions{..} phylo =
+    traceIt ( "-- | End synchronic clustering at scale " <> show (getLastLevel phylo)
             <> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
             <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo)
             <> " branches" <> "\n" :: Text
           ) phylo
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
-traceSynchronyStart :: Phylo -> Phylo
-traceSynchronyStart phylo =
-    trace ( "\n" <> "-- | Start synchronic clustering at scale " <> show (getLastLevel phylo)
+traceSynchronyStart :: ToPhyloOptions -> Phylo -> Phylo
+traceSynchronyStart ToPhyloOptions{..} phylo =
+    traceIt ( "\n" <> "-- | Start synchronic clustering at scale " <> show (getLastLevel phylo)
                  <> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
                  <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo)
                  <> " branches" <> "\n" :: Text
           ) phylo
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
 
 -------------------
@@ -748,13 +836,31 @@ intersectInit acc lst lst' =
 branchIdsToSimilarity :: PhyloBranchId -> PhyloBranchId -> Double -> Double -> Double
 branchIdsToSimilarity id id' thrInit thrStep = thrInit + thrStep * (fromIntegral $ length $ intersectInit [] (snd id) (snd id'))
 
-ngramsInBranches :: [[PhyloGroup]] -> [Int]
-ngramsInBranches branches = nub $ foldl (\acc g -> acc ++ (g ^. phylo_groupNgrams)) [] $ concat branches
+traceMatchEnd :: ToPhyloOptions -> [PhyloGroup] -> [PhyloGroup]
+traceMatchEnd ToPhyloOptions{..} groups =
+    traceIt ("\n" <> "-- | End temporal matching with " <> show (length $ nub $ map (\g -> g ^. phylo_groupBranchId) groups)
+                                                         <> " branches and " <> show (length groups) <> " groups" <> "\n" :: Text) groups
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
+
+
+traceTemporalMatching :: ToPhyloOptions -> [PhyloGroup] -> [PhyloGroup]
+traceTemporalMatching ToPhyloOptions{..} groups =
+    traceIt ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n" :: Text ) groups
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
+
+--
+-- Unused functions (remove at some point)
+--
 
+_ngramsInBranches :: [[PhyloGroup]] -> [Int]
+_ngramsInBranches branches = nub $ foldl (\acc g -> acc ++ (g ^. phylo_groupNgrams)) [] $ concat branches
 
-traceMatchSuccess :: Double -> Double -> Double -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
-traceMatchSuccess thr qua qua' nextBranches =
-    trace ( "\n" <> "-- local branches : "
+
+_traceMatchSuccess :: ToPhyloOptions -> Double -> Double -> Double -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
+_traceMatchSuccess ToPhyloOptions{..} thr qua qua' nextBranches =
+    traceIt ( "\n" <> "-- local branches : "
             <> (Text.pack $ init $ show ((init . init . snd)
                                           $ (head' "trace" $ head' "trace" $ head' "trace" nextBranches) ^. phylo_groupBranchId))
             <> ",(1.." <> show (length nextBranches) <> ")]"
@@ -763,50 +869,48 @@ traceMatchSuccess thr qua qua' nextBranches =
             <> " - for the local threshold "  <> show (thr)
             <> " ( quality : " <> show (qua) <> " < " <> show(qua') <> ")\n" :: Text
           ) nextBranches
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
 
-traceMatchFailure :: Double -> Double -> Double -> [[PhyloGroup]] -> [[PhyloGroup]]
-traceMatchFailure thr qua qua' branches =
-    trace ( "\n" <> "-- local branches : "
+_traceMatchFailure :: ToPhyloOptions -> Double -> Double -> Double -> [[PhyloGroup]] -> [[PhyloGroup]]
+_traceMatchFailure ToPhyloOptions{..} thr qua qua' branches =
+    traceIt ( "\n" <> "-- local branches : "
             <> (Text.pack $ init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
             <> ",(1.." <> show (length branches) <> ")]"
             <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
             <> " - split with failure for the local threshold " <> show (thr)
             <> " ( quality : " <> show (qua) <> " > " <> show(qua') <> ")\n" :: Text
         ) branches
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
 
-traceMatchNoSplit :: [[PhyloGroup]] -> [[PhyloGroup]]
-traceMatchNoSplit branches =
-    trace ( "\n" <> "-- local branches : "
+_traceMatchNoSplit :: ToPhyloOptions -> [[PhyloGroup]] -> [[PhyloGroup]]
+_traceMatchNoSplit ToPhyloOptions{..} branches =
+    traceIt ( "\n" <> "-- local branches : "
             <> (Text.pack $ init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
             <> ",(1.." <> show (length branches) <> ")]"
             <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
             <> " - unable to split in smaller branches" <> "\n" :: Text
         ) branches
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
 
-traceMatchLimit :: [[PhyloGroup]] -> [[PhyloGroup]]
-traceMatchLimit branches =
-    trace ( "\n" <> "-- local branches : "
+_traceMatchLimit :: ToPhyloOptions -> [[PhyloGroup]] -> [[PhyloGroup]]
+_traceMatchLimit ToPhyloOptions{..} branches =
+    traceIt ( "\n" <> "-- local branches : "
             <> (Text.pack $ init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
             <> ",(1.." <> show (length branches) <> ")]"
             <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
             <> " - unable to increase the threshold above 1" <> "\n" :: Text
         ) branches
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const
 
-
-traceMatchEnd :: [PhyloGroup] -> [PhyloGroup]
-traceMatchEnd groups =
-    trace ("\n" <> "-- | End temporal matching with " <> show (length $ nub $ map (\g -> g ^. phylo_groupBranchId) groups)
-                                                         <> " branches and " <> show (length groups) <> " groups" <> "\n" :: Text) groups
-
-
-traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
-traceTemporalMatching groups =
-    trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n" :: Text ) groups
-
-
-traceGroupsProxi :: [Double] -> [Double]
-traceGroupsProxi l =
-    trace ( "\n" <> "-- | " <> show(List.length l) <> " computed pairs of groups Similarity" <> "\n" :: Text ) l
+_traceGroupsProxi :: ToPhyloOptions -> [Double] -> [Double]
+_traceGroupsProxi ToPhyloOptions{..} l =
+    traceIt ( "\n" <> "-- | " <> show(List.length l) <> " computed pairs of groups Similarity" <> "\n" :: Text ) l
+  where
+    traceIt = if tpoptsDebugLogs then trace else flip const

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)