timeplot-0.3.14: Tools/TimePlot.hs
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, ParallelListComp, CPP #-}
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
import Data.Char
import Text.Regex.TDFA
import Text.Regex.TDFA.ByteString
import System.Environment
import System.Exit
import System.Console.GetOpt
import Data.Time hiding (parseTime)
import Data.Time.Parse
import Data.Accessor
import Graphics.Rendering.Chart
#ifdef HAVE_GTK
import Graphics.Rendering.Chart.Gtk
#endif
import Graphics.Rendering.Chart.Grid
import Graphics.Rendering.Chart.Plot
import Graphics.Rendering.Chart.Event
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
toValue = const 0
fromValue = const (Status "" "")
autoAxis = const unitStatusAxis
unitStatusAxis :: AxisData Status
unitStatusAxis = AxisData {
axis_viewport_ = \(x0,x1) _ -> (x0+x1)/2,
axis_tropweiv_ = \_ _ -> Status "" "",
axis_ticks_ = [(Status "" "", 0)],
axis_labels_ = [[(Status "" "", "")]],
axis_grid_ = []
}
data Edge = Rise | Fall | Pulse Status | SetTo Status deriving (Eq,Show)
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
#ifdef HAVE_GTK
| Window
#endif
class HasDelta t where
type Delta t :: *
add :: Delta t -> t -> t
sub :: t -> t -> Delta t
-- the 't' is a dummy argument here, just to aid type checking
-- (since given just a Delta t, the compiler won't be able to
-- figure out which 't' we're speaking of)
toSeconds :: Delta t -> t -> Double
fromSeconds :: Double -> t -> Delta t
showDelta :: t -> t -> String
instance HasDelta Double where
type Delta Double = Double
add d t = t + d
sub t2 t1 = t2 - t1
toSeconds d _ = d
fromSeconds d _ = d
showDelta a b = show (a - b)
instance HasDelta LocalTime where
type Delta LocalTime = NominalDiffTime
add d t = utcToLocalTime utc (addUTCTime d (localTimeToUTC utc t))
sub t2 t1 = diffUTCTime (localTimeToUTC utc t2) (localTimeToUTC utc t1)
toSeconds d _ = fromIntegral (truncate (1000000*d)) / 1000000
fromSeconds d _ = fromRational (toRational d)
showDelta t1 t2
| ts0 < 0.001 = "0"
| tm < 1 = showsPrec 3 s "s"
| th < 1 = show m ++ "m" ++ (if s<1 then "" else (show (floor s) ++ "s"))
| d < 1 = show h ++ "h" ++ (if m<1 then "" else (show m ++ "m"))
| True = show d ++ "d" ++ (if h<1 then "" else (show h ++ "h"))
where ts0 = toSeconds (t1 `sub` t2) t1
ts = if ts0 < 60 then ts0 else fromIntegral (round ts0)
tm = floor (ts / 60) :: Int
th = tm `div` 60 :: Int
s = ts - 60 * fromIntegral tm :: Double
m = tm - 60 * th :: Int
h = th - 24 * d :: Int
d = h `div` 24 :: Int
instance Read NominalDiffTime where
readsPrec n s = [(fromSeconds i (undefined::LocalTime), s') | (i,s') <- readsPrec n s]
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 }
| KindAPercent { binSize :: Delta t, baseCount :: Double }
| KindAFreq { binSize :: Delta t }
| KindQuantile { binSize :: Delta t, quantiles :: [Double] }
| KindBinFreq { binSize :: Delta t, delims :: [Double] }
| KindBinHist { binSize :: Delta t, delims :: [Double] }
| KindFreq { binSize :: Delta t, style :: PlotBarsStyle }
| KindHistogram { binSize :: Delta t, style :: PlotBarsStyle }
| KindLines
| KindDots { alpha :: Double }
| KindCumSum { subtrackStyle :: SumSubtrackStyle }
| KindSum { binSize :: Delta t, subtrackStyle :: SumSubtrackStyle }
| KindNone
| KindUnspecified -- Causes an error message
data ZoomMode = ZoomInput | ZoomOutput
data ConcreteConf t =
ConcreteConf {
inFile :: !FilePath,
parseTime :: !(B.ByteString -> Maybe (t, B.ByteString)),
chartKindF :: !(S.ByteString -> [ChartKind t]),
fromTime :: !(Maybe t),
toTime :: !(Maybe t),
zoomMode :: !ZoomMode,
transformLabel :: !(t -> String -> String),
outFile :: !FilePath,
outFormat :: !OutFormat,
outResolution :: !(Int,Int)
}
type Conf = ConcreteConf LocalTime
data KindChoiceOperator = Cut | Accumulate
readConf :: [String] -> Conf
readConf args = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%OS")) of
"date":f -> readConf' (strptime (B.pack $ unwords f))
_ -> error "Unrecognized time format (-tf)"
where
int2double = fromIntegral :: Int -> Double
single desc name def = case (getArg name 1 args) of
[[r]] -> r
[] -> def
_ -> error $ "Single argument expected for: "++desc++" ("++name++")"
readConf' :: (B.ByteString -> Maybe (LocalTime, B.ByteString)) -> ConcreteConf LocalTime
readConf' parseTime = ConcreteConf {inFile=inFile, outFile=outFile, outFormat=outFormat, outResolution=outRes,
chartKindF=chartKindF, parseTime=parseTime, fromTime=fromTime, toTime=toTime,
transformLabel=transformLabel, zoomMode=zoomMode}
where
inFile = single "input file" "-if" (error "No input file (-if) specified")
outFile = single "output file" "-o" (error "No output file (-o) specified")
outFormat = maybe PNG id $ lookup (single "output format" "-of" (name2format outFile)) $
[("png",PNG), ("pdf",PDF), ("ps",PS), ("svg",SVG)
#ifdef HAVE_GTK
, ("x",Window)
#endif
]
where
name2format = reverse . takeWhile (/='.') . reverse
outRes = parseRes $ single "output resolution" "-or" "640x480"
where
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 $
[(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
plusKinds = [parseKind (words kind) | [regex, kind] <- getArg "+k" 2 args]
minusKinds = [parseKind (words kind) | [regex, kind] <- getArg "-k" 2 args]
kindByRegex rks s = if null specifiedKinds then [defaultKindMinus] else specifiedKinds
where
specifiedKinds = defaultKindsPlus ++
[k | (Accumulate, p, k) <- rks, p s] ++
case [k | (Cut, p, k) <- rks, p s] of {k:_ -> [k]; _ -> []}
matches regex = matchTest (makeRegexOpts defaultCompOpt (ExecOption {captureGroups = False}) regex)
fromTime = fst `fmap` (parseTime . B.pack $ single "minimum time (inclusive)" "-fromTime" "")
toTime = fst `fmap` (parseTime . B.pack $ single "maximum time (exclusive)" "-toTime" "")
baseTime = fst `fmap` (parseTime . B.pack $ single "base time" "-baseTime" "")
zoomMode = case single "zoom mode (input/output)" "-zoomMode" "input" of
"input" -> ZoomInput
"output" -> ZoomOutput
transformLabel t s = case baseTime of
Nothing -> s
Just bt -> showDelta t bt
parseKind :: [String] -> ChartKind LocalTime
parseKind ["acount", n ] = KindACount {binSize=read n}
parseKind ("acount":_) = error "acount requires a single numeric argument, bin size, e.g.: -dk 'acount 1'"
parseKind ["apercent",n,b] = KindAPercent {binSize=read n,baseCount=read b}
parseKind ("apercent":_) = error "apercent requires two numeric arguments: bin size and base value, e.g.: -dk 'apercent 1 480'"
parseKind ["afreq", n ] = KindAFreq {binSize=read n}
parseKind ("afreq":_) = error "afreq requires a single numeric argument, bin size, e.g.: -dk 'afreq 1'"
parseKind ["freq", n ] = KindFreq {binSize=read n,style=BarsClustered}
parseKind ["freq", n,s] = KindFreq {binSize=read n,style=parseStyle s}
parseKind ("freq":_) = error $ "freq requires a single numeric argument, bin size, e.g.: -dk 'freq 1', " ++
"or two arguments, e.g.: -dk 'freq 1 clustered'"
parseKind ["hist", n ] = KindHistogram {binSize=read n,style=BarsClustered}
parseKind ["hist", n,s] = KindHistogram {binSize=read n,style=parseStyle s}
parseKind ("hist":_) = error $ "hist requires a single numeric argument, bin size, e.g.: -dk 'hist 1', " ++
"or two arguments, e.g.: -dk 'hist 1 clustered'"
parseKind ["event" ] = KindEvent
parseKind ("event":_) = error "event requires no arguments"
parseKind ["quantile",b,q] = KindQuantile {binSize=read b, quantiles=read ("["++q++"]")}
parseKind ("quantile":_) = error $ "quantile requres two arguments: bin size and comma-separated " ++
"(without spaces!) quantiles, e.g.: -dk 'quantile 1 0.5,0.75,0.9'"
parseKind ["binf", b,q] = KindBinFreq {binSize=read b, delims =read ("["++q++"]")}
parseKind ("binf":_) = error $ "binf requres two arguments: bin size and comma-separated " ++
"(without spaces!) threshold values, e.g.: -dk 'binf 1 10,50,100,200,500'"
parseKind ["binh", b,q] = KindBinHist {binSize=read b, delims =read ("["++q++"]")}
parseKind ("binh":_) = error $ "binh requres two arguments: bin size and comma-separated " ++
"(without spaces!) threshold values, e.g.: -dk 'binh 1 10,50,100,200,500'"
parseKind ["lines" ] = KindLines
parseKind ("lines":_) = error "lines requires no arguments"
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 ["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 " ++
"subtrack style, e.g.: -dk 'sum 1' or -dk 'sum 1 stacked'"
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 ("none":_) = error "none requires no arguments"
parseKind ["unspecified" ] = KindUnspecified
parseKind ("unspecified":_)= error "unspecified requires no arguments"
parseKind ws = error ("Unknown diagram kind " ++ unwords ws)
defaultKindMinus = parseKind $ words $ single "default kind" "-dk" "unspecified"
defaultKindsPlus = map (parseKind . words . head) $ getArg "+dk" 1 args
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, InEvent)]
readSource readTime f = (map parseLine . filter (not . B.null) . blines) `fmap` (if f=="-" then B.getContents else B.readFile f)
where
blines = map pruneLF . B.split '\n'
pruneLF b | not (B.null b) && (B.last b == '\r') = B.init b
| otherwise = b
strict = S.concat . B.toChunks
parseLine s = (\x -> case x of { Just e -> e; Nothing -> error $ "Unparseable input line: " ++ B.unpack s }) $ do
(t, s') <- readTime s
(_, s'') <- B.uncons s'
(c,rest) <- B.uncons s''
case c of
'>' -> 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, InEdge (strict track) (Pulse (Status "" "")))
else do
(_,val) <- B.uncons val'
return (t, InEdge (strict track) $ Pulse (Status "" (B.unpack val)))
'@' -> do
let (track, val') = B.break (==' ') rest
(_,val) <- B.uncons val'
return (t, InEdge (strict track) $ SetTo (Status {statusColor = B.unpack $ val, statusLabel = ""}))
'=' -> do
let (track, val') = B.break (==' ') rest
(_,val) <- B.uncons val'
if B.null val
then Nothing
else do
case B.head val of
'`' -> do
return (t, InAtom (strict track) (strict $ B.tail val))
_ -> do
(v,_ ) <- readDouble val
return (t, InValue (strict track) v)
_ -> Nothing
makeChart :: (S.ByteString -> [ChartKind LocalTime]) ->
[(LocalTime, InEvent)] ->
Maybe LocalTime -> Maybe LocalTime ->
ZoomMode ->
(LocalTime -> String -> String) ->
Renderable ()
makeChart chartKindF [] minT maxT zoomMode transformLabel = emptyRenderable
makeChart chartKindF events0 minT maxT zoomMode transformLabel = renderLayout1sStacked plots
where
events :: [(LocalTime, InEvent)]
events@((t0,_):_) = sortBy (comparing (\(t,_)-> t)) events0
track2events :: M.Map S.ByteString [(LocalTime, InEvent)]
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 ; KindWithin _ _ -> False ; _ -> True} ] ++
withinPlots
withinPlots = [ plotWithKind name k es | (name, (k,es)) <- M.toList withinTracks ]
where
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 {KindWithin mn sk -> Just (sk,mn) ; _ -> Nothing}]]
mergeOn f [] ys = ys
mergeOn f xs [] = xs
mergeOn f (x:xs) (y:ys)
| f x <= f y = x : mergeOn f xs (y:ys)
| otherwise = y : mergeOn f (x:xs) ys
minInTime = case (zoomMode, minT) of (ZoomInput, Just t) -> t ; _ -> head times
maxInTime = case (zoomMode, maxT) of (ZoomInput, Just t) -> t ; _ -> last times
minOutTime = case (zoomMode, minT) of (ZoomOutput, Just t) -> t ; _ -> head times
maxOutTime = case (zoomMode, maxT) of (ZoomOutput, Just t) -> t ; _ -> last times
times :: [LocalTime]
times = sort $ [t | tes <- M.elems track2events, (t,_)<- tes]
commonTimeAxis :: AxisData LocalTime
commonTimeAxis = transformLabels $ autoAxis axisTimes
where
axisTimes = case zoomMode of
ZoomInput -> [minInTime] ++ times ++ [maxInTime]
ZoomOutput -> [minOutTime] ++ filter (\x -> x >= minOutTime && x <= maxOutTime) times ++ [maxOutTime]
transformLabels axis = axis { axis_labels_ = map (map (\(t, s) -> (t, transformLabel t s))) (axis_labels_ axis) }
plotTrack :: S.ByteString -> ChartKind LocalTime -> [(LocalTime, InEvent)] -> AnyLayout1 LocalTime
plotTrack name kind es = plotWithKind name kind es
plotWithKind :: S.ByteString -> ChartKind LocalTime -> [(LocalTime, InEvent)] -> AnyLayout1 LocalTime
plotWithKind name k es = case k of
KindACount bs -> withAnyOrdinate $ plotTrackACount name es bs
KindAPercent bs b -> withAnyOrdinate $ plotTrackAPercent name es bs b
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
KindQuantile bs qs -> withAnyOrdinate $ plotTrackQuantile name es qs bs
KindBinFreq bs vs -> withAnyOrdinate $ plotTrackBinFreqs name es vs bs
KindBinHist bs vs -> withAnyOrdinate $ plotTrackBinHist name es vs bs
KindLines -> withAnyOrdinate $ plotTrackLines name es
KindDots alpha -> withAnyOrdinate $ plotTrackDots name es alpha
KindSum bs ss -> withAnyOrdinate $ plotTrackSum name es bs ss
KindCumSum ss -> withAnyOrdinate $ plotTrackCumSum name es ss
KindDuration sk -> plotWithKind name sk (edges2durations (edges es) minInTime maxInTime name)
KindWithin _ _ -> error $ "KindDuration should not be plotted: track " ++ show name
KindNone -> error $ "KindNone should not be plotted: track " ++ show name
KindUnspecified -> error $ "Kind not specified for track " ++ show name ++ " (have you misspelled -dk or any of -k arguments?)"
edges :: [(LocalTime,InEvent)] -> [(LocalTime,S.ByteString,Edge)]
values :: [(LocalTime,InEvent)] -> [(LocalTime,S.ByteString,Double)]
atoms :: [(LocalTime,InEvent)] -> [(LocalTime,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 LocalTime a
ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 0 $
plot_bars_style ^= BarsStacked $
plot_bars_alignment ^= BarsLeft $
defaultPlotBars
plotTrackActivity :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> ([(S.ByteString, Double)] -> Double -> Double) -> Layout1 LocalTime Double
plotTrackActivity name es bs transform = layoutWithTitle [plotBars plot] name (length subTracks > 1)
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 minInTime maxInTime (edges es)
subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns]
barsData = [(t, map (transform sns . fromMaybe 0 . (`lookup` sns)) subTracks)
| ((t,_),sns) <- bins, (s,n) <- sns]
plotTrackACount :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Layout1 LocalTime Double
plotTrackACount name es bs = plotTrackActivity name es bs (\_ -> id)
plotTrackAFreq :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Layout1 LocalTime Double
plotTrackAFreq name es bs = plotTrackActivity name es bs $ \sns ->
let total = (\x -> if x==0 then 1 else x) $ sum [n | (s,n) <- sns] in (/total)
plotTrackAPercent :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Double -> Layout1 LocalTime Double
plotTrackAPercent name es bs b = plotTrackActivity name es bs (\_ x -> 100*x/b)
plotTrackFreq :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime Double
plotTrackFreq = plotTrackAtoms atoms2freqs
plotTrackHist :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime Int
plotTrackHist = plotTrackAtoms atoms2hist
plotTrackAtoms :: (Num v, BarsPlotValue v) =>
([S.ByteString] -> [S.ByteString] -> [v]) ->
S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime v
plotTrackAtoms f name es bs k = layoutWithTitle [plotBars plot] name (length vs > 1)
where plot = plot_bars_style ^= k $
plot_bars_values ^= vals $
plot_bars_item_styles ^= itemStyles $
plot_bars_titles ^= "":map show vs $
ourPlotBars
itemStyles = none:[(solidFillStyle (opaque c), Nothing) | c <- colors]
vals = byTimeBins ((0:).f vs) bs t0 as
-- TODO Multiple tracks
as = [(t,a) | (t,_,a) <- atoms es]
vs = M.keys $ M.fromList $ [(a,()) | (_,a) <- as]
-- TODO Multiple tracks
plotTrackEvent :: S.ByteString -> [(LocalTime,InEvent)] -> Layout1 LocalTime Status
plotTrackEvent name es = layoutWithTitle [toPlot plot] name False
where plot = plot_event_data ^= dropTrack (edges2events (edges es) minInTime maxInTime) $
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 -> [(LocalTime,InEvent)] -> [Double] -> NominalDiffTime -> Layout1 LocalTime Double
plotTrackQuantile name es qs bs = layoutWithTitle [plotBars plot] name False
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) [Nothing | i <- [0..n+1]])
quantileTitles = [""]++[show p1++".."++show p2++"%" | (p1,p2) <- lag percents ]
where
percents = map (floor . (*100.0)) $ [0.0] ++ qs ++ [1.0]
n = length qs
lag :: [a] -> [(a,a)]
lag xs = xs `zip` tail xs
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
low = "<"++show (head vs)
high = ">"++show (last vs)
binColor n i = opaque (colors !! i)
plotTrackBinFreqs name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n)
where
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 tvs
tvs = [(t,v) | (t,_,v) <- values es]
n = length vs
plotTrackBars :: (BarsPlotValue a) => [(LocalTime,[a])] -> [String] -> S.ByteString -> (Int -> AlphaColour Double) -> Layout1 LocalTime a
plotTrackBars values titles name clr = layoutWithTitle [plotBars plot] name (length titles > 1)
where plot = plot_bars_values ^= values $
plot_bars_item_styles ^= binStyles $
plot_bars_titles ^= "":titles $
ourPlotBars
binStyles = none:[(solidFillStyle (clr i), Nothing)
| (i,_) <- [0..]`zip`titles]
none = (solidFillStyle transparent, Nothing)
toBars tvs = [(t,diffs vs) | (t,vs) <- tvs]
diffs xs = zipWith (-) xs (0:xs)
groupByTrack xs = M.toList $ sort `fmap` M.fromListWith (++) [(s, [(t,v)]) | (t,s,v) <- xs]
plotLines :: S.ByteString -> [(S.ByteString, [(LocalTime,Double)])] -> Layout1 LocalTime Double
plotLines name vss = layoutWithTitle (map toPlot plots) name (length vss > 1)
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 -> [(LocalTime,InEvent)] -> Layout1 LocalTime Double
plotTrackLines name es = plotLines name (groupByTrack (values es))
plotTrackDots :: S.ByteString -> [(LocalTime,InEvent)] -> Double -> Layout1 LocalTime Double
plotTrackDots name es alpha = layoutWithTitle (map toPlot plots) name (length vss > 1)
where plots = [plot_points_values ^= vs $
plot_points_style ^= hollowCircles 4 1 color $
plot_points_title ^= S.unpack subtrack $
defaultPlotPoints
| (subtrack, vs) <- vss
| color <- if alpha == 1 then map opaque colors else map (`withOpacity` alpha) colors]
vss = groupByTrack (values es)
plotTrackCumSum :: S.ByteString -> [(LocalTime,InEvent)] -> SumSubtrackStyle -> Layout1 LocalTime Double
plotTrackCumSum name es SumOverlayed = plotLines name rows
where rows = [(track, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (minInTime, 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]
rows :: [(S.ByteString, [(LocalTime, Double)])]
rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs]
rowsT :: [(LocalTime, [(S.ByteString, Double)])]
rowsT = (minInTime, 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 -> [(LocalTime,InEvent)] -> NominalDiffTime -> SumSubtrackStyle -> Layout1 LocalTime Double
plotTrackSum name es bs ss = plotLines name rows
where groups = groupByTrack (values es)
allTracks = M.keys $ M.fromList groups
rowsT :: [(LocalTime, 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, [(LocalTime, Double)])]
rows = M.toList $ sort `fmap` M.fromListWith (++) [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m]
layoutWithTitle :: (PlotValue a) => [Plot LocalTime a] -> S.ByteString -> Bool -> Layout1 LocalTime a
layoutWithTitle plots name showLegend =
layout1_title ^= "" $
layout1_plots ^= map Left plots $
(if showLegend then id else (layout1_legend ^= Nothing)) $
layout1_bottom_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $
layout1_top_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $
layout1_left_axis .> laxis_title ^= S.unpack name $
layout1_margin ^= 0 $
layout1_grid_last ^= True $
defaultLayout1
edges2durations :: forall t. (Ord t, HasDelta t) => [(t,S.ByteString,Edge)] -> t -> t -> S.ByteString -> [(t,InEvent)]
edges2durations tes minTime maxTime commonTrack =
[(t2, InValue commonTrack $ toSeconds (t2 `sub` t1) (undefined::t))
| (track, LongEvent (t1,True) (t2,True) _) <- edges2events tes minTime maxTime]
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
getTrack s = M.findWithDefault (minTime, 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
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,True) (t,True) 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,True) (t,True) st)] >> killTrack s
n -> putTrack s (t0, max 0 (n-1), st)
flush = RWS.get >>= mapM_ (\(s, (t0,_,st)) -> RWS.tell [(s, LongEvent (t0,True) (maxTime,False) 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
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 + 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 $ \(area, start, nopen, npulse) -> (area, t, nopen, npulse+1)
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,_):_)
| t<t1 = error "Times are not in ascending order"
| True = let (bin,rest) = span ((<t2).fst) tvs
in (map snd bin : values2timeBins (t2:ts) rest)
byTimeBins :: (Ord t, HasDelta t, Ord a) => ([a] -> b) -> Delta t -> t -> [(t,a)] -> [(t, b)]
byTimeBins f binSize t0 tvs = times `zip` map f (values2timeBins times tvs)
where times = iterate (add binSize) t0
getQuantiles :: (Ord a) => [Double] -> [a] -> [a]
getQuantiles qs = \xs -> quantiles' (sort xs)
where
qs' = sort qs
quantiles' [] = []
quantiles' xs = index (0:ns++[n-1]) 0 xs
where
n = length xs
ns = map (floor . (*(fromIntegral n-1))) qs'
index _ _ [] = []
index [] _ _ = []
index [i] j (x:xs)
| i<j = []
| i==j = [x]
| True = index [i] (j+1) xs
index (i:i':is) j (x:xs)
| i<j = index (i':is) j (x:xs)
| i>j = index (i:i':is) (j+1) xs
| i==i' = x:index (i':is) j (x:xs)
| True = x:index (i':is) (j+1) xs
values2binFreqs :: (Ord a) => [a] -> [a] -> [Double]
values2binFreqs bins xs = map toFreq $ values2binHist bins xs
where
n = length xs
toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n)
values2binHist bins xs = values2binHist' bins $ sort xs
where
values2binHist' [] xs = [length xs]
values2binHist' (a:as) xs = length xs0 : values2binHist' as xs'
where (xs0,xs') = span (<a) xs
atoms2hist :: (Ord a) => [a] -> [a] -> [Int]
atoms2hist as xs = map (maybe 0 id . (`M.lookup` m)) as
where
m = foldl' insert M.empty xs
insert m a = M.alter (Just . maybe 1 inc) a m
inc n = n `seq` (n+1)
atoms2freqs :: (Ord a) => [a] -> [a] -> [Double]
atoms2freqs as xs = map toFreq (atoms2hist as xs)
where
n = length xs
toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n)
zoom :: (Ord 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)
showHelp = mapM_ putStrLn [ "",
"tplot - a tool for drawing timing diagrams.",
" See http://www.haskell.org/haskellwiki/Timeplot",
#ifdef HAVE_GTK
"Usage: tplot [-o OFILE] [-of {png|pdf|ps|svg|x}] [-or 640x480]",
" -if IFILE [-tf TF] ",
" [{+|-}k Pat1 Kind1 {+|-}k Pat2 Kind2 ...] [{+|-}dk KindN]",
" [-fromTime TIME] [-toTime TIME] [-baseTime TIME]",
" -o OFILE - output file (required if -of is not x)",
" -of - output format (x means draw result in a window, default:",
" extension of -o)",
#else
"Usage: tplot [-o OFILE] [-of {png|pdf|ps|svg}] [-or 640x480]",
" -if IFILE [-tf TF] ",
" [{+|-}k Pat1 Kind1 {+|-}k Pat2 Kind2 ...] [{+|-}dk KindN]",
" [-fromTime TIME] [-toTime TIME] [-baseTime TIME]",
" -o OFILE - output file",
" -of - output format (default: extension of -o)",
#endif
" -or - output resolution (default 640x480)",
" -if IFILE - input file; '-' means 'read from stdin'",
" -tf TF - time format: -tf 'date PATTERN' means that times are dates in the format",
" specified by PATTERN - see http://linux.die.net/man/3/strptime, ",
" for example, -tf 'date [%Y-%m-%d %H:%M:%S]' parses dates like ",
" '[2009-10-20 16:52:43]'.",
" We also support %OS for fractional seconds (i.e. %OS will",
" parse 12.4039 or 12,4039) and %^[+-][N]s for ten-powers ",
" of seconds since epoch, for example %^-3s is ms since epoch.",
" Default: 'date %Y-%m-%d %H:%M:%OS'",
" {+|-}dk - set default diagram kind",
" {+|-}k P K - set diagram kind for tracks matching regex P (in the format",
" of regex-tdfa, which is at least POSIX-compliant and",
" supports some GNU extensions) to K",
" EXPLANATION:",
" -k clauses are matched till first success, +k are all",
" matched: a track is drawn acc. to all matching +k, to +dk",
" AND ALSO to the first matching -k, or -dk if none of -k",
" match",
" -fromTime - filter records whose time is >= this time",
" (formatted according to -tf)",
" -toTime - filter records whose time is < this time",
" (formatted according to -tf)",
" -baseTime - display time difference with this value instead of absolute time",
" (formatted according to -tf)",
" -zoomMode M- whether -fromTime and -toTime filter the input or the output:",
" zooming input (dropping events outside interval) may be faster,",
" but zooming output will be more accurate for history-dependent",
" graphs like activity graphs. M is 'input' or 'output'.",
"",
"Input format: lines of the following form:",
"1234 >A - at time 1234, activity A has begun",
"1234 <A - at time 1234, activity A has ended",
"1234 !B - at time 1234, pulse event B has occured",
"1234 !B TEXT - at time 1234, pulse event B has occured with label TEXT",
"1234 @B COLOR - at time 1234, the status of B became such that it is",
" appropriate to draw it with color COLOR :)",
"1234 =C VAL - at time 1234, parameter C had numeric value VAL (for example,",
" HTTP response time)",
"1234 =D `EVENT - at time 1234, event EVENT occured in process D (for",
" example, HTTP response code)",
"It is assumed that many events of the same kind may occur at once.",
"Diagram kinds:",
" 'none' - do not plot this track",
" 'event' is for event diagrams: activities are drawn like --[===]--- ,",
" pulse events like --|-- with a label over '|'",
" 'duration XXXX' - plot any kind of diagram over the *durations* of events",
" on a track (delimited by > ... <), for example 'duration quantile",
" 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. 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 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'.",
" Explanation: if you specify -k REGEX 'within[.] SOMETHING', timeplot will",
" take all tracks matching REGEX, split each track around the first '.', giving",
" a 'supertrack' and 'subtrack' (e.g. customer.John -> customer, John), ",
" group the events by supertrack and for each supertrack draw a graphical track",
" using the plot type SOMETHING. It's up to SOMETHING to do something with these",
" events, e.g. 'lines' will simply draw several line plots, one per subtrack.",
" '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 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.",
" 'apercent N B' is for activity percentages of a basis: like 'acount N',",
" but instead of X you get 100*X/B",
" '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",
" 'hist N [TYPE]' is for event count histograms: a histogram of type TYPE",
" (stacked or clustered, default clustered) is drawn for each time bin",
" of size N, about the *counts* of various ` events",
" 'quantile N q1,q2,..' (example: quantile 100 0.25,0.5,0.75) - a bar chart",
" of corresponding quantiles in time bins of size N",
" 'binf N v1,v2,..' (example: binf 100 1,2,5,10) - a histogram of frequency",
" of values falling into bins min..v1, v1..v2, .., v2..max in time bins",
" of size N",
" '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. 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.",
" 'dots ALPHA' - a simple dot plot of numeric values. When used in 'within', ",
" 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.",
" 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."
]
main = do
args <- getArgs
mainWithArgs args
mainWithArgs args = do
when (null args || args == ["--help"]) $ showHelp >> exitSuccess
let !conf = readConf args
let render = case (outFormat conf) of {
PNG -> \c w h f -> const () `fmap` renderableToPNGFile c w h f;
PDF -> renderableToPDFFile ;
PS -> renderableToPSFile ;
SVG -> renderableToSVGFile ;
#ifdef HAVE_GTK
Window -> \c w h f -> renderableToWindow c w h
#endif
}
case conf of
ConcreteConf {
parseTime=parseTime, inFile=inFile, chartKindF=chartKindF,
outFile=outFile, outResolution=outResolution,
fromTime=fromTime, toTime=toTime, transformLabel=transformLabel, zoomMode=zoomMode} -> do
source <- readSource parseTime inFile
let source' = case zoomMode of {
ZoomInput -> zoom source fromTime toTime ;
ZoomOutput -> source
}
let chart = makeChart chartKindF source' fromTime toTime zoomMode transformLabel
let (w,h) = outResolution
render chart w h outFile