{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module BenchGraph
( ComparisonStyle(..)
, Config(..)
, defaultConfig
, bgraph
) where
import Control.Arrow (second)
import Control.Monad (when)
import Control.Monad.Trans.State.Lazy (get, put)
import Data.Char (toUpper)
import Data.Function ((&), on)
import Data.List (nub, nubBy, transpose, findIndex, groupBy, (\\), group, sort)
import Data.Maybe (catMaybes, fromMaybe, maybe)
import Debug.Trace (trace)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import Text.CSV (CSV, parseCSVFromFile)
import Text.Read (readMaybe)
import Graphics.Rendering.Chart.Easy
import Graphics.Rendering.Chart.Backend.Diagrams
getRepeated :: Ord a => [a] -> [a]
getRepeated = map head . filter ((>1) . length) . group . sort
data ComparisonStyle =
CompareFull
| CompareDelta
deriving Eq
data Config = Config
{
outputDir :: FilePath
, chartTitle :: Maybe String
, classifyBenchmark :: String -> Maybe (String, String)
, sortBenchmarks :: [String] -> [String]
, sortBenchGroups :: [String] -> [String]
, setYScale :: Maybe (Double, Double, Int)
, comparisonStyle :: ComparisonStyle
}
defaultConfig :: Config
defaultConfig = Config
{ outputDir = "."
, chartTitle = Nothing
, classifyBenchmark = \b -> Just ("default", b)
, sortBenchmarks = id
, sortBenchGroups = id
, setYScale = Nothing
, comparisonStyle = CompareFull
}
genGroupGraph
:: FilePath
-> String
-> Maybe [Double]
-> Config
-> [String]
-> [(String, [Maybe Double])]
-> IO ()
genGroupGraph outputFile units yindexes Config{..} benchNames values = do
toFile
def ((outputDir </> outputFile) ++ ".svg") $ do
case chartTitle of
Just title -> do
layout_title .= title
layout_title_style . font_size .= 25
Nothing -> return ()
let vals =
if length values == 1
then values ++ [([], [])]
else if comparisonStyle == CompareDelta
then let (_, h) = head values
toDelta x1 x2 =
case x1 of
Nothing -> Nothing
Just v -> fmap (\v1 -> v1 - v) x2
convertTail (name, xs) = (name ++ "(-base)", zipWith toDelta h xs)
convertHead (name, xs) = (name ++ "(base)", xs)
in convertHead (head values) : map convertTail (tail values)
else values
layout_x_axis . laxis_generate .= autoIndexAxis (map fst vals)
layout_x_axis . laxis_style . axis_label_style . font_size .= 16
layout_y_axis . laxis_style . axis_label_style . font_size .= 14
layout <- get
case _layout_legend layout of
Nothing -> return ()
Just style@LegendStyle{..} -> do
let s = style { _legend_plot_size = 22
, _legend_label_style = _legend_label_style
{ _font_size = 14 }
}
put $ layout { _layout_legend = Just s }
let modifyLabels ad = ad {
_axis_labels = map (map (second (++ " " ++ units)))
(_axis_labels ad)
}
layout_y_axis . laxis_override .= modifyLabels
case yindexes of
Nothing -> return ()
Just indexes ->
layout_y_axis . laxis_override .= \_ ->
makeAxis (let f = floor :: Double -> Int
in map ((++ " " ++ units) . show . f))
(indexes, [], [])
let modifyVal x = map (fromMaybe 0) (snd x)
plot $ fmap plotBars $ bars benchNames (addIndexes (map modifyVal vals))
transposeLists :: Show a => String -> [[a]] -> Maybe [[Maybe a]]
transposeLists gname xs =
case nub $ map length xs of
[0] -> trace ("Warning! " ++ gname ++ ": No results") Nothing
[n] ->
let ys = map (convertToMaybe n) xs
in Just $ transpose ys
[0,n] ->
let ys = map (convertToMaybe n) xs
in Just $ transpose ys
_ -> trace ("Warning! " ++ gname
++ ": has multiple runs with different number of benchmarks\n"
++ show xs) Nothing
where
convertToMaybe n zs = case zs of
[] -> replicate n Nothing
x -> map Just x
getResultsForBenchGroup
:: CSV
-> (String -> Maybe (String, String))
-> String
-> [String]
-> Maybe [[Maybe Double]]
getResultsForBenchGroup csvData classify groupName bmnames =
transposeLists groupName $ map getBenchmarkValues bmnames
where
match name origName =
case classify origName of
Nothing -> False
Just (g, n) -> g == groupName && n == name
getBenchmarkValues :: String -> [Double]
getBenchmarkValues bmname =
map (\(_, y) -> read y)
$ map (\xs -> (xs !! 0, xs !! 1))
$ filter (match bmname . head) csvData
genGraph :: FilePath -> String -> Maybe [Double] -> Config -> CSV -> IO ()
genGraph outfile units yindexes cfg@Config{..} csvData = do
let origNames = nub $ map head csvData
bmTuples = catMaybes $ map classifyBenchmark origNames
let origGroups = nub $ map fst bmTuples
bmgroups = sortBenchGroups origGroups
when (bmgroups == []) $ error
"No benchmark groups to plot. Please check your benchmark \
\classifier (classifyBenchmarks), group filter (sortBenchGroups) or \
\the input data"
let newGroups = bmgroups \\ origGroups
when (newGroups /= []) $ error $
"sortBenchGroups cannot add new groups to the original list. The\
\following new groups were added: " ++ show newGroups
let rep = getRepeated bmTuples
z = zip origNames bmTuples
zrep = filter (\(_, tup) -> tup `elem` rep) z
when (zrep /= []) $ do
error $
"classifyBenchmark cannot map different benchmarks to the same \
\name under the same group.\n"
++ unlines (map show zrep)
let names = nub $ map snd bmTuples
bmnames = sortBenchmarks names
when (bmnames == []) $ error
"No benchmark names to plot. Please check your benchmark \
\classifier (classifyBenchmarks), filter (sortBenchmarks) or \
\the input data"
let newNames = bmnames \\ names
when (newNames /= []) $ error $
"sortBenchmarks cannot add new names to the original list. The\
\following new names were added: " ++ show newNames
mapM_ (checkBenchNameInGrps bmgroups bmTuples) bmnames
let grpResults = concat $ map (grpGetResults bmnames) bmgroups
filterJust (gName, res) =
case res of
Nothing -> do
putStrLn $ "Warning! no results found for benchmark group " ++ gName
return Nothing
Just x -> return $ Just (gName, x)
res0 <- mapM filterJust grpResults
let res = catMaybes res0
when (res == []) $ error
"Each benchmark being plotted must have the same number of results \
\in the CSV input"
genGroupGraph outfile units yindexes cfg bmnames res
where
grpGetResults bmnames groupName =
let res = getResultsForBenchGroup csvData classifyBenchmark
groupName bmnames
in case res of
Nothing -> [(groupName, Nothing)]
Just xs ->
case length xs of
0 -> [(groupName, Nothing)]
1 -> map (groupName,) (map Just xs)
_ -> zipWith (withIndexes groupName) [(1::Int)..]
(map Just xs)
withIndexes groupName indx y = (groupName ++ "(" ++ show indx ++ ")", y)
checkBenchNameInGrps bmgroups bmTuples nm =
let appearsIn = nub $ map fst $ filter (\(_, n) -> nm == n) bmTuples
xs = bmgroups \\ appearsIn
in if not (null xs)
then error $
"Each benchmark name must appear in all benchmark groups.\n\
\Benchmark " ++ nm ++ " does not appear in " ++ show xs ++
"\nPlease check your benchmark classifier (classifyBenchmarks).\n"
else return ()
eqCaseInsensitive :: String -> String -> Bool
eqCaseInsensitive a b = map toUpper a == map toUpper b
getFieldIndexInLine :: String -> (Int, [String]) -> Maybe (Int, Int)
getFieldIndexInLine fieldName (lineno, fields) =
fmap (lineno,) $
findIndex (\x -> eqCaseInsensitive x fieldName) fields
getFieldIndexUnchecked :: String -> [(Int, [String])] -> [(Int, Int)]
getFieldIndexUnchecked fieldName csvlines =
nubBy ((==) `on` snd) $
catMaybes $ map (getFieldIndexInLine fieldName) csvlines
getFieldIndexChecked :: String -> [(Int, [String])] -> Int
getFieldIndexChecked fieldName csvlines =
let idxs = getFieldIndexUnchecked fieldName csvlines
in case idxs of
[(_, x)] -> x
[] -> error $ "Field name [" ++ fieldName
++ "] does not occur in any line of "
++ "the CSV input. Is the header line missing?"
_ -> error $ "Field [" ++ fieldName
++ "] found at different indexes [(line, column): " ++ show idxs
++ "] in different lines of CSV input"
findIndexes :: String
-> String
-> String
-> [(Int, [String])]
-> (Int, Maybe Int, Int, [(Int, [String])])
findIndexes benchmarkNameField iterationField fieldName csvlines =
let fieldIdx = getFieldIndexChecked fieldName csvlines
iterIdxs = getFieldIndexUnchecked iterationField csvlines
nameIdxs = getFieldIndexUnchecked benchmarkNameField csvlines
csvlines' = filter (\(_, xs) ->
(not $ (xs !! fieldIdx) `eqCaseInsensitive` fieldName)) csvlines
in case nameIdxs of
[] -> case iterIdxs of
[] ->
case getFieldIndexChecked benchmarkNameField csvlines of
_ -> error "not reached"
_ ->
( 0
, Just $ getFieldIndexChecked iterationField csvlines + 1
, fieldIdx + 1
, csvlines'
)
_ ->
( getFieldIndexChecked benchmarkNameField csvlines
, case iterIdxs of
[] -> Nothing
_ -> Just $ getFieldIndexChecked iterationField csvlines
, fieldIdx
, csvlines'
)
extractIndexes :: (Int, Maybe Int, Int, [(Int, [String])]) -> [(Int, [String])]
extractIndexes (nameIdx, iterIdx, fieldIdx, csvlines) =
let zipList = zipWith (\(l, xs) (_, ys) -> (l, xs ++ ys))
in map (indexWithError nameIdx "name") csvlines
`zipList`
case iterIdx of
Nothing -> repeat (1, ["1"])
Just idx -> map (indexWithError idx "iter") csvlines
`zipList` map (indexWithError fieldIdx "requested") csvlines
where
indexWithError :: Int -> String -> (Int, [String]) -> (Int, [String])
indexWithError idx colName (l, xs) =
if (length xs < idx)
then error $ "Line " ++ show l ++ " " ++ show colName
++ " column at index " ++ show idx ++ " not present"
else (l, [xs !! idx])
bgraph :: FilePath -> FilePath -> String -> Config -> IO ()
bgraph inputFile outputFile fieldName cfg@Config{..} = do
createDirectoryIfMissing True outputDir
putStrLn $ "Creating chart "
++ maybe "" (\x -> "[" ++ x ++ "]") chartTitle
++ " at "
++ show (outputDir </> outputFile)
csvData <- parseCSVFromFile inputFile
case csvData of
Left e -> error $ show e
Right csvlines -> do
let isTimeField =
let x = map toUpper fieldName
in x == "TIME" || x == "MEAN"
let isAllocationField =
let x = map toUpper fieldName
in x == "ALLOCATED" || x == "MAXRSS"
let isMaxField =
let x = map toUpper fieldName
in x == "MAXRSS"
(multiplier, units) =
case isTimeField of
True -> (1000, "ms")
False -> case isAllocationField of
True -> (1/2^(20 :: Int), "MiB")
False -> (1, "")
yindexes =
case setYScale of
Nothing -> Nothing
Just (rangeMin, rangeMax, nInterval) ->
let r = (rangeMax - rangeMin)/(fromIntegral nInterval)
in case isTimeField of
True ->
let r' = r/1000
rmin = rangeMin/1000
in Just $ take (nInterval + 1) [rmin, rmin + r'..]
False -> Just $ take (nInterval + 1) [rangeMin, rangeMin + r..]
readWithError :: Read a => String -> String -> Int -> (Int, [String]) -> a
readWithError fname typ idx (lno, xs) =
case readMaybe (xs !! idx) of
Nothing -> error $ "Cannot read " ++ show fname
++ " field as a " ++ typ ++ " type at line number "
++ show lno
Just n -> n
foldToMean xs =
let iters = map (readWithError "iter" "Double" 0) xs :: [Double]
values = map (readWithError "requested" "Double" 1) xs :: [Double]
mean = sum values / sum iters
in show $ mean * multiplier
foldToMax xs =
let values = map (readWithError "requested" "Double" 1) xs :: [Double]
in show $ (maximum values) * multiplier
in
zip [1..] csvlines
& filter (\(_,xs) -> xs /= [""])
& findIndexes "Name" "iters" fieldName
& extractIndexes
& groupBy (\l1@(_, x:_) l2@(_, y:_) -> x == y
&& ((readWithError "iter" "Int" 1 l2 :: Int) >
(readWithError "iter" "Int" 1 l1 :: Int)))
& map (\xs -> [ head $ map (head . snd) xs
, if isMaxField
then foldToMax $ map (\(l, ys) -> (l, tail ys)) xs
else foldToMean $ map (\(l, ys) -> (l, tail ys)) xs
]
)
& genGraph outputFile units yindexes cfg