diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Changelog + + +## 0.1 Initial hackage release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Ben Gamari + +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. + + * Neither the name of Ben Gamari nor the names of other + contributors may 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Criterion-compare + +A tool for quick comparisons between different criterion runs via their csv files. + +Use like this: +``` +$ criterion-compare +``` + +Which will generate the files `comparison.html` and `comparison.svg`. + +### Attributions + +This tool was initially written by Ben Gamari (bgamari), extended by Brandon Simmons (jberryman) and most recently +updated by Andreas Klebinger (AndreasPK). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/criterion-compare.cabal b/criterion-compare.cabal new file mode 100644 --- /dev/null +++ b/criterion-compare.cabal @@ -0,0 +1,40 @@ +name: criterion-compare +version: 0.1.0.0 +synopsis: A simple tool for visualising differences in Criterion benchmark results +description: Create a html file containing a quick comparison of results for the input files. +homepage: http://github.com/AndreasPK/criterion-compare +license: BSD3 +license-file: LICENSE +author: Ben Gamari +maintainer: ben@well-typed.com, klebinger.andreas@gmx.at +copyright: (c) 2016 Ben Gamari +category: Development +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 + +executable criterion-compare + main-is: CriterionCompare.hs + other-modules: CsvParse, Plot, Style, Types + hs-source-dirs: src + other-extensions: GeneralizedNewtypeDeriving, RecordWildCards, OverloadedStrings, FlexibleContexts, TupleSections + default-language: Haskell2010 + build-depends: base >=4.9 && <= 4.13, + cassava >=0.5 && <0.6, + containers >=0.6 && <0.7, + Chart >=1.6 && < 1.10, + data-default >=0.5 && < 7.2, + lens >=4.13 && < 4.18, + colour >=2.3 && < 2.4, + text >=1.2 && < 1.3, + filepath >=1.4 && <1.5, + lucid >=2.9 && < 2.10, + Chart-diagrams >=1.6 && < 1.10, + optparse-applicative >=0.12 && < 0.16, + clay >=0.10 && < 0.14, + vector >=0.11 && < 0.13, + bytestring >=0.10 && < 0.11 + +source-repository head + type: git + location: https://github.com/AndreasPK/criterion-compare.git diff --git a/src/CriterionCompare.hs b/src/CriterionCompare.hs new file mode 100644 --- /dev/null +++ b/src/CriterionCompare.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Control.Applicative +import Control.Monad (forM_) +import Data.Maybe (fromMaybe) +import System.FilePath (takeFileName, dropExtension, (<.>)) +import Numeric +import Lucid +import Lucid.Base +import Graphics.Rendering.Chart (toRenderable) +import Graphics.Rendering.Chart.Backend.Diagrams (renderableToFile) +import Data.Default +import Options.Applicative hiding (style) + +import Style +import Plot +import CsvParse +import Types + +invert :: (Ord a, Ord b) => M.Map a (M.Map b v) -> M.Map b (M.Map a v) +invert runs = + M.unionsWith M.union [ M.singleton bench $ M.singleton run stats + | (run, results) <- M.assocs runs + , (bench, stats) <- M.assocs results ] + +toTable :: [(BenchName,Int)] -> M.Map BenchName (M.Map RunName (Either (Html ()) (Attribute,Double))) -> Html () +toTable orderOrig results = + table_ $ do + thead_ $ + tr_ $ do + th_ "Benchmark" + forM_ (M.keys $ head $ M.elems results) $ \(RunName runName) -> + th_ $ toHtml runName + + -- for list.js + tbody_ [class_ "list"] $ + forM_ (M.assocs results) $ \(bn@(BenchName benchName), runs) -> tr_ $ do + let o = fromMaybe maxBound $ lookup bn orderOrig + td_ [class_ "benchName"] $ toHtml benchName + forM_ (M.assocs runs) $ \(RunName runName, ec) -> do + let content = either id (\(cls,n) -> span_ [cls] $ toHtml $ showGFloat (Just 1) n "%") ec + td_ [class_ $ T.pack runName] content + let significance = sum $ map (either (const 0) (abs . snd)) $ M.elems runs + -- hidden tds to let us sort by original benchmark order: + td_ [class_ "orderOrig", style_ "display:none;"] (toHtml $ show o) + td_ [class_ "significance", style_ "display:none;"] + -- subtract as stupid hack to get reverse order on first click + (toHtml $ show (99999 - significance)) + -- TODO "largest regression", "largest improvement", etc. Then we + -- must add those names to the JS snippet at the bottom + +tabulateAbsolute :: M.Map BenchName (M.Map RunName Stats) + -> M.Map BenchName (M.Map RunName (Html ())) +tabulateAbsolute = fmap $ fmap cell + where + cell stats = + let mean = showGFloat (Just 2) (statsMean stats) "" + std = showString " ± " $ showGFloat (Just 2) (statsStd stats) "" + in td_ $ do + toHtml mean + span_ [class_ "stddev"] $ toHtml std + +tabulateRelative :: RunName -> M.Map BenchName (M.Map RunName Stats) + -> M.Map BenchName (M.Map RunName (Either (Html ()) (Attribute,Double))) +tabulateRelative refRun results = + M.mapWithKey (\bench -> M.mapWithKey (cell bench)) results + where + cell bench run stats + | run == refRun + = showAbs stats + | Just refStats <- M.lookup bench results >>= M.lookup refRun + = let rel = (statsMean stats - statsMean refStats) / statsMean refStats + cls = T.pack $ "stat-"++sign++show (abs n) + where sign = if rel > 0 then "p" else "n" + n = min 10 $ max (-10) $ round $ rel / 0.025 :: Int + -- in span_ [class_ cls] $ toHtml $ showGFloat (Just 1) (100*rel) "%" + in Right (class_ cls, 100*rel) + | otherwise + = showAbs stats + + showAbs stats = Left $ toHtml $ showGFloat (Just 2) (statsMean stats) "" + +data Options = Options { optRunNames :: [RunName] + , optOutput :: FilePath + , optRunPaths :: [FilePath] + } + +options :: Options.Applicative.Parser Options +options = + Options <$> many (option (RunName <$> str) $ short 'l' <> long "label" <> help "label") + <*> option str (short 'o' <> long "output" <> metavar "FILE" <> help "output file name" <> value "comparison") + <*> many (argument str $ metavar "FILE" <> help "CSV file name") + +addGeoMean :: [(RunName, M.Map BenchName Stats)] -> [(RunName, M.Map BenchName Stats)] +addGeoMean input + -- Inputs have different benchmarks - geoMean makes no sense then. + | not (all (== head benchNames) benchNames) = input + | otherwise = map (\(run,stats) -> (run,mean_stat stats)) input + + where + mean_stat stats = M.insert (BenchName "GeoMean (calculated)") + (Stats { statsMean = (gm stats/head_mean) + , statsMeanLB = 0, statsMeanUB = 0 + , statsStd = 0, statsStdLB = 0 + , statsStdUB = 0 }) + stats + head_mean = gm . snd . head $ input + + product = (M.foldl' (\total s -> statsMean s * total) 1.0) + entries m = fromIntegral $ M.size m :: Double + gm m = (product m) ** (1.0/entries m) :: Double + + benchNames = map (M.keys . snd) input :: [[BenchName]] + + + + + + +main :: IO () +main = do + Options{..} <- execParser $ info (helper <*> options) mempty + results <- sequence [ (name',) . M.fromList <$> readResults path + | (name, path) <- zip (map Just optRunNames ++ repeat Nothing) optRunPaths + , let name' = fromMaybe (RunName $ dropExtension $ takeFileName path) name + ] :: IO [(RunName, M.Map BenchName Stats)] + + let resultWithMean = addGeoMean results + + orderOrig <- zipWith (\i (nm,_)-> (nm,i)) [0..] <$> (readResults $ head optRunPaths) :: IO [(BenchName, Int)] + renderableToFile def (optOutput <.> "svg") $ toRenderable $ plot $ M.fromList resultWithMean + --let table = tabulateAbsolute $ invert $ M.unions results + let table = tabulateRelative (fst $ head resultWithMean) $ invert $ M.fromList resultWithMean + + renderToFile (optOutput <.> "html") $ doctypehtml_ $ do + head_ $ do + title_ "Criterion comparison" + meta_ [ charset_ "UTF-8" ] + style_ style + body_ $ + -- for list.js: + div_ [id_ "bench"] $ do + input_ [class_ "search", placeholder_ "Filter by name"] + span_ "Sort by: " + button_ [class_ "sort", makeAttribute "data-sort" "orderOrig"] "original order" + button_ [class_ "sort", makeAttribute "data-sort" "significance"] "significance" + button_ [class_ "sort", makeAttribute "data-sort" "benchName"] "name" + toTable orderOrig table + -- http://listjs.com : + script_ [ src_ "http://cdnjs.cloudflare.com/ajax/libs/list.js/1.5.0/list.min.js"] (""::T.Text) + script_ "new List(\"bench\", {valueNames: [\"orderOrig\", \"benchName\",\"significance\"]});" diff --git a/src/CsvParse.hs b/src/CsvParse.hs new file mode 100644 --- /dev/null +++ b/src/CsvParse.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module CsvParse (readResults) where + +import qualified Data.Map.Strict as M +import Control.Applicative +import Data.Csv +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.Char8 as BSL + +import Types + +data BenchResult = BenchResult { benchName :: BenchName + , benchStats :: Stats + } + +instance FromRecord BenchResult where + parseRecord v + | V.length v == 7 = + bench <$> v .! 0 + <*> v .! 1 + <*> v .! 2 + <*> v .! 3 + <*> v .! 4 + <*> v .! 5 + <*> v .! 6 + | otherwise = empty + where bench a b c d e f g = BenchResult a (Stats b c d e f g) + +readResults :: FilePath -> IO [(BenchName, Stats)] +readResults fname = do + mxs <- parseResults <$> BSL.readFile fname + case mxs of + Left err -> fail err + Right xs -> return $ map (\(BenchResult a b) -> (a, b)) $ V.toList xs + +parseResults :: BSL.ByteString -> Either String (V.Vector BenchResult) +parseResults = + decode NoHeader + . BSL.unlines + . filter (not . ("Name,Mean" `BSL.isPrefixOf`)) + . BSL.lines diff --git a/src/Plot.hs b/src/Plot.hs new file mode 100644 --- /dev/null +++ b/src/Plot.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RecordWildCards #-} + +module Plot where + +import qualified Data.Map as M + +import Graphics.Rendering.Chart +import Data.Default +import Data.List +import Control.Lens +import Types +import Data.Colour +import qualified Data.Colour.Names as N + +plot :: M.Map RunName (M.Map BenchName Stats) -> Layout PlotIndex Double +plot results = layout + where + idxs' :: [(PlotIndex, Maybe (BenchName, RunName))] + idxs' = addIndexes + $ intercalate (replicate 3 Nothing) + $ transpose + [ [ Just (benchName, runName) + | (benchName, _stats) <- M.assocs runs + ] + | (runName, runs) <- M.assocs results + ] + + idxs :: M.Map (RunName, BenchName) PlotIndex + idxs = M.unions [ M.singleton (runName, benchName) idx + | (idx, Just (benchName, runName)) <- idxs' + ] + + plotRun :: AlphaColour Double + -> (RunName, M.Map BenchName Stats) + -> PlotErrBars PlotIndex Double + plotRun color (runName, benchmarks) = + plot_errbars_title .~ getRunName runName + $ plot_errbars_line_style . line_color .~ color + $ plot_errbars_values .~ [ ErrPoint ex ey + | (benchName, Stats{..}) <- M.assocs benchmarks + , let Just idx = M.lookup (runName, benchName) idxs + , let ex = ErrValue idx idx idx + , let ey = ErrValue statsMeanLB statsMean statsMeanUB + ] + $ def + + colors :: [AlphaColour Double] + colors = map opaque $ cycle [N.red, N.blue, N.purple, N.yellow, N.brown, N.green, N.cyan] + + plots :: [Plot PlotIndex Double] + plots = map toPlot $ zipWith plotRun colors (M.assocs results) + + labels = map (\(BenchName name, idx) -> (idx, name)) $ M.assocs $ M.mapKeys snd idxs + + layout :: Layout PlotIndex Double + layout = layout_title .~ "Criterion comparison" + $ layout_plots .~ plots + $ layout_x_axis . laxis_override .~ (axis_labels .~ [labels]) + $ def diff --git a/src/Style.hs b/src/Style.hs new file mode 100644 --- /dev/null +++ b/src/Style.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +module Style (style) where + +import Control.Monad (forM_) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Clay hiding (round, style, min) + +style :: T.Text +style = TL.toStrict $ render style' + +style' :: Css +style' = do + ".stddev" ? do + fontSizeCustom xSmall + "td" ? do + paddingLeft (em 1) + paddingRight (em 1) + + forM_ [0..10] $ \n -> do + star # byClass (T.pack $ "stat-p"++show (round n)) ? do backgroundColor $ shade 0 n + star # byClass (T.pack $ "stat-n"++show (round n)) ? do backgroundColor $ shade 128 n + +shade h n = hsl h 60 (100 - (5*n)) diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Types where + +import Data.Csv + +-- | The name of a set of benchmark results from a single run. +newtype RunName = RunName {getRunName :: String} + deriving (Eq, Ord, Show, FromField) + +-- | The name of a benchmark +newtype BenchName = BenchName {getBenchName :: String} + deriving (Eq, Ord, Show, FromField) + +data Stats = Stats { statsMean, statsMeanLB, statsMeanUB :: Double + , statsStd, statsStdLB, statsStdUB :: Double + } + deriving (Show)