timeplot 1.0.1 → 1.0.3
raw patch · 6 files changed
+56/−53 lines, 6 filesdep −hashabledep −hashmapdep ~Chart
Dependencies removed: hashable, hashmap
Dependency ranges changed: Chart
Files
- Tools/TimePlot.hs +2/−1
- Tools/TimePlot/Conf.hs +13/−11
- Tools/TimePlot/Incremental.hs +8/−7
- Tools/TimePlot/Plots.hs +29/−30
- Tools/TimePlot/Types.hs +1/−1
- timeplot.cabal +3/−3
Tools/TimePlot.hs view
@@ -191,7 +191,8 @@ " gives one plot per subtrack. All dots are drawn with opacity ALPHA,", " where 0 means transparent and 1 means opaque. Useful when you're suffering", " from overplotting (dots overlapping each other too much)",- " 'cumsum [TYPE]' - a simple line plot of the sum of the numeric values.",+ " 'cumsum N [TYPE]' - a simple line plot of the running sum of the numeric values,",+ " over bins of size N - as if you plotted 'sum N', but sums are accumulated over time", " When used in 'within', produce 1 subplot per subtrack. TYPE can be: ", " 'overlayed' -> just lay the subplots over one another.", " 'stacked' -> add them up at each point to see how subtracks contribute",
Tools/TimePlot/Conf.hs view
@@ -37,18 +37,20 @@ data KindChoiceOperator = Cut | Accumulate +localToUTC Nothing = Nothing +localToUTC (Just (t,s)) = Just (localToUTC' t, s) +localToUTC' (LocalTime day (TimeOfDay h m s)) = {-# SCC "localToUTC" #-} UTCTime day daytime + where + daytime = unsafeCoerce (s + fromIntegral (60*m + 3600*h)) + readConf :: [String] -> Conf readConf args = readConf' parseTime where pattern = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%OS")) of "date":f -> B.pack (unwords f) _ -> error "Unrecognized time format (-tf)" - parseTime = localToUTC . strptime pattern - localToUTC Nothing = Nothing - localToUTC (Just (t,s)) = Just (localToUTC' t, s) - localToUTC' (LocalTime day (TimeOfDay h m s)) = UTCTime day daytime - where - daytime = unsafeCoerce (s + fromIntegral (60*m) + fromIntegral (3600*h)) + ourStrptime = {-# SCC "ourStrptime" #-} strptime pattern + parseTime s = localToUTC (ourStrptime s) int2double = fromIntegral :: Int -> Double single desc name def = case (getArg name 1 args) of @@ -76,7 +78,7 @@ parseRes s = case break (=='x') s of (h,_:v) -> (read h,read v) forceList :: [a] -> () forceList = foldr seq () - chartKindF = forceList [forceList plusKinds, forceList minusKinds, forceList defaultKindsPlus, defaultKindMinus `seq` ()] `seq` kindByRegex $ + chartKindF = {-# SCC "chartKindF" #-} forceList [forceList plusKinds, forceList minusKinds, forceList defaultKindsPlus, defaultKindMinus `seq` ()] `seq` kindByRegex $ [(Cut, matches regex, parseKind (words kind)) | [regex,kind] <- getArg "-k" 2 args] ++ [(Accumulate, matches regex, parseKind (words kind)) | [regex,kind] <- getArg "+k" 2 args] where @@ -128,10 +130,10 @@ parseKind ["dots" ] = KindDots { alpha = 1 } parseKind ["dots", a ] = KindDots { alpha = read a } parseKind ("dots":_) = error "dots requires 0 or 1 arguments (the argument is alpha value: 0 = transparent, 1 = opaque, default 1)" - parseKind ["cumsum" ] = KindCumSum {subtrackStyle=SumStacked} - parseKind ["cumsum", s ] = KindCumSum {subtrackStyle=parseSubtrackStyle s} - parseKind ("cumsum":_) = error $ "cumsum requires zero or one argument (subtrack style), e.g.: " ++ - "-dk cumsum or -dk 'cumsum stacked'" + parseKind ["cumsum", b ] = KindCumSum {binSize=read b, subtrackStyle=SumStacked} + parseKind ["cumsum", b,s] = KindCumSum {binSize=read b, subtrackStyle=parseSubtrackStyle s} + parseKind ("cumsum":_) = error $ "cumsum requires 1 or 2 arguments (bin size and subtrack style), e.g.: " ++ + "-dk 'cumsum 10' or -dk 'cumsum 10 stacked'" parseKind ["sum", b ] = KindSum {binSize=read b, subtrackStyle=SumStacked} parseKind ["sum", b,s] = KindSum {binSize=read b, subtrackStyle=parseSubtrackStyle s} parseKind ("sum":_) = error $ "sum requires one or two arguments: bin size and optionally " ++
Tools/TimePlot/Incremental.hs view
@@ -20,13 +20,13 @@ runStreamSummary !s [] = finalize s runStreamSummary !s (a:as) = runStreamSummary (insert s a) as -foldl' :: (a -> s -> s) -> s -> StreamSummary a s -foldl' insert init = go init +stateful :: s -> (a -> s -> s) -> (s -> r) -> StreamSummary a r +stateful init insert finalize = go init where - go !s = Summary (\a -> go (insert a s)) s + go !s = Summary (\a -> go (insert a s)) (finalize s) filterMap :: (a -> Maybe b) -> StreamSummary b r -> StreamSummary a r -filterMap p !s@(Summary insert res) = Summary insert' res +filterMap p s@(Summary insert res) = Summary insert' res where insert' a = case p a of { Nothing -> filterMap p s ; Just b -> filterMap p (insert b) } @@ -34,10 +34,10 @@ mapInput f (Summary insert res) = Summary (mapInput f . insert . f) res collect :: StreamSummary a [a] -collect = fmap reverse (foldl' (:) []) +collect = stateful [] (:) reverse byTimeBins :: (Ord t) => [t] -> StreamSummary (t,[a]) r -> StreamSummary (t,a) r -byTimeBins ts s = fmap finalize' (foldl' insert' init') +byTimeBins ts s = stateful init' insert' finalize' where init' = (ts, [], s) insert' (t,a) (t1:t2:ts, curBin, !s) @@ -46,8 +46,9 @@ | True = (t2:ts, [a], insert s (t1,reverse curBin)) finalize' (t1:t2:ts, curBin, s) = finalize (insert s (t1,reverse curBin)) + byKey :: (Ord k) => (k -> StreamSummary v r) -> StreamSummary (k,v) (M.Map k r) -byKey initByKey = fmap finalize' (foldl' insert' init') +byKey initByKey = stateful init' insert' finalize' where init' = M.empty insert' (k,v) m = case M.lookup k m of
Tools/TimePlot/Plots.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ParallelListComp, ScopedTypeVariables, BangPatterns, Rank2Types #-} +{-# LANGUAGE ParallelListComp, ScopedTypeVariables, BangPatterns, Rank2Types, TupleSections #-} module Tools.TimePlot.Plots ( initGen ) where @@ -42,7 +42,7 @@ initGen KindLines = genLines initGen (KindDots alpha) = genDots alpha initGen (KindSum bs ss) = genSum bs ss -initGen (KindCumSum ss) = genCumSum ss +initGen (KindCumSum bs ss) = genCumSum bs ss initGen (KindDuration sk) = genDuration sk initGen (KindWithin _ _) = \name -> error $ "KindWithin should not be plotted (this is a bug): track " ++ show name @@ -195,20 +195,14 @@ h as tfs = plotTrackBars (map (second (f as)) tfs) (map show as) name colors unique :: (Ord a) => (x -> a) -> I.StreamSummary x [a] -unique f = M.keys <$> I.foldl' (\a -> M.insert (f a) ()) M.empty +unique f = I.stateful M.empty (\a -> M.insert (f a) ()) M.keys uniqueSubtracks :: I.StreamSummary (UTCTime,S.ByteString,a) [S.ByteString] uniqueSubtracks = unique (\(t,s,a) -> s) genSum :: NominalDiffTime -> SumSubtrackStyle -> PlotGen -genSum binSize ss name t0 t1 = I.filterMap values (h <$> uniqueSubtracks <*> sumsInBins) +genSum binSize ss name t0 t1 = I.filterMap values (h <$> uniqueSubtracks <*> sumsInBins t0 binSize) where - sumsInBins :: I.StreamSummary (UTCTime,S.ByteString,Double) [(UTCTime, M.Map S.ByteString Double)] - sumsInBins = I.mapInput (\(t,s,v) -> (t,(s,v))) $ - summaryByFixedTimeBins t0 binSize $ - I.mapInput (second (fromListWith' (+))) $ - I.collect - h :: [S.ByteString] -> [(UTCTime, M.Map S.ByteString Double)] -> PlotData h tracks binSums = plotLines name rows where @@ -223,27 +217,32 @@ rows = M.toList $ fmap sort $ M.fromListWith (++) $ [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m] -genCumSum :: SumSubtrackStyle -> PlotGen -genCumSum ss name t0 t1 = I.filterMap values $ fmap (plotLines name . data2plot ss) I.collect +sumsInBins :: UTCTime -> NominalDiffTime -> I.StreamSummary (UTCTime,S.ByteString,Double) [(UTCTime, M.Map S.ByteString Double)] +sumsInBins t0 bs = I.mapInput (\(t,s,v) -> (t,(s,v))) $ + summaryByFixedTimeBins t0 bs $ + I.mapInput (second (fromListWith' (+))) $ + I.collect + +genCumSum :: NominalDiffTime -> SumSubtrackStyle -> PlotGen +genCumSum bs ss name t0 t1 = I.filterMap values (accumulate <$> uniqueSubtracks <*> sumsInBins t0 bs) where - data2plot :: SumSubtrackStyle -> [(UTCTime, S.ByteString, Double)] -> [(S.ByteString, [(UTCTime, Double)])] - data2plot SumOverlayed es = [(s, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (t0, 0) vs) | (s, vs) <- groupByTrack es] - data2plot SumStacked es = rows - where - allTracks = Set.toList $ Set.fromList [track | (t, track, v) <- es] + accumulate :: [S.ByteString] -> [(UTCTime, M.Map S.ByteString Double)] -> PlotData + accumulate tracks tss = plotLines name [(track, [(t, ss M.! track) | (t,ss) <- cumsums]) | track <- tracks] + where + cumsums = scanl' f (t0, M.fromList $ zip tracks (repeat 0)) (map normalize tss) + normalize (t,binSums) = (t, M.fromList [ (track, M.findWithDefault 0 track binSums) | track <- tracks ]) - rows :: [(S.ByteString, [(UTCTime, Double)])] - rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs] + f (_,bases) (t,binSums) = (t,) $ M.fromList $ zip tracks $ zipWith (+) trackBases $ case ss of + SumOverlayed -> trackSums + SumStacked -> trackAccSums + where + trackSums = [ binSums M.! track | track <- tracks ] + trackBases = [ bases M.! track | track <- tracks ] + trackAccSums = scanl1' (+) trackSums +scanl1' f (x:xs) = scanl' f x xs +scanl' f !x0 [] = [x0] +scanl' f !x0 (x:xs) = x0:scanl' f (f x0 x) xs - rowsT :: [(UTCTime, [(S.ByteString, Double)])] - rowsT = (t0, zip allTracks (repeat 0)) : St.evalState (mapM addDataPoint es) M.empty - - addDataPoint (t, track, v) = do - St.modify (M.insertWith' (+) track v) - st <- St.get - let trackSums = map (\x -> M.findWithDefault 0 x st) allTracks - return (t, allTracks `zip` (scanl1 (+) trackSums)) - genActivity :: (M.Map S.ByteString Double -> Double -> Double) -> NominalDiffTime -> PlotGen genActivity f bs name t0 t1 = I.filterMap edges (h <$> uniqueSubtracks <*> binAreas) where @@ -257,7 +256,7 @@ edges2binsSummary :: (Ord t,HasDelta t,Show t) => Delta t -> t -> t -> I.StreamSummary (t,S.ByteString,Edge) [((t,t), M.Map S.ByteString Double)] -edges2binsSummary binSize tMin tMax = fmap flush (I.foldl' step (M.empty, iterate (add binSize) tMin, [])) +edges2binsSummary binSize tMin tMax = I.stateful (M.empty, iterate (add binSize) tMin, []) step flush where -- State: (m, ts, r) where: -- * m = subtrack => state of current bin: @@ -298,7 +297,7 @@ edges2eventsSummary :: forall t . (Ord t) => t -> t -> StreamTransformer (t,S.ByteString,Edge) (S.ByteString, Event t Status) -edges2eventsSummary t0 t1 s = flush <$> I.foldl' step (M.empty,s) +edges2eventsSummary t0 t1 s = I.stateful (M.empty,s) step flush where -- State: (m, sum) where -- * m = subtrack => (event start, level = rise-fall, status)
Tools/TimePlot/Types.hs view
@@ -105,7 +105,7 @@ | KindHistogram { binSize :: Delta t, style :: PlotBarsStyle } | KindLines | KindDots { alpha :: Double } - | KindCumSum { subtrackStyle :: SumSubtrackStyle } + | KindCumSum { binSize :: Delta t, subtrackStyle :: SumSubtrackStyle } | KindSum { binSize :: Delta t, subtrackStyle :: SumSubtrackStyle } | KindNone | KindUnspecified -- Causes an error message
timeplot.cabal view
@@ -1,5 +1,5 @@ name: timeplot-version: 1.0.1+version: 1.0.3 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -29,8 +29,8 @@ buildable: True ghc-options: -rtsopts other-modules: Graphics.Rendering.Chart.Event- build-depends: Chart >=0.14, base >=3 && <5, bytestring -any,+ build-depends: Chart >=0.15, base >=3 && <5, bytestring -any, bytestring-lexing -any, cairo -any, colour -any, containers -any, data-accessor ==0.2.*, data-accessor-template >=0.2.1.1 && <0.3, regex-tdfa -any, strptime >=0.1.7, time -any,- transformers -any, hashmap -any, hashable -any+ transformers -any