timeplot 1.0.0 → 1.0.1
raw patch · 8 files changed
+861/−4 lines, 8 filesdep +hashabledep +hashmap
Dependencies added: hashable, hashmap
Files
- Tools/TimePlot.hs +3/−2
- Tools/TimePlot/Conf.hs +162/−0
- Tools/TimePlot/Incremental.hs +56/−0
- Tools/TimePlot/Plots.hs +364/−0
- Tools/TimePlot/Render.hs +81/−0
- Tools/TimePlot/Source.hs +48/−0
- Tools/TimePlot/Types.hs +142/−0
- timeplot.cabal +5/−2
Tools/TimePlot.hs view
@@ -65,9 +65,10 @@ -- Pass 2 events' <- readEvents- let eventsToTracks = map (\(t,e) -> (map fst $ i2oTracks (evt_track e), (t,e))) events'+ let eventsToTracks = [(outTrack, (t,e)) | (t,e) <- events', (outTrack,_) <- i2oTracks (evt_track e)] - let plots = I.runStreamSummary (I.byKey (\track -> initGen (outTracks M.! track) (S.unpack track) minTime maxTime)) eventsToTracks+ let initPlot track = initGen (outTracks M.! track) (S.unpack track) minTime maxTime+ let plots = I.runStreamSummary (I.byKey initPlot) eventsToTracks -- Render return $ renderLayout1sStacked $ map (dataToPlot commonTimeAxis) (M.elems plots)
+ Tools/TimePlot/Conf.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-} +module Tools.TimePlot.Conf ( + ConcreteConf(..), + Conf, + readConf +) where + +import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString +import Data.Time hiding (parseTime) +import Data.Time.Parse +import Data.List +import Graphics.Rendering.Chart +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as B + +import Unsafe.Coerce + +import Tools.TimePlot.Types + +data ConcreteConf t = + ConcreteConf { + inFile :: !FilePath, + parseTime :: !(B.ByteString -> Maybe (t, B.ByteString)), + chartKindF :: !(S.ByteString -> [ChartKind t]), + + fromTime :: !(Maybe t), + toTime :: !(Maybe t), + transformLabel :: !(t -> String -> String), + + outFile :: !FilePath, + outFormat :: !OutFormat, + outResolution :: !(Int,Int) + } + +type Conf = ConcreteConf UTCTime + +data KindChoiceOperator = Cut | Accumulate + +readConf :: [String] -> Conf +readConf args = readConf' parseTime + where + pattern = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%OS")) of + "date":f -> B.pack (unwords f) + _ -> error "Unrecognized time format (-tf)" + parseTime = localToUTC . strptime pattern + localToUTC Nothing = Nothing + localToUTC (Just (t,s)) = Just (localToUTC' t, s) + localToUTC' (LocalTime day (TimeOfDay h m s)) = UTCTime day daytime + where + daytime = unsafeCoerce (s + fromIntegral (60*m) + fromIntegral (3600*h)) + + 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 (UTCTime, B.ByteString)) -> ConcreteConf UTCTime + readConf' parseTime = ConcreteConf {inFile=inFile, outFile=outFile, outFormat=outFormat, outResolution=outRes, + chartKindF=chartKindF, parseTime=parseTime, fromTime=fromTime, toTime=toTime, + transformLabel=transformLabel} + 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" "") + + transformLabel t s = case baseTime of + Nothing -> s + Just bt -> showDelta t bt + + parseKind :: [String] -> ChartKind UTCTime + 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] +
+ Tools/TimePlot/Incremental.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs, BangPatterns #-} +module Tools.TimePlot.Incremental where + +import Data.Time +import qualified Data.List as L +import qualified Data.Map as M +import Control.Applicative + +data StreamSummary a r where + Summary :: { insert :: a -> StreamSummary a r, finalize :: r } -> StreamSummary a r + +instance Functor (StreamSummary a) where + fmap f (Summary insert res) = Summary (fmap f . insert) (f res) + +instance Applicative (StreamSummary a) where + pure r = Summary (\_ -> pure r) r + (!fs) <*> (!xs) = Summary (\a -> insert fs a <*> insert xs a) (finalize fs $ finalize xs) + +runStreamSummary :: StreamSummary a r -> [a] -> r +runStreamSummary !s [] = finalize s +runStreamSummary !s (a:as) = runStreamSummary (insert s a) as + +foldl' :: (a -> s -> s) -> s -> StreamSummary a s +foldl' insert init = go init + where + go !s = Summary (\a -> go (insert a s)) s + +filterMap :: (a -> Maybe b) -> StreamSummary b r -> StreamSummary a r +filterMap p !s@(Summary insert res) = Summary insert' res + where + insert' a = case p a of { Nothing -> filterMap p s ; Just b -> filterMap p (insert b) } + +mapInput :: (a -> b) -> StreamSummary b r -> StreamSummary a r +mapInput f (Summary insert res) = Summary (mapInput f . insert . f) res + +collect :: StreamSummary a [a] +collect = fmap reverse (foldl' (:) []) + +byTimeBins :: (Ord t) => [t] -> StreamSummary (t,[a]) r -> StreamSummary (t,a) r +byTimeBins ts s = fmap finalize' (foldl' insert' init') + where + init' = (ts, [], s) + insert' (t,a) (t1:t2:ts, curBin, !s) + | t < t1 = error "Times are not in ascending order" + | t < t2 = (t1:t2:ts, a:curBin, s) + | True = (t2:ts, [a], insert s (t1,reverse curBin)) + finalize' (t1:t2:ts, curBin, s) = finalize (insert s (t1,reverse curBin)) + +byKey :: (Ord k) => (k -> StreamSummary v r) -> StreamSummary (k,v) (M.Map k r) +byKey initByKey = fmap finalize' (foldl' insert' init') + where + init' = M.empty + insert' (k,v) m = case M.lookup k m of + Nothing -> M.insert k (initByKey k) m + Just !s -> M.insert k (insert s v) m + finalize' = fmap finalize
+ Tools/TimePlot/Plots.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE ParallelListComp, ScopedTypeVariables, BangPatterns, Rank2Types #-} +module Tools.TimePlot.Plots ( + initGen +) where + +import qualified Control.Monad.Trans.State.Strict as St +import Control.Arrow +import Control.Applicative +import Data.List (foldl', sort) +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as S + +import Data.Time + +import Data.Accessor + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Event + +import Data.Colour +import Data.Colour.Names + +import Tools.TimePlot.Types +import qualified Tools.TimePlot.Incremental as I + +type PlotGen = String -> UTCTime -> UTCTime -> I.StreamSummary (UTCTime, InEvent) PlotData + +initGen :: ChartKind UTCTime -> PlotGen +initGen (KindACount bs) = genActivity (\sns n -> n) bs +initGen (KindAPercent bs b) = genActivity (\sns n -> 100*n/b) bs +initGen (KindAFreq bs) = genActivity (\sns n -> if n == 0 then 0 else (n / sum (M.elems sns))) bs +initGen (KindFreq bs k) = genAtoms atoms2freqs bs k + where atoms2freqs as m = let n = length as in [fromIntegral (M.findWithDefault 0 a m)/fromIntegral n | a <- as] +initGen (KindHistogram bs k) = genAtoms atoms2hist bs k + where atoms2hist as m = [fromIntegral (M.findWithDefault 0 a m) | a <- as] +initGen KindEvent = genEvent +initGen (KindQuantile bs vs) = genQuantile bs vs +initGen (KindBinFreq bs vs) = genBinFreqs bs vs +initGen (KindBinHist bs vs) = genBinHist bs vs +initGen KindLines = genLines +initGen (KindDots alpha) = genDots alpha +initGen (KindSum bs ss) = genSum bs ss +initGen (KindCumSum ss) = genCumSum ss +initGen (KindDuration sk) = genDuration sk +initGen (KindWithin _ _) = \name -> error $ + "KindWithin should not be plotted (this is a bug): track " ++ show name +initGen KindNone = \name -> error $ + "KindNone should not be plotted (this is a bug): track " ++ show name +initGen KindUnspecified = \name -> error $ + "Kind not specified for track " ++ show name ++ " (have you misspelled -dk or any of -k arguments?)" + +-- Auxiliary functions for two common plot varieties + +plotTrackBars :: [(UTCTime,[Double])] -> [String] -> String -> [Colour Double] -> PlotData +plotTrackBars vals titles name colors = PlotBarsData { + plotName = name, + barsStyle = BarsStacked, + barsValues = vals, + barsStyles = [(solidFillStyle c, Nothing) + |(i,_) <- [0..]`zip`titles + | c <- transparent:map opaque colors], + barsTitles = titles + } + +plotLines :: String -> [(S.ByteString, [(UTCTime,Double)])] -> PlotData +plotLines name vss = PlotLinesData { + plotName = name, + linesData = [vs | (_, vs) <- vss], + linesStyles = [solidLine 1 color | _ <- vss | color <- map opaque colors], + linesTitles = [S.unpack subtrack | (subtrack, _) <- vss] + } + +------------------------------------------------------------- +-- Plot generators +------------------------------------------------------------- + +-- Wrappers for I.filterMap +values (t,InValue s v) = Just (t,s,v) +values _ = Nothing + +valuesDropTrack (t, InValue s v) = Just (t,v) +valuesDropTrack _ = Nothing + +atomsDropTrack (t, InAtom s a) = Just (t,a) +atomsDropTrack _ = Nothing + +edges (t,InEdge s e) = Just (t,s,e) +edges _ = Nothing + +------------------- Lines ---------------------- +genLines :: PlotGen +genLines name t0 t1 = I.filterMap values $ (data2plot . groupByTrack) <$> I.collect + where + data2plot vss = PlotLinesData { + plotName = name, + linesData = [vs | (_,vs) <- vss], + linesStyles = [solidLine 1 color | _ <- vss | color <- map opaque colors], + linesTitles = [S.unpack subtrack | (subtrack, _) <- vss] + } + +------------------- Dots ---------------------- +genDots :: Double -> PlotGen +genDots alpha name t0 t1 = I.filterMap values $ (data2plot . groupByTrack) <$> I.collect + where + data2plot vss = PlotDotsData { + plotName = name, + dotsData = [vs | (_,vs) <- vss], + dotsTitles = [S.unpack subtrack | (subtrack, _) <- vss], + dotsColors = if alpha == 1 then map opaque colors else map (`withOpacity` alpha) colors + } + +------------------- Binned graphs ---------------------- +summaryByFixedTimeBins t0 binSize = I.byTimeBins (iterate (add binSize) t0) + +-- Arguments of f will be: value bin boundaries, values in the current time bin +genByBins :: ([Double] -> [Double] -> [Double]) -> NominalDiffTime -> [Double] -> PlotGen +genByBins f timeBinSize valueBinBounds name t0 t1 = I.filterMap valuesDropTrack $ + summaryByFixedTimeBins t0 timeBinSize $ + I.mapInput (\(t,xs) -> (t, 0:f valueBinBounds xs)) $ + (\tfs -> plotTrackBars tfs binTitles name colors) <$> + I.collect + where + binTitles = [low]++[show v1++".."++show v2 + | v1 <- valueBinBounds + | v2 <- tail valueBinBounds]++ + [high] + where + low = "<"++show (head valueBinBounds) + high = ">"++show (last valueBinBounds) + +genBinHist :: NominalDiffTime -> [Double] -> PlotGen +genBinFreqs :: NominalDiffTime -> [Double] -> PlotGen +(genBinHist,genBinFreqs) = (genByBins values2binHist, genByBins values2binFreqs) + where + values2binHist bins = values2binHist' bins . sort + + values2binHist' [] xs = [fromIntegral (length xs)] + values2binHist' (a:as) xs = fromIntegral (length xs0) : values2binHist' as xs' + where (xs0,xs') = span (<a) xs + + values2binFreqs bins xs = map toFreq $ values2binHist bins xs + where + n = length xs + toFreq k = if n==0 then 0 else (k/fromIntegral n) + + +genQuantile :: NominalDiffTime -> [Double] -> PlotGen +genQuantile binSize qs name t0 t1 = I.filterMap valuesDropTrack $ + summaryByFixedTimeBins t0 binSize $ + I.mapInput (second (diffs . getQuantiles qs)) $ + fmap (\tqs -> plotTrackBars tqs quantileTitles name colors) $ + I.collect + where + quantileTitles = [""]++[show p1++".."++show p2++"%" | p1 <- percents | p2 <- tail percents] + percents = map (floor . (*100.0)) $ [0.0] ++ qs ++ [1.0] + diffs xs = zipWith (-) xs (0:xs) + +getQuantiles :: (Ord a) => [Double] -> [a] -> [a] +getQuantiles qs = quantiles' . sort + 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 + +genAtoms :: ([S.ByteString] -> M.Map S.ByteString Int -> [Double]) -> + NominalDiffTime -> PlotBarsStyle -> PlotGen +genAtoms f binSize k name t0 t1 = I.filterMap atomsDropTrack (h <$> unique (\(t,atom) -> atom) <*> fInBins) + where + fInBins :: I.StreamSummary (UTCTime, S.ByteString) [(UTCTime, M.Map S.ByteString Int)] + fInBins = summaryByFixedTimeBins t0 binSize $ I.mapInput (second counts) I.collect + counts = foldl' insert M.empty + where + insert m a = case M.lookup a m of + Nothing -> M.insert a 1 m + Just !n -> M.insert a (n+1) m + + h :: [S.ByteString] -> [(UTCTime, M.Map S.ByteString Int)] -> PlotData + h as tfs = plotTrackBars (map (second (f as)) tfs) (map show as) name colors + +unique :: (Ord a) => (x -> a) -> I.StreamSummary x [a] +unique f = M.keys <$> I.foldl' (\a -> M.insert (f a) ()) M.empty + +uniqueSubtracks :: I.StreamSummary (UTCTime,S.ByteString,a) [S.ByteString] +uniqueSubtracks = unique (\(t,s,a) -> s) + +genSum :: NominalDiffTime -> SumSubtrackStyle -> PlotGen +genSum binSize ss name t0 t1 = I.filterMap values (h <$> uniqueSubtracks <*> sumsInBins) + where + sumsInBins :: I.StreamSummary (UTCTime,S.ByteString,Double) [(UTCTime, M.Map S.ByteString Double)] + sumsInBins = I.mapInput (\(t,s,v) -> (t,(s,v))) $ + summaryByFixedTimeBins t0 binSize $ + I.mapInput (second (fromListWith' (+))) $ + I.collect + + h :: [S.ByteString] -> [(UTCTime, M.Map S.ByteString Double)] -> PlotData + h tracks binSums = plotLines name rows + where + rowsT' = case ss of + SumOverlayed -> map (second M.toList) binSums + SumStacked -> map (second stack) binSums + + stack :: M.Map S.ByteString Double -> [(S.ByteString, Double)] + stack ss = zip tracks (scanl1 (+) (map (\x -> M.findWithDefault 0 x ss) tracks)) + + rows :: [(S.ByteString, [(UTCTime, Double)])] + rows = M.toList $ fmap sort $ M.fromListWith (++) $ + [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m] + +genCumSum :: SumSubtrackStyle -> PlotGen +genCumSum ss name t0 t1 = I.filterMap values $ fmap (plotLines name . data2plot ss) I.collect + where + data2plot :: SumSubtrackStyle -> [(UTCTime, S.ByteString, Double)] -> [(S.ByteString, [(UTCTime, Double)])] + data2plot SumOverlayed es = [(s, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (t0, 0) vs) | (s, vs) <- groupByTrack es] + data2plot SumStacked es = rows + where + allTracks = Set.toList $ Set.fromList [track | (t, track, v) <- es] + + rows :: [(S.ByteString, [(UTCTime, Double)])] + rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs] + + rowsT :: [(UTCTime, [(S.ByteString, Double)])] + rowsT = (t0, zip allTracks (repeat 0)) : St.evalState (mapM addDataPoint es) M.empty + + addDataPoint (t, track, v) = do + St.modify (M.insertWith' (+) track v) + st <- St.get + let trackSums = map (\x -> M.findWithDefault 0 x st) allTracks + return (t, allTracks `zip` (scanl1 (+) trackSums)) + +genActivity :: (M.Map S.ByteString Double -> Double -> Double) -> NominalDiffTime -> PlotGen +genActivity f bs name t0 t1 = I.filterMap edges (h <$> uniqueSubtracks <*> binAreas) + where + binAreas :: I.StreamSummary (UTCTime,S.ByteString,Edge) [(UTCTime, M.Map S.ByteString Double)] + binAreas = fmap (map (\((t1,t2),m) -> (t1,m))) $ edges2binsSummary bs t0 t1 + + h tracks binAreas = (plotTrackBars barsData ("":map S.unpack tracks) name colors) { barsStyle = BarsStacked } + where + barsData = [(t, 0:map (f m . flip (M.findWithDefault 0) m) tracks) | (t,m) <- binAreas] + +edges2binsSummary :: (Ord t,HasDelta t,Show t) => + Delta t -> t -> t -> + I.StreamSummary (t,S.ByteString,Edge) [((t,t), M.Map S.ByteString Double)] +edges2binsSummary binSize tMin tMax = fmap flush (I.foldl' step (M.empty, iterate (add binSize) tMin, [])) + where + -- State: (m, ts, r) where: + -- * m = subtrack => state of current bin: + -- (area, starting time, level = rise-fall, num pulse events) + -- * ts = infinite list of time bin boundaries + -- * r = reversed list of results per bins + modState s t (!m, ts,r) f = (m', ts, r) + where + m' = M.insertWith' (\new !old -> f old) s (f (0,t,0,0)) m + + flushBin st@(m,t1:t2:ts,!r) = (m', t2:ts, r') + where + states = M.toList m + binSizeSec = deltaToSeconds t2 t1 + binValue (area,start,nopen,npulse) = + (fromIntegral npulse + area + deltaToSeconds t2 start*nopen) / binSizeSec + !r' = ((t1,t2), M.fromList [(s, binValue bin) | (s, bin) <- states]) : r + !m' = fmap (\(_,_,nopen,_) -> (0,t2,nopen,0)) m + + step ev@(t, s, e) st@(m, t1:t2:ts, r) + | t < t1 = error "Times are not in ascending order" + | t >= t2 = step ev (flushBin st) + | True = step'' ev st + + step'' ev@(t,s,e) st@(m, t1:t2:ts, r) = if (t < t1 || t >= t2) then error "Outside bin" else step' ev st + step' (t, s, SetTo _) st = st + step' (t, s, Pulse _) st = modState s t st $ + \(!area, !start, !nopen, !npulse) -> (area, t, nopen, npulse+1) + step' (t, s, Rise) st = modState s t st $ + \(!area, !start, !nopen, !npulse) -> (area+deltaToSeconds t start*nopen, t, nopen+1, npulse) + step' (t, s, Fall) st = modState s t st $ + \(!area, !start, !nopen, !npulse) -> (area+deltaToSeconds t start*nopen, t, nopen-1, npulse) + flush st@(m, t1:t2:ts, r) + | t2 <= tMax = flush (flushBin st) + | True = reverse r + +type StreamTransformer a b = forall r . I.StreamSummary b r -> I.StreamSummary a r + +edges2eventsSummary :: forall t . (Ord t) => + t -> t -> StreamTransformer (t,S.ByteString,Edge) (S.ByteString, Event t Status) +edges2eventsSummary t0 t1 s = flush <$> I.foldl' step (M.empty,s) + where + -- State: (m, sum) where + -- * m = subtrack => (event start, level = rise-fall, status) + -- * sum = summary of accumulated events so far + tellSummary e (ts,!sum) = (ts,I.insert sum e) + + getTrack s (!ts,sum) = M.findWithDefault (t0, 0, emptyStatus) s ts + putTrack s t (!ts,sum) = (M.insert s t ts, sum) + killTrack s (!ts,sum) = (M.delete s ts, sum) + trackCase s whenZero withNonzero st + | numActive == 0 = whenZero + | True = withNonzero t0 numActive status + where (t0, numActive, status) = getTrack s st + + emptyStatus = Status "" "" + + step (t,s,Pulse st) state = tellSummary (s, PulseEvent t st) state + step (t,s,SetTo st) state = trackCase s + (putTrack s (t, 1, st) state) + (\t0 !n st0 -> putTrack s (t,n,st) $ tellSummary (s, LongEvent (t0,True) (t,True) st0) state) + state + step (t,s,Rise) state = trackCase s + (putTrack s (t, 1, emptyStatus) state) + (\t0 !n st -> putTrack s (t, n+1, st) state) + state + step (t,s,Fall) state + | numActive == 1 = killTrack s $ tellSummary (s, LongEvent (t0,True) (t,True) st) state + | True = putTrack s (t0, max 0 (numActive-1), st) state + where + (t0, numActive, st) = getTrack s state + + flush (ts,sum) = I.finalize $ foldl' addEvent sum $ M.toList ts + where + addEvent sum (s,(t0,_,st)) = I.insert sum (s, LongEvent (t0,True) (t1,False) st) + +edges2durationsSummary :: forall t . (Ord t, HasDelta t) => + t -> t -> String -> StreamTransformer (t,S.ByteString,Edge) (t,InEvent) +edges2durationsSummary t0 t1 commonTrack = edges2eventsSummary t0 t1 . I.filterMap genDurations + where + genDurations (track, e) = case e of + LongEvent (t1,True) (t2,True) _ -> Just (t2, InValue commonTrackBS $ deltaToSeconds t2 t1) + _ -> Nothing + commonTrackBS = S.pack commonTrack + +genEvent :: PlotGen +genEvent name t0 t1 = I.filterMap edges $ + fmap (\evs -> PlotEventData { plotName = name, eventData = map snd evs }) $ + edges2eventsSummary t0 t1 I.collect +-- TODO Multiple tracks + +genDuration :: ChartKind UTCTime -> PlotGen +genDuration sk name t0 t1 = I.filterMap edges $ edges2durationsSummary t0 t1 name (initGen sk name t0 t1) + +fromListWith' f kvs = foldl' insert M.empty kvs + where + insert m (k,v) = case M.lookup k m of + Nothing -> M.insert k v m + Just !v' -> M.insert k (f v' v) m + +colors = cycle [green,blue,red,brown,yellow,orange,grey,purple,violet,lightblue] + +groupByTrack xs = M.toList $ sort `fmap` M.fromListWith (++) [(s, [(t,v)]) | (t,s,v) <- xs] +
+ Tools/TimePlot/Render.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE ParallelListComp #-} +module Tools.TimePlot.Render ( + dataToPlot +) where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Event +import Data.Time +import Data.Accessor +import Data.Colour +import Data.Colour.Names +import Data.Maybe + +import Tools.TimePlot.Types +import Tools.TimePlot.Plots + +instance PlotValue UTCTime where + toValue = toValue . utcToLocalTime utc + fromValue = localTimeToUTC utc . fromValue + autoAxis ts = ad' + where + ad :: AxisData LocalTime + ad = autoAxis (map (utcToLocalTime utc) ts) + ad' :: AxisData UTCTime + ad' = mapAxisData (utcToLocalTime utc) (localTimeToUTC utc) ad + +mapAxisData :: (a -> b) -> (b -> a) -> AxisData b -> AxisData a +mapAxisData f f' (AxisData vp pv ticks labels grid) = AxisData + (\range x -> vp range (f x)) + (\range v -> f' (pv range v)) + (map (\(x,t) -> (f' x, t)) ticks) + (map (map (\(x,lab) -> (f' x, lab))) labels) + (map f' grid) + +dataToPlot :: AxisData UTCTime -> PlotData -> AnyLayout1 UTCTime +dataToPlot commonTimeAxis p@PlotBarsData{} = withAnyOrdinate $ layoutWithTitle commonTimeAxis [plotBars plot] (plotName p) (length (barsTitles p) > 1) + where plot = plot_bars_values ^= barsValues p $ + plot_bars_item_styles ^= barsStyles p $ + plot_bars_titles ^= "":barsTitles p $ + ourPlotBars +dataToPlot commonTimeAxis p@PlotEventData{} = withAnyOrdinate $ layoutWithTitle commonTimeAxis [toPlot plot] (plotName p) False + where plot = plot_event_data ^= eventData p $ + plot_event_long_fillstyle ^= toFillStyle $ + plot_event_label ^= toLabel $ + defaultPlotEvent + toFillStyle s = solidFillStyle . opaque $ fromMaybe lightgray (readColourName (statusColor s)) + toLabel s = statusLabel s +dataToPlot commonTimeAxis p@PlotLinesData{} = withAnyOrdinate $ layoutWithTitle commonTimeAxis (map toPlot plots) (plotName p) (length (linesData p) > 1) + where plots = [plot_lines_values ^= [vs] $ + plot_lines_title ^= title $ + plot_lines_style ^= lineStyle $ + defaultPlotLines + | vs <- linesData p + | title <- linesTitles p + | lineStyle <- linesStyles p] +dataToPlot commonTimeAxis p@PlotDotsData{} = withAnyOrdinate $ layoutWithTitle commonTimeAxis (map toPlot plots) (plotName p) (length (dotsData p) > 1) + where plots = [plot_points_values ^= vs $ + plot_points_style ^= hollowCircles 4 1 color $ + plot_points_title ^= subtrack $ + defaultPlotPoints + | subtrack <- dotsTitles p + | color <- dotsColors p + | vs <- dotsData p] + +layoutWithTitle :: (PlotValue a) => AxisData UTCTime -> [Plot UTCTime a] -> String -> Bool -> Layout1 UTCTime a +layoutWithTitle commonTimeAxis 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 ^= name $ + layout1_margin ^= 0 $ + layout1_grid_last ^= True $ + defaultLayout1 + +ourPlotBars :: (BarsPlotValue a) => PlotBars UTCTime a +ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 0 $ + plot_bars_style ^= BarsStacked $ + plot_bars_alignment ^= BarsLeft $ + defaultPlotBars
+ Tools/TimePlot/Source.hs view
@@ -0,0 +1,48 @@+module Tools.TimePlot.Source ( + readSource +) where + +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lex.Lazy.Double +import Tools.TimePlot.Types + +readSource :: (Show t) => (B.ByteString -> Maybe (t,B.ByteString)) -> FilePath -> IO [(t, InEvent)] +readSource readTime f = (map parseLine . filter (not . B.null) . blines) `fmap` 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 +
+ Tools/TimePlot/Types.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP, TypeFamilies, BangPatterns #-} +module Tools.TimePlot.Types where + +import Data.Time hiding (parseTime) +import qualified Data.ByteString.Char8 as S +import Graphics.Rendering.Chart +import Data.Colour +import Data.Accessor +import Graphics.Rendering.Chart.Event + +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 + deltaToSeconds :: 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 + deltaToSeconds t2 t1 = t2 - t1 + fromSeconds d _ = d + showDelta a b = show (a - b) + +instance HasDelta UTCTime where + type Delta UTCTime = NominalDiffTime + add d t = addUTCTime d t + sub t2 t1 = diffUTCTime t2 t1 + toSeconds d _ = fromIntegral (truncate (1000000*d)) / 1000000 + deltaToSeconds t2 t1 = diffToSeconds t2 t1 + 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 + +{-# INLINE diffToSeconds #-} +diffToSeconds :: UTCTime -> UTCTime -> Double +diffToSeconds !t2 !t1 = 86400.0 * fromIntegral dd + fromRational (toRational (tod2-tod1))*1000.0 + where + (d1,d2,tod1,tod2) = (utctDay t1, utctDay t2, utctDayTime t1, utctDayTime t2) + dd = toModifiedJulianDay d2 - toModifiedJulianDay d1 + + +instance Read NominalDiffTime where + readsPrec n s = [(fromSeconds i (undefined::UTCTime), 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 + +instance Show CairoLineStyle where show _ = "<line>" +instance Show CairoFillStyle where show _ = "<fill>" +data PlotData = PlotBarsData + { + plotName :: String, + barsStyle :: PlotBarsStyle, + barsValues :: [ (UTCTime, [Double]) ], + barsStyles :: [(CairoFillStyle, Maybe CairoLineStyle)], + barsTitles :: [String] + } + | PlotEventData + { + plotName :: String, + eventData :: [Event UTCTime Status] + } + | PlotLinesData + { + plotName :: String, + linesData :: [[(UTCTime, Double)]], + linesStyles :: [CairoLineStyle], + linesTitles :: [String] + } + | PlotDotsData + { + plotName :: String, + dotsData :: [[(UTCTime, Double)]], + dotsColors :: [AlphaColour Double], + dotsTitles :: [String] + } + deriving (Show)
timeplot.cabal view
@@ -1,5 +1,5 @@ name: timeplot-version: 1.0.0+version: 1.0.1 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -23,6 +23,9 @@ executable tplot main-is: Tools/TimePlot.hs+ other-modules: Tools.TimePlot.Conf Tools.TimePlot.Incremental + Tools.TimePlot.Plots Tools.TimePlot.Render Tools.TimePlot.Source + Tools.TimePlot.Types buildable: True ghc-options: -rtsopts other-modules: Graphics.Rendering.Chart.Event@@ -30,4 +33,4 @@ bytestring-lexing -any, cairo -any, colour -any, containers -any, data-accessor ==0.2.*, data-accessor-template >=0.2.1.1 && <0.3, regex-tdfa -any, strptime >=0.1.7, time -any,- transformers -any+ transformers -any, hashmap -any, hashable -any