diff --git a/Tools/TimePlot.hs b/Tools/TimePlot.hs --- a/Tools/TimePlot.hs +++ b/Tools/TimePlot.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, GADTs, CPP #-} +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, GADTs, CPP, ParallelListComp #-} module Main where import Control.Monad +import qualified Control.Monad.Trans.State.Strict as St +import qualified Control.Monad.Trans.RWS.Strict as RWS import Control.Arrow import Data.List import Data.Ord import Data.Maybe import qualified Data.Map as M +import qualified Data.Set as Set import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lex.Lazy.Double @@ -36,6 +39,8 @@ import Data.Colour import Data.Colour.Names +import Debug.Trace + data Status = Status {statusColor :: String, statusLabel :: String} deriving (Eq, Show, Ord) instance PlotValue Status where @@ -52,11 +57,11 @@ axis_grid_ = [] } -data Edge = Rise | Fall | Pulse {pulseLabel :: String} | SetTo Status deriving (Eq,Show) +data Edge = Rise | Fall | Pulse Status | SetTo Status deriving (Eq,Show) -data InEvent = InEdge Edge - | InValue Double - | InAtom S.ByteString +data InEvent = InEdge {evt_track :: S.ByteString, evt_edge :: Edge} + | InValue {evt_track :: S.ByteString, evt_value :: Double} + | InAtom {evt_track :: S.ByteString, evt_atom :: S.ByteString} deriving (Show) data OutFormat = PNG | PDF | PS | SVG @@ -113,9 +118,13 @@ instance TimeAxis LocalTime -data (TimeAxis t) => ChartKind t = KindEvent - | KindDuration { mapName :: S.ByteString -> S.ByteString, subKind :: ChartKind t } - | KindCount { binSize :: Delta t } +data SumSubtrackStyle = SumStacked | SumOverlayed + +data ChartKind t = KindEvent + | KindDuration { subKind :: ChartKind t } + | KindWithin { mapName :: S.ByteString -> S.ByteString, subKind :: ChartKind t } + | KindACount { binSize :: Delta t } + | KindAFreq { binSize :: Delta t } | KindQuantile { binSize :: Delta t, quantiles :: [Double] } | KindBinFreq { binSize :: Delta t, delims :: [Double] } | KindBinHist { binSize :: Delta t, delims :: [Double] } @@ -123,8 +132,8 @@ | KindHistogram { binSize :: Delta t, style :: PlotBarsStyle } | KindLines | KindDots - | KindCumSum - | KindSum { binSize :: Delta t } + | KindCumSum { subtrackStyle :: SumSubtrackStyle } + | KindSum { binSize :: Delta t, subtrackStyle :: SumSubtrackStyle } | KindNone data ConcreteConf t = @@ -194,7 +203,8 @@ Nothing -> s Just bt -> showDelta t bt - parseKind ["count", n ] = KindCount {binSize=read n} + parseKind ["acount", n ] = KindACount {binSize=read n} + parseKind ["afreq", n ] = KindAFreq {binSize=read n} parseKind ["freq", n ] = KindFreq {binSize=read n,style=BarsClustered} parseKind ["freq", n,s] = KindFreq {binSize=read n,style=parseStyle s} parseKind ["hist", n ] = KindHistogram {binSize=read n,style=BarsClustered} @@ -202,14 +212,16 @@ parseKind ["event" ] = KindEvent parseKind ["quantile",b,q] = KindQuantile {binSize=read b, quantiles=read ("["++q++"]")} parseKind ["binf", b,q] = KindBinFreq {binSize=read b, delims =read ("["++q++"]")} - parseKind ["binh", b,q] = KindBinHist {binSize=read b, delims =read ("["++q++"]")} + parseKind ["binh", b,q] = KindBinHist {binSize=read b, delims =read ("["++q++"]")} parseKind ["lines" ] = KindLines parseKind ["dots" ] = KindDots - parseKind ["cumsum" ] = KindCumSum - parseKind ["sum", b ] = KindSum {binSize=read b} - parseKind ("duration":ws) = KindDuration {subKind=parseKind ws, mapName=id} - parseKind (('d':'u':'r':'a':'t':'i':'o':'n':'[':sep:"]"):ws) - = KindDuration {subKind=parseKind ws, mapName = fst . S.break (==sep)} + parseKind ["cumsum" ] = KindCumSum {subtrackStyle=SumStacked} + parseKind ["cumsum", s ] = KindCumSum {subtrackStyle=parseSubtrackStyle s} + parseKind ["sum", b ] = KindSum {binSize=read b, subtrackStyle=SumStacked} + parseKind ["sum", b,s] = KindSum {binSize=read b, subtrackStyle=parseSubtrackStyle s} + parseKind ("duration":ws) = KindDuration {subKind=parseKind ws} + parseKind (('w':'i':'t':'h':'i':'n':'[':sep:"]"):ws) + = KindWithin {subKind=parseKind ws, mapName = fst . S.break (==sep)} parseKind ["none" ] = KindNone parseKind ws = error ("Unknown diagram kind " ++ unwords ws) @@ -219,13 +231,16 @@ parseStyle "stacked" = BarsStacked parseStyle "clustered" = BarsClustered + parseSubtrackStyle "stacked" = SumStacked + parseSubtrackStyle "overlayed" = SumOverlayed + -- getArg "-a" 2 ["-b", "1", "-a", "2", "q", "r", "-c", "3", "-a", "x"] = -- [["2", "q"], ["x"]] getArg :: String -> Int -> [String] -> [[String]] getArg name arity args = [take arity as | (t:as) <- tails args, t==name] -readSource :: (Show t) => (B.ByteString -> Maybe (t,B.ByteString)) -> FilePath -> IO [(t, S.ByteString, InEvent)] +readSource :: (Show t) => (B.ByteString -> Maybe (t,B.ByteString)) -> FilePath -> IO [(t, InEvent)] readSource readTime f = (justs . map parseLine . blines) `fmap` (if f=="-" then B.getContents else B.readFile f) where justs xs = [x | Just x <- xs] @@ -238,19 +253,19 @@ (_, s'') <- B.uncons s' (c,rest) <- B.uncons s'' case c of - '>' -> return (t, strict rest, InEdge Rise ) - '<' -> return (t, strict rest, InEdge Fall ) + '>' -> return (t, InEdge (strict rest) Rise ) + '<' -> return (t, InEdge (strict rest) Fall ) '!' -> do let (track, val') = B.break (==' ') rest if B.null val' - then return (t, strict track, InEdge (Pulse "")) + then return (t, InEdge (strict track) (Pulse (Status "" ""))) else do (_,val) <- B.uncons val' - return (t, strict track, InEdge . Pulse . B.unpack $ val) + return (t, InEdge (strict track) $ Pulse (Status "" (B.unpack val))) '@' -> do let (track, val') = B.break (==' ') rest (_,val) <- B.uncons val' - return (t, strict track, InEdge $ SetTo (Status {statusColor = B.unpack $ val, statusLabel = ""})) + return (t, InEdge (strict track) $ SetTo (Status {statusColor = B.unpack $ val, statusLabel = ""})) '=' -> do let (track, val') = B.break (==' ') rest (_,val) <- B.uncons val' @@ -259,40 +274,40 @@ else do case B.head val of '`' -> do - return (t, strict track, InAtom (strict $ B.tail val)) + return (t, InAtom (strict track) (strict $ B.tail val)) _ -> do (v,_ ) <- readDouble val - return (t, strict track, InValue v) + return (t, InValue (strict track) v) _ -> Nothing makeChart :: forall t . TimeAxis t => (S.ByteString -> [ChartKind t]) -> - [(t, S.ByteString, InEvent)] -> + [(t, InEvent)] -> Maybe t -> Maybe t -> (t -> String -> String) -> Renderable () makeChart chartKindF [] minT maxT transformLabel = emptyRenderable makeChart chartKindF events0 minT maxT transformLabel = renderLayout1sStacked plots where - events :: [(t, S.ByteString, InEvent)] - events@((t0,_,_):_) = sortBy (comparing (\(t,_,_)-> t)) events0 + events :: [(t, InEvent)] + events@((t0,_):_) = sortBy (comparing (\(t,_)-> t)) events0 track2events :: M.Map S.ByteString [(t, InEvent)] - track2events = reverse `fmap` foldl' insert M.empty [(s, (t, e)) | (t, s, e) <- events] + track2events = reverse `fmap` foldl' insert M.empty [(evt_track e, x) | x@(t, e) <- events] where insert m (s, r) = M.alter (Just . maybe [r] (r:)) s m plots = [ plotTrack k kind es | (k, es) <- M.toList track2events, kind <- chartKindF k, - case kind of {KindNone -> False ; KindDuration _ _ -> False ; _ -> True} ] ++ - durationPlots + case kind of {KindNone -> False ; KindWithin _ _ -> False ; _ -> True} ] ++ + withinPlots - durationPlots = [ plotWithKind name k es | (name, (k,es)) <- M.toList durationTracks ] + withinPlots = [ plotWithKind name k es | (name, (k,es)) <- M.toList withinTracks ] where - durationTracks = M.fromListWith (\(ka,as) (kb,bs) -> (ka,mergeOn fst as bs)) components - components = [ (mn k, (sk, edges2durations (edges es) minTime maxTime)) + withinTracks = M.fromListWith (\(ka,as) (kb,bs) -> (ka,mergeOn fst as bs)) components + components = [ (mn k, (sk, es)) | (k, es) <- M.toList track2events, kind <- chartKindF k, - Just (sk,mn) <- [case kind of {KindDuration mn sk -> Just (sk,mn) ; _ -> Nothing}]] + Just (sk,mn) <- [case kind of {KindWithin mn sk -> Just (sk,mn) ; _ -> Nothing}]] mergeOn f [] ys = ys mergeOn f xs [] = xs mergeOn f (x:xs) (y:ys) @@ -310,12 +325,13 @@ where transformLabels axis = axis { axis_labels_ = map (map (\(t, s) -> (t, transformLabel t s))) (axis_labels_ axis) } - plotTrack :: S.ByteString -> ChartKind t -> [(t,InEvent)] -> AnyLayout1 t + plotTrack :: S.ByteString -> ChartKind t -> [(t, InEvent)] -> AnyLayout1 t plotTrack name kind es = plotWithKind name kind es plotWithKind :: S.ByteString -> ChartKind t -> [(t, InEvent)] -> AnyLayout1 t plotWithKind name k es = case k of - KindCount bs -> withAnyOrdinate $ plotTrackCount name es bs + KindACount bs -> withAnyOrdinate $ plotTrackACount name es bs + KindAFreq bs -> withAnyOrdinate $ plotTrackAFreq name es bs KindFreq bs k -> withAnyOrdinate $ plotTrackFreq name es bs k KindHistogram bs k -> withAnyOrdinate $ plotTrackHist name es bs k KindEvent -> withAnyOrdinate $ plotTrackEvent name es @@ -324,17 +340,18 @@ KindBinHist bs vs -> withAnyOrdinate $ plotTrackBinHist name es vs bs KindLines -> withAnyOrdinate $ plotTrackLines name es KindDots -> withAnyOrdinate $ plotTrackDots name es - KindSum bs -> withAnyOrdinate $ plotTrackSum name es bs - KindCumSum -> withAnyOrdinate $ plotTrackCumSum name es - KindDuration _ _ -> error "KindDuration should not be plotted" + KindSum bs ss -> withAnyOrdinate $ plotTrackSum name es bs ss + KindCumSum ss -> withAnyOrdinate $ plotTrackCumSum name es ss + KindDuration sk -> plotWithKind name sk (edges2durations (edges es) minTime maxTime) + KindWithin _ _ -> error "KindDuration should not be plotted" KindNone -> error "KindNone should not be plotted" - edges :: [(t,InEvent)] -> [(t,Edge)] - values :: [(t,InEvent)] -> [(t,Double)] - atoms :: [(t,InEvent)] -> [(t,S.ByteString)] - edges es = [(t,e) | (t,InEdge e) <- es] - values es = [(t,v) | (t,InValue v) <- es] - atoms es = [(t,a) | (t,InAtom a) <- es] + edges :: [(t,InEvent)] -> [(t,S.ByteString,Edge)] + values :: [(t,InEvent)] -> [(t,S.ByteString,Double)] + atoms :: [(t,InEvent)] -> [(t,S.ByteString,S.ByteString)] + edges es = [(t,s,e) | (t,InEdge s e) <- es] + values es = [(t,s,v) | (t,InValue s v) <- es] + atoms es = [(t,s,a) | (t,InAtom s a) <- es] ourPlotBars :: (BarsPlotValue a) => PlotBars t a ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 0 $ @@ -342,14 +359,32 @@ plot_bars_alignment ^= BarsLeft $ defaultPlotBars - plotTrackCount :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Int - plotTrackCount name es bs = layoutWithTitle (plotBars plot) name + plotTrackACount :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Double + plotTrackACount name es bs = layoutWithTitle [plotBars plot] name where plot = plot_bars_values ^= barsData $ - plot_bars_item_styles ^= [(solidFillStyle (opaque blue), Nothing)] $ + plot_bars_item_styles ^= itemStyles $ + plot_bars_titles ^= map show subTracks $ ourPlotBars - barsData :: [(t,[Int])] - barsData = [(t,[n]) | ((t,_),n) <- edges2bins bs minTime maxTime (edges es)] + itemStyles = [(solidFillStyle (opaque c), Nothing) | c <- colors] + bins = edges2bins bs minTime maxTime (edges es) + subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns] + barsData = [(t, map (fromMaybe 0 . (`lookup` sns)) subTracks) + | ((t,_),sns) <- edges2bins bs minTime maxTime (edges es), (s,n) <- sns] + plotTrackAFreq :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Double + plotTrackAFreq name es bs = layoutWithTitle [plotBars plot] name + where plot = plot_bars_values ^= barsData $ + plot_bars_item_styles ^= itemStyles $ + plot_bars_titles ^= map show subTracks $ + ourPlotBars + itemStyles = [(solidFillStyle (opaque c), Nothing) | c <- colors] + bins = edges2bins bs minTime maxTime (edges es) + subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns] + barsData = [(t, map ((/total) . fromMaybe 0 . (`lookup` sns)) subTracks) + | ((t,_),sns) <- edges2bins bs minTime maxTime (edges es), + let total = (\x -> if x==0 then 1 else x) $ sum [n | (s,n) <- sns], + (s,n) <- sns] + plotTrackFreq :: S.ByteString -> [(t,InEvent)] -> Delta t -> PlotBarsStyle -> Layout1 t Double plotTrackFreq = plotTrackAtoms atoms2freqs @@ -359,7 +394,7 @@ plotTrackAtoms :: (Num v, BarsPlotValue v) => ([S.ByteString] -> [S.ByteString] -> [v]) -> S.ByteString -> [(t,InEvent)] -> Delta t -> PlotBarsStyle -> Layout1 t v - plotTrackAtoms f name es bs k = layoutWithTitle (plotBars plot) name + plotTrackAtoms f name es bs k = layoutWithTitle [plotBars plot] name where plot = plot_bars_style ^= k $ plot_bars_values ^= vals $ plot_bars_item_styles ^= itemStyles $ @@ -367,24 +402,29 @@ ourPlotBars itemStyles = none:[(solidFillStyle (opaque c), Nothing) | c <- colors] vals = byTimeBins ((0:).f vs) bs t0 as - as = atoms es + -- TODO Multiple tracks + as = [(t,a) | (t,_,a) <- atoms es] vs = M.keys $ M.fromList $ [(a,()) | (_,a) <- as] + -- TODO Multiple tracks plotTrackEvent :: S.ByteString -> [(t,InEvent)] -> Layout1 t Status - plotTrackEvent name es = layoutWithTitle (toPlot plot) name - where plot = plot_event_data ^= edges2events (edges es) minTime maxTime $ + plotTrackEvent name es = layoutWithTitle [toPlot plot] name + where plot = plot_event_data ^= dropTrack (edges2events (edges es) minTime maxTime) $ plot_event_long_fillstyle ^= toFillStyle $ plot_event_label ^= toLabel $ defaultPlotEvent + dropTrack = map snd toFillStyle s = solidFillStyle . opaque $ fromMaybe lightgray (readColourName (statusColor s)) toLabel s = statusLabel s plotTrackQuantile :: S.ByteString -> [(t,InEvent)] -> [Double] -> Delta t -> Layout1 t Double - plotTrackQuantile name es qs bs = layoutWithTitle (plotBars plot) name - where plot = plot_bars_values ^= toBars (byTimeBins (getQuantiles qs) bs t0 (values es)) $ + plotTrackQuantile name es qs bs = layoutWithTitle [plotBars plot] name + where plot = plot_bars_values ^= toBars (byTimeBins (getQuantiles qs) bs t0 vs) $ plot_bars_item_styles ^= quantileStyles $ plot_bars_titles ^= quantileTitles $ ourPlotBars + -- TODO Multiple tracks + vs = [(t,v) | (t,_,v) <- values es] quantileStyles = none:(zip (map (solidFillStyle . opaque) colors) [Just $ solidLine 1 (opaque black) | i <- [0..n+1]]) quantileTitles = [""]++[show p1++".."++show p2++"%" | (p1,p2) <- lag percents ] where @@ -394,7 +434,7 @@ lag :: [a] -> [(a,a)] lag xs = xs `zip` tail xs - colors = cycle [green,blue,yellow,red,orange,brown,grey,purple,violet,lightblue] + colors = cycle [green,blue,red,brown,yellow,orange,grey,purple,violet,lightblue] binTitles vs = [low]++[show v1++".."++show v2 | (v1,v2) <- lag vs]++[high] where @@ -405,15 +445,18 @@ plotTrackBinFreqs name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n) where - vals = byTimeBins ((0:).values2binFreqs vs) bs t0 (values es) + vals = byTimeBins ((0:).values2binFreqs vs) bs t0 tvs n = length vs + -- TODO Multiple tracks + tvs = [(t,v) | (t,_,v) <- values es] plotTrackBinHist name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n) where - vals = byTimeBins ((0:).values2binHist vs) bs t0 (values es) + vals = byTimeBins ((0:).values2binHist vs) bs t0 tvs + tvs = [(t,v) | (t,_,v) <- values es] n = length vs plotTrackBars :: (BarsPlotValue a) => [(t,[a])] -> [String] -> S.ByteString -> (Int -> AlphaColour Double) -> Layout1 t a - plotTrackBars values titles name clr = layoutWithTitle (plotBars plot) name + plotTrackBars values titles name clr = layoutWithTitle [plotBars plot] name where plot = plot_bars_values ^= values $ plot_bars_item_styles ^= binStyles $ plot_bars_titles ^= "":titles $ @@ -425,29 +468,71 @@ toBars tvs = [(t,diffs vs) | (t,vs) <- tvs] diffs xs = zipWith (-) xs (0:xs) - plotLines :: S.ByteString -> [(t,Double)] -> Layout1 t Double - plotLines name vs = layoutWithTitle (toPlot plot) name - where plot = plot_lines_values ^= [vs] $ defaultPlotLines + groupByTrack xs = M.toList $ sort `fmap` M.fromListWith (++) [(s, [(t,v)]) | (t,s,v) <- xs] + plotLines :: S.ByteString -> [(S.ByteString, [(t,Double)])] -> Layout1 t Double + plotLines name vss = layoutWithTitle (map toPlot plots) name + where plots = [plot_lines_values ^= [vs] $ + plot_lines_title ^= S.unpack subtrack $ + plot_lines_style .> line_color ^= color $ + defaultPlotLines + | (subtrack, vs) <- vss + | color <- map opaque colors] + plotTrackLines :: S.ByteString -> [(t,InEvent)] -> Layout1 t Double - plotTrackLines name es = plotLines name (values es) + plotTrackLines name es = plotLines name (groupByTrack (values es)) plotTrackDots :: S.ByteString -> [(t,InEvent)] -> Layout1 t Double - plotTrackDots name es = layoutWithTitle (toPlot plot) name - where plot = plot_points_values ^= values es $ - plot_points_style ^= hollowCircles 4 1 (opaque blue) $ - defaultPlotPoints + plotTrackDots name es = layoutWithTitle (map toPlot plots) name + where plots = [plot_points_values ^= vs $ + plot_points_style ^= hollowCircles 4 1 color $ + plot_points_title ^= S.unpack subtrack $ + defaultPlotPoints + | (subtrack, vs) <- groupByTrack (values es) + | color <- map opaque colors] - plotTrackCumSum :: S.ByteString -> [(t,InEvent)] -> Layout1 t Double - plotTrackCumSum name es = plotLines name $ scanl (\(t1,s) (t2,v) -> (t2,s+v)) (minTime, 0) (values es) + plotTrackCumSum :: S.ByteString -> [(t,InEvent)] -> SumSubtrackStyle -> Layout1 t Double + plotTrackCumSum name es SumOverlayed = plotLines name rows + where rows = [(track, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (minTime, 0) vs) | (track, vs) <- groupByTrack (values es)] + plotTrackCumSum name es SumStacked = plotLines name rows + where vals = values es + allTracks = Set.toList $ Set.fromList [track | (t, track, v) <- vals] - plotTrackSum :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Double - plotTrackSum name es bs = plotLines name $ byTimeBins sum bs t0 (values es) + rows :: [(S.ByteString, [(t, Double)])] + rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs] - layoutWithTitle :: (PlotValue a) => Plot t a -> S.ByteString -> Layout1 t a - layoutWithTitle plot name = + rowsT :: [(t, [(S.ByteString, Double)])] + rowsT = (minTime, zip allTracks (repeat 0)) : St.evalState (mapM addDataPoint vals) 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)) + + + plotTrackSum :: S.ByteString -> [(t,InEvent)] -> Delta t -> SumSubtrackStyle -> Layout1 t Double + plotTrackSum name es bs ss = plotLines name rows + where groups = groupByTrack (values es) + allTracks = M.keys $ M.fromList groups + + rowsT :: [(t, M.Map S.ByteString Double)] + rowsT = byTimeBins (M.fromListWith (+)) bs t0 $ sort [(t, (track, v)) | (track, vs) <- groups, (t, v) <- vs] + + rowsT' = case ss of + SumOverlayed -> map (\(t,ss) -> (t, M.toList ss)) rowsT + SumStacked -> map (\(t,ss) -> (t, stack ss)) rowsT + + stack :: M.Map S.ByteString Double -> [(S.ByteString, Double)] + stack ss = zip allTracks (scanl1 (+) (map (\x -> M.findWithDefault 0 x ss) allTracks)) + + rows :: [(S.ByteString, [(t, Double)])] + rows = M.toList $ sort `fmap` M.fromListWith (++) [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m] + + layoutWithTitle :: (PlotValue a) => [Plot t a] -> S.ByteString -> Layout1 t a + layoutWithTitle plots name = layout1_title ^= "" $ - layout1_plots ^= [Left plot] $ + layout1_plots ^= map Left plots $ layout1_bottom_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $ layout1_top_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $ layout1_left_axis .> laxis_title ^= S.unpack name $ @@ -455,51 +540,69 @@ layout1_grid_last ^= True $ defaultLayout1 -edges2durations :: forall t. (Ord t, HasDelta t) => [(t,Edge)] -> t -> t -> [(t,InEvent)] -edges2durations tes minTime maxTime = [(t2, InValue $ toSeconds (t2 `sub` t1) (undefined::t)) | LongEvent t1 t2 _ <- edges2events tes minTime maxTime] +edges2durations :: forall t. (Ord t, HasDelta t) => [(t,S.ByteString,Edge)] -> t -> t -> [(t,InEvent)] +edges2durations tes minTime maxTime = [(t2, InValue track $ toSeconds (t2 `sub` t1) (undefined::t)) | (track,LongEvent t1 t2 _) <- edges2events tes minTime maxTime] -edges2events :: (Ord t) => [(t,Edge)] -> t -> t -> [Event t Status] -edges2events tes minTime maxTime = longs `merge` pulses +edges2events :: (Ord t) => [(t,S.ByteString,Edge)] -> t -> t -> [(S.ByteString,Event t Status)] +edges2events tes minTime maxTime = snd $ RWS.execRWS (mapM_ step tes >> flush) () M.empty where - merge [] ps = ps - merge ls [] = ls - merge (l@(LongEvent t1 t2 _):ls) (p@(PulseEvent t _):ps) - | t1 False; _ -> True } ] - longs = longs' (Status "" "") Nothing 0 edges - where - longs' s _ 0 [] = [] - longs' s (Just t0) _ [] = [LongEvent t0 maxTime s] - longs' s Nothing 0 ((t,Rise):tes) = longs' s (Just t) 1 tes - longs' s Nothing 0 ((t,Fall):tes) = longs' s Nothing 0 tes - longs' s (Just t0) n ((t,Rise):tes) = longs' s (Just t0) (n+1) tes - longs' s (Just t0) 1 ((t,Fall):tes) = LongEvent t0 t s : longs' s Nothing 0 tes - longs' s (Just t0) n ((t,Fall):tes) = longs' s (Just t0) (n-1) tes - longs' s Nothing 0 ((t,SetTo s'):tes) = longs' s' (Just t) 1 tes - longs' s (Just t0) n ((t,SetTo s'):tes) = LongEvent t0 t s : longs' s' (Just t) n tes + getTrack s = M.findWithDefault (undefined, 0, emptyStatus) s `fmap` RWS.get + putTrack s t = RWS.get >>= RWS.put . M.insert s t + trackCase s whenZero withNonzero = do + (t0, numActive, st) <- getTrack s + case numActive of + 0 -> whenZero + n -> withNonzero t0 numActive st + killTrack s = RWS.get >>= RWS.put . M.delete s -edges2bins :: (Ord t,HasDelta t,Show t) => Delta t -> t -> t -> [(t,Edge)] -> [((t,t), Int)] -edges2bins binSize minTime maxTime es = gather 0 0 0 es maxTime $ iterate (add binSize) minTime + emptyStatus = Status "" "" + + step (t,s,Pulse st) = RWS.tell [(s, PulseEvent t st)] + step (t,s,SetTo st) = trackCase s (putTrack s (t, 1, st)) + (\t0 n st0 -> RWS.tell [(s, LongEvent t0 t st0)] >> + putTrack s (t, n, st)) + step (t,s,Rise) = trackCase s (putTrack s (t, 1, emptyStatus)) + (\t0 n st -> putTrack s (t, n+1, st)) + step (t,s,Fall) = do + (t0, numActive, st) <- getTrack s + case numActive of + 1 -> RWS.tell [(s, LongEvent t0 t st)] >> killTrack s + n -> putTrack s (t0, max 0 (n-1), st) + + flush = RWS.get >>= mapM_ (\(s, (t0,_,st)) -> RWS.tell [(s, LongEvent t0 maxTime st)]) . M.toList + +edges2bins :: forall t. (Ord t,HasDelta t,Show t) => Delta t -> t -> t -> [(t,S.ByteString,Edge)] -> [((t,t), [(S.ByteString,Double)])] +edges2bins binSize minTime maxTime es = snd $ RWS.execRWS (mapM_ step es >> flush) () (M.empty, iterate (add binSize) minTime) where - gather :: (Ord t) => Int -> Int -> Int -> [(t,Edge)] -> t -> [t] -> [((t,t), Int)] - gather 0 _ _ [] maxTime (t1:t2:ts) = [] - gather n nopen npulse [] maxTime (t1:t2:ts) = if t2 <= maxTime - then ((t1,t2),n):gather nopen nopen npulse [] maxTime (t2:ts) - else [] - gather nmax nopen npulse ((t,e):tes) maxTime (t1:t2:ts) - | t=t2 = ((t1,t2),nmax):gather nopen nopen 0 ((t,e):tes) maxTime (t2:ts) - gather nmax nopen npulse ((t,Rise ):tes) maxTime (t1:t2:ts) - = gather (nmax `max` (nopen+npulse+1)) (nopen+1) npulse tes maxTime (t1:t2:ts) - gather nmax nopen npulse ((t,Fall ):tes) maxTime (t1:t2:ts) - = gather nmax (nopen-1) npulse tes maxTime (t1:t2:ts) - gather nmax nopen npulse ((t,Pulse _):tes) maxTime (t1:t2:ts) - = gather (nmax `max` (nopen+npulse+1)) nopen (npulse+1) tes maxTime (t1:t2:ts) - gather nmax nopen npulse ((t,SetTo s):tes) maxTime (t1:t2:ts) - = gather nmax nopen npulse tes maxTime (t1:t2:ts) + getBin = RWS.gets $ \(m, t1:t2:ts) -> (t1, t2) + nextBin = RWS.get >>= \(m, t1:t2:ts) -> RWS.put (m, t2:ts) + getState s t = RWS.gets $ \(m, _) -> (M.findWithDefault (0,t,0,0) s m) + putState s v = RWS.get >>= \(m, ts) -> RWS.put (M.insert s v m, ts) + modState s t f = getState s t >>= putState s . f + getStates = RWS.gets (\(m,_) -> M.toList m) + flushBin = do + bin@(t1,t2) <- getBin + states <- getStates + let binSizeSec = toSeconds (t2 `sub` t1) t1 + RWS.tell [(bin, [(s, (fromIntegral npulse/binSizeSec + area + toSeconds (t2 `sub` start) t2*nopen)/binSizeSec) | (s,(area,start,nopen,npulse)) <- states])] + forM_ states $ \(s, (area,start,nopen,_)) -> putState s (0,t2,nopen,0) + nextBin + + step ev@(t, s, e) = do + (t1, t2) <- getBin + if t < t1 + then error "Times are not in ascending order" + else if (t >= t2) + then flushBin >> step ev + else step'' ev + step'' ev@(t,s,e) = do (t1,t2) <- getBin; when (t < t1 || t >= t2) (error "Outside bin"); step' ev + step' (t, s, SetTo _) = modState s t id + step' (t, s, Pulse _) = modState s t id + step' (t, s, Rise) = modState s t $ \(area, start, nopen, npulse) -> (area+toSeconds (t `sub` start) t*nopen, t, nopen+1, npulse) + step' (t, s, Fall) = modState s t $ \(area, start, nopen, npulse) -> (area+toSeconds (t `sub` start) t*nopen, t, nopen-1, npulse) + flush = getBin >>= \(t1,t2) -> when (t2 <= maxTime) (flushBin >> flush) + values2timeBins :: (Ord t) => [t] -> [(t,a)] -> [[a]] values2timeBins (t1:t2:ts) [] = [] values2timeBins (t1:t2:ts) tvs@((t,_):_) @@ -557,11 +660,11 @@ n = length xs toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n) -zoom :: (TimeAxis t) => [(t, S.ByteString, InEvent)] -> Maybe t -> Maybe t -> [(t, S.ByteString, InEvent)] +zoom :: (TimeAxis t) => [(t, InEvent)] -> Maybe t -> Maybe t -> [(t, InEvent)] zoom events fromTime toTime = filter p events where - p (t, _, _) = (maybe True (\ft -> t >= ft) fromTime) && - (maybe True (\tt -> t < tt) toTime) + p (t, _) = (maybe True (\ft -> t >= ft) fromTime) && + (maybe True (\tt -> t < tt) toTime) showHelp = mapM_ putStrLn [ "", "tplot - a tool for drawing timing diagrams.", @@ -623,16 +726,24 @@ " 300 0.25,0.5,0.75' will plot these quantiles of durations of the", " events. This is useful where your log looks like 'Started processing'", " ... 'Finished processing': you can plot processing durations without", - " computing them yourself.", - " 'duration[C] XXXX' - same as 'duration', but of a track's name we only", - " take the part before character C. For example, if you have processes", + " computing them yourself. Very useful inside 'within'!", + " 'within[C] XXXX' - draw plot XXXX over events grouped by their track's name ", + " before separator C. For example, if you have processes", " named 'MACHINE-PID' (i.e. UNIT027-8532) say 'begin something' / ", " 'end something' and you're interested in the properties of per-machine", - " durations, use duration[-].", - " 'count N' is for activity counts: a histogram is drawn with granularity", + " durations, use within[-] duration dots; or if you've got jobs starting", + " and finishing tasks on different machines, and you want to plot a diagram", + " showing the number of utilized machines and how this number is composed of", + " utilization by different jobs, make your trace say '>job-JOBID'...' just lay the subplots over one another.", + " 'stacked' -> add them up at each point to see how subtracks contribute", + " to the total cumulative sum (default; only makes sense inside 'within')", + " 'sum N [TYPE]' - a simple line plot of the sum of the numeric values in time", + " bins of size N. N is measured in units or in seconds.", + " When used in 'within', produce 1 subplot per subtrack. TYPE used in same ", + " way as in cumsum." ] diff --git a/timeplot.cabal b/timeplot.cabal --- a/timeplot.cabal +++ b/timeplot.cabal @@ -1,10 +1,10 @@ name: timeplot -version: 0.2.24 +version: 0.3.0 cabal-version: >=1.6 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Eugene Kirpichov, 2009 +copyright: Eugene Kirpichov, 2009-2011 maintainer: Eugene Kirpichov stability: stable homepage: http://haskell.org/haskellwiki/Timeplot @@ -35,4 +35,5 @@ build-depends: Chart >=0.14, 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, - haskell98 -any, regex-tdfa -any, strptime >=0.1.7, time -any + haskell98 -any, regex-tdfa -any, strptime >=0.1.7, time -any, + transformers -any