timeplot 0.2.24 → 0.3.0
raw patch · 2 files changed
+254/−134 lines, 2 filesdep +transformers
Dependencies added: transformers
Files
- Tools/TimePlot.hs +250/−131
- timeplot.cabal +4/−3
Tools/TimePlot.hs view
@@ -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<t = l:merge ls (p:ps)- | True = p:merge (l:ls) ps- pulses = [PulseEvent t (Status {statusColor="", statusLabel=s}) | (t,Pulse s) <- tes]- edges = [(t,e) | (t,e) <- tes, case e of { Pulse _ -> 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<t1 = error "Times are not in ascending order"- | 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'...'<job-JOBID'",+ " and use -k job 'within[-] count 1'.",+ " 'acount N' is for activity counts: a histogram is drawn with granularity", " of N time units, where the bin corresponding to [t..t+N) has value",- " 'what was the maximal number of active events or impulses in that",- " interval'.",+ " 'what was the average number of active events or impulses in that",+ " interval'. When used inside 'within', the histogram is a stacked one,",+ " with one vertical bar per subtrack in each bin.",+ " 'afreq N' is for activity frequencies: it's like acount, but relative",+ " rather than absolute - it only makes sense inside 'within', because",+ " otherwise it would just always show a filled one-coloured bar in every bin.", " 'freq N [TYPE]' is for event frequency histograms: a histogram of type", " TYPE (stacked or clustered, default clustered) is drawn for each time", " bin of size N, about the *frequency* of various ` events",@@ -647,11 +758,19 @@ " 'binh N v1,v2,..' (example: binf 100 1,2,5,10) - a histogram of counts of", " values falling into bins min..v1, v1..v2, .., v2..max in time bins of", " size N",- " 'lines' - a simple line plot of numeric values",- " 'dots' - a simple dot plot of numeric values",- " 'cumsum' - a simple line plot of the sum of the numeric values",- " 'sum N' - 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."+ " 'lines' - a simple line plot of numeric values. When used in 'within', ",+ " gives one plot per subtrack.",+ " 'dots' - a simple dot plot of numeric values. When used in 'within', ",+ " gives one plot per subtrack.",+ " 'cumsum [TYPE]' - a simple line plot of the sum of the numeric values.",+ " 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",+ " 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." ]
timeplot.cabal view
@@ -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 <ekirpichov@gmail.com> 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