timeplot 0.3.14 → 1.0.0
raw patch · 2 files changed
+62/−697 lines, 2 files
Files
- Tools/TimePlot.hs +61/−696
- timeplot.cabal +1/−1
Tools/TimePlot.hs view
@@ -1,30 +1,16 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, ParallelListComp, CPP #-}+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, ParallelListComp, CPP, BangPatterns #-} 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 @@ -34,679 +20,57 @@ 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+import Tools.TimePlot.Types+import Tools.TimePlot.Conf+import Tools.TimePlot.Source+import Tools.TimePlot.Plots+import Tools.TimePlot.Render+import qualified Tools.TimePlot.Incremental as I -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)+-- Assume events are sorted.+-- Pass 1:+-- * Compute min/max times+-- * Compute unique track names+-- +-- Then map track names to plotters (track types).+-- +-- Pass 2:+-- * Generate plot data (one-pass multiplexed to tracks)+-- +makeChart :: (S.ByteString -> [ChartKind UTCTime]) -> + IO [(UTCTime, InEvent)] ->+ Maybe UTCTime -> Maybe UTCTime ->+ (UTCTime -> String -> String) -> + IO (Renderable ())+makeChart chartKindF readEvents minT maxT transformLabel = do+ events <- readEvents+ if null events+ then return emptyRenderable+ else do+ -- Pass 1: find out min/max time and final track names.+ let i2o t KindNone = []+ i2o t (KindWithin mapName sk) = [(mapName t, sk)]+ i2o t k = [(t, k)]+ let i2oTracks t = concatMap (i2o t) (chartKindF t)+ let t0 = fst (head events)+ let (minTime, maxTime, outTracks) = foldl' + (\(!mi,!ma,!ts) (t,e) -> (min t mi, max t ma, foldr (uncurry M.insert) ts (i2oTracks $ evt_track e))) + (t0, t0, M.empty) + events -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)+ let minOutTime = case minT of Just t -> t ; Nothing -> minTime+ let maxOutTime = case maxT of Just t -> t ; Nothing -> maxTime+ let transformLabels axis = axis { axis_labels_ = map (map (\(t, s) -> (t, transformLabel t s))) (axis_labels_ axis) }+ let commonTimeAxis = transformLabels $ autoAxis [minOutTime, maxOutTime]+ + -- Pass 2+ events' <- readEvents+ let eventsToTracks = map (\(t,e) -> (map fst $ i2oTracks (evt_track e), (t,e))) events' -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)+ let plots = I.runStreamSummary (I.byKey (\track -> initGen (outTracks M.! track) (S.unpack track) minTime maxTime)) eventsToTracks+ + -- Render+ return $ renderLayout1sStacked $ map (dataToPlot commonTimeAxis) (M.elems plots) showHelp = mapM_ putStrLn [ "", "tplot - a tool for drawing timing diagrams.",@@ -729,6 +93,10 @@ #endif " -or - output resolution (default 640x480)", " -if IFILE - input file; '-' means 'read from stdin'",+ " NOTE: for large datasets, use actual files, not stdin,",+ " as tplot can operate on them in streaming mode, which",+ " allows it to use a lot less memory and work on virtually",+ " unbounded datasets", " -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 ",@@ -752,10 +120,6 @@ " (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",@@ -857,12 +221,13 @@ 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+ fromTime=fromTime, toTime=toTime, transformLabel=transformLabel } -> do+ source <- case inFile of+ "-" -> do+ putStrLn "Warning: working in non-streaming mode (for very large datasets, supply input from a file)"+ events <- readSource parseTime inFile+ return (return events)+ _ -> return (readSource parseTime inFile)+ chart <- makeChart chartKindF source fromTime toTime transformLabel let (w,h) = outResolution render chart w h outFile
timeplot.cabal view
@@ -1,5 +1,5 @@ name: timeplot-version: 0.3.14+version: 1.0.0 cabal-version: >=1.6 build-type: Simple license: BSD3