{-# LANGUAGE TypeFamilies, FlexibleContexts, NamedFieldPuns, RecordWildCards, GeneralizedNewtypeDeriving #-} module Graphics.BarChart.Types where import System.IO ( FilePath ) import Graphics.Rendering.Diagrams import Graphics.Rendering.Diagrams.Types ( SomeColor(..) ) import Data.Data ( Data, Typeable ) import Data.List ( nub, transpose ) import Data.Maybe ( fromJust, fromMaybe ) import Control.Arrow ( first ) type Label = String -- | Bar charts consist of a (possibly empty) list of labels for the -- diferent blcks of bars and the bars themselves. -- data BarChart a = BarChart { -- | Labels of blocks in bars. Drawn as a legend if non-empty. block_labels :: [Label], -- | The different bars of the chart. bars :: [Bar a] } deriving Show -- | Represents one bar of a bar chart. data Bar a = Bar { -- | Label written underneath label :: Label, -- | Different blocks of the bar. Simple charts contain only one -- block per bar. blocks :: [Block a] } deriving Show -- | Bocks either have a single associated value or a mean value along -- with minimum and maximum deviation. -- data Block a = Value a | Interval { mean :: a, lower :: a, upper :: a } deriving Show -- | Instances of this class can be depicted in bar charts. -- class Num a => Measurable a where -- | Measures the given value to figure out the correponding height -- of the bar. -- size :: a -> Double instance Measurable Double where size = id instance Measurable Float where size = realToFrac instance Measurable Integer where size = fromIntegral instance Measurable Int where size = fromIntegral type ColorName = String readColor :: ColorName -> SomeColor readColor color = SomeColor . fromMaybe (error $ "ivalid color: " ++ color) $ readColourName color -- | Specifies how bar charts are rendered data Config = Config { -- | file to which the bar chart is written outFile :: FilePath, -- | Type of generated file outputType :: OutputType, -- | Title of the generated chart caption :: Label, -- | Label of the x-axis xLabel :: Label, -- | label of the y-axis yLabel :: Label, -- | Colors for the different blocks of a bar. If there are fewer -- colors than blocks, then colors are reused in a cyclic fashion. barColors :: [SomeColor], -- | Dimensions of the generated chart. The image will be a bit -- larger because of additiona space used for labels. dimensions :: (Int,Int), -- | Scales the height of the chart. The given ratio is multiplied -- with the 'size' of bars as given by the corresponding -- 'Measurable' instance. ratio :: Double, -- | Specifies the size of fonts used for labels. fontSize :: Double, -- | Value between 0.0 and 1.0 which pecifies the width of -- bars. Zero means that the bars are lines and 1.0 means that the -- is no space between bars. barRatio :: Double } -- | The default configuration generates a PNG file with a chart of -- size 600x300 pixels. The output file is left unspecified and you -- should provide one if you use a cstom configuration. -- conf :: Config conf = Config { outFile = "", outputType = PNG, caption = "", xLabel = "", yLabel = "", barColors = map SomeColor [forestgreen,firebrick,midnightblue], dimensions = (600,300), ratio = 1, fontSize = 12, barRatio = 0.3 } -- | Wrapper around the 'Double' type used in bar charts for criterion -- summary files. It has a custom 'Show' instance to produce labels -- like @10ms@ or @2h@ rather than showing the plain 'Double' -- values. -- newtype RunTime = RunTime Double deriving (Eq,Num,Measurable) instance Read RunTime where readsPrec n = map (first RunTime) . readsPrec n instance Show RunTime where show (RunTime t) | t >= hours = display (t/hours) ++ " h" | t >= minutes = display (t/minutes) ++ " m" | t >= seconds = display (t/seconds) ++ " s" | t >= millis = display (t/millis) ++ " ms" | t >= micros = display (t/micros) ++ " us" | otherwise = display (t/nanos) ++ " ns" where hours = 60 * minutes minutes = 60 * seconds seconds = 1 millis = seconds / 1000 micros = millis / 1000 nanos = micros / 1000 display :: Double -> String display x | x >= 100 = show (fromIntegral (round x)) | x >= 10 = show (fromIntegral (round (10*x)) / 10) | otherwise = show (fromIntegral (round (100*x)) / 100) -- | Wrapper around the double type used in bar charts for progression -- summaries. It has a custom 'Show' instance that shows the 'Double' -- values as percentages. -- newtype Ratio = Ratio Double deriving (Eq,Num,Measurable) instance Read Ratio where readsPrec n = map (first Ratio) . readsPrec n instance Show Ratio where show (Ratio r) = display (100*r) ++ " %" -- | Values of this type are drawn as charts where each bar may -- consist of multiple blocks. -- data MultiBars a = MultiBars [Label] [(Label,[a])] deriving Show -- | Converts bars with multiple blocks into their 'BarChart' -- representation. drawMultiBars :: Measurable a => MultiBars a -> BarChart a drawMultiBars (MultiBars block_labels pairs) = BarChart{..} where bars = map (uncurry mkBar) pairs mkBar label values = Bar{..} where blocks = map Value values -- | Values of this type are drawn as charts where each bar has an -- associated deviation depicted as an interval next to the bar. -- newtype Intervals a = Intervals [(Label,(a,a,a))] deriving Show -- | Converts bars with associated deviation into their 'BarChart' -- representation. -- drawIntervals :: Measurable a => Intervals a -> BarChart a drawIntervals (Intervals pairs) = BarChart{..} where block_labels = [] bars = map (uncurry mkBar) pairs mkBar label (mean,lower,upper) = Bar{..} where blocks = [Interval{..}] -- | Values of this type are drawn as charts where each bar may be -- divided into multiple blocks with an associated deviation -- depicted as intervals next to them. -- data MultiBarIntervals a = MBIntervals [Label] [(Label,[(a,a,a)])] deriving Show -- | Merges several interval charts into a chart where each bar has -- multiple blocks that represent the different interval charts. -- mergeIntervals :: Num a => [(Label,Intervals a)] -> MultiBarIntervals a mergeIntervals xs = MBIntervals block_labels [ (label,intervals label) | label <- bar_labels ] where bar_labels = map fst xs block_labels = nub (concatMap ((\ (Intervals ys) -> map fst ys) . snd) xs) intervals l = map (fromMaybe (0,0,0) . flip lookup ys) block_labels where Intervals ys = fromJust (lookup l xs) -- | Swaps bars and blocks of a chart that contains both and -- associated deviations. -- flipMultiBarIntervals :: MultiBarIntervals a -> MultiBarIntervals a flipMultiBarIntervals (MBIntervals old_block_labels old_bars) = MBIntervals new_block_labels new_bars where new_block_labels = map fst old_bars new_bars = zip old_block_labels . transpose . map snd $ old_bars -- | Converts bars with multiple blocks and associated deviations into -- their 'BarChart' representation. -- drawMultiBarIntervals :: Measurable a => MultiBarIntervals a -> BarChart a drawMultiBarIntervals (MBIntervals block_labels pairs) = BarChart{..} where bars = map (uncurry mkBar) pairs mkBar label ints = Bar{..} where blocks = map mkInterval ints mkInterval (mean,lower,upper) = Interval{..}