criterion-compare (empty) → 0.1.0.0
raw patch · 10 files changed
+392/−0 lines, 10 filesdep +Chartdep +Chart-diagramsdep +basesetup-changed
Dependencies added: Chart, Chart-diagrams, base, bytestring, cassava, clay, colour, containers, data-default, filepath, lens, lucid, optparse-applicative, text, vector
Files
- ChangeLog.md +4/−0
- LICENSE +30/−0
- README.md +15/−0
- Setup.hs +2/−0
- criterion-compare.cabal +40/−0
- src/CriterionCompare.hs +156/−0
- src/CsvParse.hs +44/−0
- src/Plot.hs +59/−0
- src/Style.hs +24/−0
- src/Types.hs +18/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog + + +## 0.1 Initial hackage release
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,15 @@+# Criterion-compare + +A tool for quick comparisons between different criterion runs via their csv files. + +Use like this: +``` +$ criterion-compare <run1.csv> <run2.csv> +``` + +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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ criterion-compare.cabal view
@@ -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 <ben@well-typed.com>+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
+ src/CriterionCompare.hs view
@@ -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\"]});"
+ src/CsvParse.hs view
@@ -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
+ src/Plot.hs view
@@ -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
+ src/Style.hs view
@@ -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))
+ src/Types.hs view
@@ -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)