Skip to content

haskell-gargantext
haskell-gargantext
Commit 0b73cd17 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli Committed by Alfredo Di Napoli
Browse files
Options

wip - disable debug logs for Phylo code

parent 39fc144f
Hide whitespace changes
Inline Side-by-side
Showing with 192 additions and 65 deletions
bench/Main.hs
View file @ 0b73cd17
......@@ -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
View file @ 0b73cd17
......@@ -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
View file @ 0b73cd17
......@@ -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
View file @ 0b73cd17
......@@ -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
View file @ 0b73cd17
......@@ -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
View file @ 0b73cd17
......@@ -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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment