diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009, Eugene Kirpichov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Tools/TimePlot.hs b/Tools/TimePlot.hs new file mode 100644 --- /dev/null +++ b/Tools/TimePlot.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, GADTs #-} +module Main where + +import Control.Monad +import Control.Arrow +import Data.List +import Data.Maybe +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lex.Lazy.Double + +import Text.Regex.PCRE +import Text.Regex.PCRE.ByteString + +import Debug.Trace + +import System +import System.Exit +import System.Console.GetOpt + +import Data.Time hiding (parseTime) +import Data.Time.Parse + +import Data.Accessor + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Graphics.Rendering.Chart.Grid +import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Event + +import Data.Colour +import Data.Colour.Names + + +data Edge = Rise | Fall | Pulse deriving (Eq,Show) + +data InEvent = InEdge Edge + | InValue Double + | InAtom S.ByteString + +data OutFormat = PNG | PDF | PS | SVG | Window + +class HasDelta t where + type Delta t :: * + add :: Delta t -> t -> t + +instance HasDelta Double where + type Delta Double = Double + add d t = t + d + +instance HasDelta LocalTime where + type Delta LocalTime = NominalDiffTime + add d t = utcToLocalTime utc (addUTCTime d (localTimeToUTC utc t)) + +instance Read NominalDiffTime where + readsPrec n s = [(fromIntegral i, s') | (i,s') <- readsPrec n s] + +data (Ord t, HasDelta t) => ChartKind t = KindEvent + | KindHistogram { binSize :: Delta t } + | KindQuantile { binSize :: Delta t, quantiles :: [Double] } + | KindBinFreq { binSize :: Delta t, delims :: [Double] } + | KindBinCount { binSize :: Delta t, delims :: [Double] } + | KindFreq { binSize :: Delta t, style :: PlotBarsStyle } + | KindCount { binSize :: Delta t, style :: PlotBarsStyle } + | KindValue + +data Conf = forall t . (Ord t, HasDelta t, Read (Delta t), PlotValue t) => + Conf { + inFile :: FilePath, + parseTime :: B.ByteString -> Maybe (t, B.ByteString), + chartKindF :: S.ByteString -> ChartKind t, + + outFile :: FilePath, + outFormat :: OutFormat, + outResolution :: (Int,Int) + } + +readConf :: [String] -> Conf +readConf args = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%S")) of + ["num"] -> readConf' (fmap (int2double *** id) . B.readInt) + "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' parseTime = Conf {inFile=inFile, outFile=outFile, outFormat=outFormat, outResolution=outRes, + chartKindF=chartKindF, parseTime=parseTime} + where + inFile = single "input file" "-if" (error "No input file (-if) specified") + outFile = single "output file" "-o" (error "No output file (-of) specified") + outFormat = maybe PNG id $ lookup (single "output format" "-of" (name2format outFile)) $ + [("png",PNG), ("pdf",PDF), ("ps",PS), ("svg",SVG), ("x",Window)] + 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) + chartKindF = kindByRegex [((=~regex), parseKind (words kind)) | [regex,kind] <- getArg "-k" 2 args] + where + kindByRegex rks s = case [k | (p,k) <- rks, p s] of + k:_ -> k + _ -> defaultKind + + parseKind ["hist", n ] = KindHistogram {binSize=read n} + parseKind ["freq", n ] = KindFreq {binSize=read n,style=BarsClustered} + parseKind ["freq", n,s] = KindFreq {binSize=read n,style=parseStyle s} + parseKind ["count", n ] = KindCount {binSize=read n,style=BarsClustered} + parseKind ["count", n,s] = KindCount {binSize=read n,style=parseStyle s} + parseKind ["event" ] = KindEvent + parseKind ["quantile",b,q] = KindQuantile {binSize=read b, quantiles=read ("["++q++"]")} + parseKind ["binf", b,q] = KindBinFreq {binSize=read b, delims =read ("["++q++"]")} + parseKind ["binc", b,q] = KindBinCount {binSize=read b, delims =read ("["++q++"]")} + parseKind ["value" ] = KindValue + parseKind ws = error ("Unknown diagram kind" ++ unwords ws) + + defaultKind = parseKind $ words $ single "default kind" "-dk" "event" + + parseStyle "stacked" = BarsStacked + parseStyle "clustered" = BarsClustered + + +-- 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 :: (B.ByteString -> Maybe (t,B.ByteString)) -> FilePath -> IO [(t, S.ByteString, InEvent)] +readSource readTime f = (justs . map parseLine . blines) `fmap` (if f=="-" then B.getContents else B.readFile f) + where + justs xs = [x | Just x <- xs] + blines = B.split '\n' + strict = S.concat . B.toChunks + parseLine s = do + (t, s') <- readTime s + (_, s'') <- B.uncons s' + (c,rest) <- B.uncons s'' + case c of + '>' -> return (t, strict rest, InEdge Rise ) + '<' -> return (t, strict rest, InEdge Fall ) + '!' -> return (t, strict rest, InEdge Pulse) + '=' -> 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, strict track, InAtom (strict $ B.tail val)) + _ -> do + (v,_ ) <- readDouble val + return (t, strict track, InValue v) + _ -> Nothing + +makeChart :: forall t . (HasDelta t, PlotValue t) => + (S.ByteString -> ChartKind t) -> [(t, S.ByteString, InEvent)] -> Renderable () +makeChart chartKindF [] = emptyRenderable +makeChart chartKindF events@((t0,_,_):_) = renderLayout1sStacked plots + where + track2events = reverse `fmap` foldl insert M.empty [(s, (t, e)) | (t, s, e) <- events] + where insert m (s, r) = M.alter (Just . maybe [r] (r:)) s m + + plots = [ plotTrack k es | (k, es) <- M.toList track2events] + + timeBounds = (head times, last times) + times = sort $ [t | tes <- M.elems track2events, (t,_)<- tes] + commonTimeAxis = autoAxis times + + plotTrack name es = case (chartKindF name) of + KindHistogram bs -> withAnyOrdinate $ plotTrackHistogram name es bs + KindFreq bs k -> withAnyOrdinate $ plotTrackFreq name es bs k + KindCount bs k -> withAnyOrdinate $ plotTrackCount 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 + KindBinCount bs vs -> withAnyOrdinate $ plotTrackBinCounts name es vs bs + KindValue -> withAnyOrdinate $ plotTrackValue name es + + edges es = [(t,e) | (t,InEdge e) <- es] + values es = [(t,v) | (t,InValue v) <- es] + atoms es = [(t,a) | (t,InAtom a) <- es] + + lag xs = xs `zip` tail xs + + ourPlotBars :: (BarsPlotValue a) => PlotBars t a + ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 $ + plot_bars_style ^= BarsStacked $ + plot_bars_alignment ^= BarsLeft $ + defaultPlotBars + + plotTrackHistogram name es bs = layoutWithTitle (plotBars plot) name + where plot = plot_bars_values ^= barsData $ ourPlotBars + barsData = [(t,[n]) | ((t,_),n) <- edges2bins bs t0 (edges es)] + + plotTrackFreq = plotTrackAtoms atoms2freqs + plotTrackCount = plotTrackAtoms atoms2counts + + plotTrackAtoms f name es bs k = layoutWithTitle (plotBars plot) name + where plot = plot_bars_style ^= k $ + plot_bars_values ^= vals $ + plot_bars_item_styles ^= itemStyles $ + plot_bars_titles ^= "":map show vs $ + ourPlotBars + itemStyles = none:cycle [(solidFillStyle (opaque c), Nothing) + | c <- [green,blue,yellow,red,orange, + brown,grey,purple,violet,lightblue]] + vals = byTimeBins ((0:).f vs) bs t0 as + as = atoms es + vs = M.keys $ M.fromList $ [(a,()) | (_,a) <- as] + + plotTrackEvent name es = layoutWithTitle (toPlot plot) name + where plot = plot_event_data ^= edges2events (edges es) $ defaultPlotEvent + + plotTrackQuantile name es qs bs = layoutWithTitle (plotBars plot) name + where plot = plot_bars_values ^= toBars (byTimeBins (getQuantiles qs) bs t0 (values es)) $ + plot_bars_item_styles ^= quantileStyles $ + plot_bars_titles ^= quantileTitles $ + ourPlotBars + quantileStyles = none:[(solidFillStyle (clr i n), + Just $ solidLine 1 (opaque black)) | i <- [0..n+1]] + quantileTitles = [""]++[show p1++".."++show p2++"%" | (p1,p2) <- lag percents ] + where percents = map (floor . (*100)) $ [0]++qs++[1] + n = length qs + (minClr,maxClr) = (green,red) + clr 0 n = opaque minClr + clr x n | x==n+1 = opaque maxClr + clr i n = (maxClr `withOpacity` o) `over` (minClr `withOpacity` (1-o)) + where o = qs!!(i-1) + + binTitles vs = [low]++[show v1++".."++show v2 | (v1,v2) <- lag vs]++[high] + where + low = "<"++show (head vs) + high = ">"++show (last vs) + + binColor n i = (maxClr `withOpacity` o) `over` (minClr `withOpacity` (1-o)) + where + (minClr,maxClr) = (green,red) + o = fromIntegral i / fromIntegral (n+1) + + plotTrackBinFreqs name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n) + where + vals = byTimeBins ((0:).values2binFreqs vs) bs t0 (values es) + n = length vs + plotTrackBinCounts name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n) + where + vals = byTimeBins ((0:).values2binCounts vs) bs t0 (values es) + n = length vs + + plotTrackBars :: (BarsPlotValue a) => [(t,[a])] -> [String] -> S.ByteString -> (Int -> AlphaColour Double) -> Layout1 t a + plotTrackBars values titles name clr = layoutWithTitle (plotBars plot) name + where plot = plot_bars_values ^= values $ + plot_bars_item_styles ^= binStyles $ + plot_bars_titles ^= "":titles $ + ourPlotBars + binStyles = none:[(solidFillStyle (clr i), Just $ solidLine 1 (opaque black)) + | (i,_) <- [0..]`zip`titles] + + none = (solidFillStyle transparent, Nothing) + toBars tvs = [(t,diffs vs) | (t,vs) <- tvs] + diffs xs = zipWith (-) xs (0:xs) + + plotTrackValue name es = layoutWithTitle (toPlot plot) name + where plot = plot_lines_values ^= [values es] $ defaultPlotLines + + layoutWithTitle plot name = + layout1_title ^= "" $ + layout1_plots ^= [Left plot] $ + layout1_bottom_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $ + layout1_top_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $ + layout1_left_axis .> laxis_title ^= S.unpack name $ + layout1_margin ^= 0 $ + defaultLayout1 + +edges2events :: (Ord t) => [(t,Edge)] -> [Event t ()] +edges2events tes = longs `merge` pulses + where + merge [] ps = ps + merge ls [] = ls + merge (l@(LongEvent t1 t2 _):ls) (p@(PulseEvent t _):ps) + | t1 Delta t -> t -> [(t,Edge)] -> [((t,t), Int)] +edges2bins binSize t0 es = gather 0 0 0 es $ iterate (add binSize) t0 + where + gather :: (Ord t) => Int -> Int -> Int -> [(t,Edge)] -> [t] -> [((t,t), Int)] + gather 0 _ _ [] (t1:t2:ts) = [] + gather n _ _ [] (t1:t2:ts) = [((t1,t2),n)] + gather nmax nopen npulse ((t,e):tes) (t1:t2:ts) + | t=t2 = ((t1,t2),nmax):gather nopen nopen 0 ((t,e):tes) (t2:ts) + gather nmax nopen npulse ((t,Rise ):tes) (t1:t2:ts) + = gather (nmax `max` (nopen+npulse+1)) (nopen+1) npulse tes (t1:t2:ts) + gather nmax nopen npulse ((t,Fall ):tes) (t1:t2:ts) + = gather nmax (nopen-1) npulse tes (t1:t2:ts) + gather nmax nopen npulse ((t,Pulse):tes) (t1:t2:ts) + = gather (nmax `max` (nopen+npulse+1)) nopen (npulse+1) tes (t1:t2:ts) + +values2timeBins :: (Ord t) => [t] -> [(t,a)] -> [[a]] +values2timeBins (t1:t2:ts) [] = [] +values2timeBins (t1:t2:ts) tvs@((t,_):_) + | t ([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) + | ij = 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 $ values2binCounts bins xs + where + n = length xs + toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n) +values2binCounts bins xs = values2binCounts' bins $ sort xs + where + values2binCounts' [] xs = [length xs] + values2binCounts' (a:as) xs = length xs0 : values2binCounts' as xs' + where (xs0,xs') = span ( [a] -> [a] -> [Int] +atoms2counts 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 (atoms2counts as xs) + where + n = length xs + toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n) + +showHelp = mapM_ putStrLn [ "", + "tplot - a tool for drawing timing diagrams. See http://www.haskell.org/haskellwiki/Timeplot", + "Usage: tplot [-o OFILE] [-of {png|pdf|ps|svg|x}] [-or 640x480] -if IFILE [-tf TF] ", + " [-k Pat1 Kind1 -k Pat2 Kind2 ...] [-dk KindN]", + " -o OFILE - output file (required if -of is not x)", + " -of - output format (x means draw result in a window, default: extension of -o)", + " -or - output resolution (default 640x480)", + " -if IFILE - input file; '-' means 'read from stdin'", + " -tf TF - time format: 'num' means that times are integer numbers less than 2^31", + " (for instance, line numbers); 'date PATTERN' means that times are dates", + " in the format specified by PATTERN - see http://linux.die.net/man/3/strptime,", + " for example, [%Y-%m-%d %H:%M:%S] parses dates like [2009-10-20 16:52:43]. ", + " Default: 'date %Y-%m-%d %H:%M:%S'", + " -k P K - set diagram kind for tracks matching pattern P to K ", + " (-k clauses are matched till first success)", + " -dk - set default diagram kind", + "", + "Input format: lines of the following form:", + "1234 >A - at time 1234, during event A has begun", + "1234 > exitSuccess + let conf = readConf args + let render = case (outFormat conf) of { + PNG -> renderableToPNGFile ; + PDF -> renderableToPDFFile ; + PS -> renderableToPSFile ; + SVG -> renderableToSVGFile ; + Window -> \c w h f -> renderableToWindow c w h + } + case conf of + Conf{parseTime=parseTime, inFile=inFile, chartKindF=chartKindF, outFile=outFile, outResolution=outResolution} -> do + source <- readSource parseTime inFile + let chart = makeChart chartKindF source + let (w,h) = outResolution + render chart w h outFile diff --git a/timeplot.cabal b/timeplot.cabal new file mode 100644 --- /dev/null +++ b/timeplot.cabal @@ -0,0 +1,33 @@ +Name: timeplot +Version: 0.1 +License: BSD3 +License-file: LICENSE +Copyright: Eugene Kirpichov, 2009 +Author: Eugene Kirpichov +Maintainer: Eugene Kirpichov +Synopsis: A tool for visualizing time series from log files. +Description: A tool for visualizing time series from log files. + Reads an input file with events in different "tracks" and draws a diagram for each track, + where a diagram may be one of 8 types. See --help for help and haskell.org/haskellwiki/Timeplot + for a bigger description, examples and a tutorial. +Category: Graphics +Cabal-Version: >= 1.6 +Build-Type: Simple + +Source-repository head + type: darcs + location: http://patch-tag.com/r/jkff/timeplot + +flag splitbase + description: Choose the new smaller, split-up base package. + +executable tplot + if flag(splitbase) + Build-Depends: base >= 3 && < 4 + else + Build-Depends: base < 3 + + Build-Depends: Chart >= 0.12, cairo, bytestring, bytestring-lexing, strptime, time, + containers, colour, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3, + haskell98, regex-pcre + Main-Is: Tools/TimePlot.hs