diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 1.9.3 +Version: 1.9.5 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2014 @@ -14,19 +14,20 @@ Documentation: https://github.com/timbod7/haskell-chart/wiki. Category: Graphics -Cabal-Version: >= 1.6 +Cabal-Version: 1.18 Build-Type: Simple library + default-language: Haskell98 Build-depends: base >= 3 && < 5 , old-locale - , time, mtl, array - , lens >= 3.9 && < 4.19 + , time, array + , lens >= 3.9 && < 5.3 , colour >= 2.2.1 && < 2.4 , data-default-class < 0.2 - , mtl >= 2.0 && < 2.3 + , mtl >= 2.0 && < 2.4 , operational >= 0.2.2 && < 0.3 - , vector >=0.9 && <0.13 + , vector >=0.9 && <0.14 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.4 && <0.19 diff --git a/Graphics/Rendering/Chart/Axis/Floating.hs b/Graphics/Rendering/Chart/Axis/Floating.hs --- a/Graphics/Rendering/Chart/Axis/Floating.hs +++ b/Graphics/Rendering/Chart/Axis/Floating.hs @@ -30,7 +30,7 @@ loga_labelf ) where -import Data.List(minimumBy) +import Data.List(minimumBy, nub) import Data.Ord (comparing) import Data.Default.Class import Numeric (showEFloat, showFFloat) @@ -68,7 +68,7 @@ -- | A wrapper class for doubles used to indicate they are to -- be plotted against a log axis. -newtype LogValue = LogValue Double +newtype LogValue = LogValue {unLogValue :: Double} deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat) instance Show LogValue where @@ -142,7 +142,7 @@ showWithoutOffset :: RealFloat d => [d] -> [String] showWithoutOffset xs - | useScientificNotation = map (\x -> showEFloat' (Just 1) x) xs + | useScientificNotation = map (showEFloat' (Just 1)) xs | otherwise = map showD xs where -- use scientific notation if max value is too big or too small @@ -186,7 +186,7 @@ } instance (Show a, RealFloat a) => Default (LinearAxisParams a) where - def = LinearAxisParams + def = LinearAxisParams { _la_labelf = showDs , _la_nLabels = 5 , _la_nTicks = 50 @@ -249,16 +249,16 @@ ---------------------------------------------------------------------- instance (Show a, RealFloat a) => Default (LogAxisParams a) where - def = LogAxisParams + def = LogAxisParams { _loga_labelf = showDs } --- | Generate a log axis automatically, scaled appropriate for the +-- | Generate a log axis automatically, scaled appropriately for the -- input data. autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a autoScaledLogAxis lap ps0 = makeAxis' (realToFrac . log) (realToFrac . exp) - (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rgridvs) + (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rlabelvs) where ps = filter (\x -> isValidNumber x && 0 < x) ps0 (minV,maxV) = (minimum ps,maximum ps) @@ -266,7 +266,7 @@ range [] = (3,30) range _ | minV == maxV = (realToFrac $ minV/3, realToFrac $ maxV*3) | otherwise = (realToFrac $ minV, realToFrac $ maxV) - (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) + (rlabelvs, rtickvs) = logTicks (range ps) data LogAxisParams a = LogAxisParams { @@ -276,13 +276,13 @@ {- Rules: Do not subdivide between powers of 10 until all powers of 10 - get a major ticks. + get major ticks. Do not subdivide between powers of ten as [1,2,4,6,8,10] when - 5 gets a major ticks - (ie the major ticks need to be a subset of the minor tick) + 5 gets a major tick + (i.e. the major ticks need to be a subset of the minor ticks) -} -logTicks :: Range -> ([Rational],[Rational],[Rational]) -logTicks (low,high) = (major,minor,major) +logTicks :: Range -> ([Rational],[Rational]) +logTicks (low,high) = (nub major,nub minor) where pf :: RealFrac a => a -> (Integer, a) pf = properFraction @@ -299,17 +299,17 @@ maximum (1:filter (\x -> log10 (fromRational x) <= r) l)*10^^i upper a l = let (i,r) = pf (log10 a) in minimum (10:filter (\x -> r <= log10 (fromRational x)) l)*10^^i - + powers :: (Double,Double) -> [Rational] -> [Rational] powers (x,y) l = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] :: [Integer] , a <- l ] midselection r l = filter (inRange r l) (powers r l) inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) - + logRange = (log10 low, log10 high) - + roundPow x = 10^^(round x :: Integer) - + major | 17.5 < log10 ratio = map roundPow $ steps (min 5 (log10 ratio)) logRange | 12 < log10 ratio = map roundPow $ @@ -326,19 +326,15 @@ (dl',dh') = (fromRational l', fromRational h') ratio' :: Double ratio' = fromRational (h'/l') - filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') - + filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') + minor | 50 < log10 ratio' = map roundPow $ steps 50 (log10 dl', log10 dh') | 6 < log10 ratio' = filterX [1,10] - | 3 < log10 ratio' = filterX [1,5,10] + | 4 < log10 ratio' = filterX [1,5,10] | 6 < ratio' = filterX [1..10] | 3 < ratio' = filterX [1,1.2..10] | otherwise = steps 50 (dl', dh') - - -log10 :: (Floating a) => a -> a -log10 = logBase 10 $( makeLenses ''LinearAxisParams ) $( makeLenses ''LogAxisParams ) diff --git a/Graphics/Rendering/Chart/Axis/Indexed.hs b/Graphics/Rendering/Chart/Axis/Indexed.hs --- a/Graphics/Rendering/Chart/Axis/Indexed.hs +++ b/Graphics/Rendering/Chart/Axis/Indexed.hs @@ -7,14 +7,15 @@ -- Calculate and render indexed axes {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Axis.Indexed( PlotIndex(..), + autoIndexAxis', autoIndexAxis, addIndexes, ) where -import Control.Arrow (first) import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types @@ -31,18 +32,18 @@ -- | Augment a list of values with index numbers for plotting. addIndexes :: [a] -> [(PlotIndex,a)] -addIndexes as = map (first PlotIndex) (zip [0..] as) +addIndexes = zipWith (\n x -> (PlotIndex n, x)) [0..] -- | Create an axis for values indexed by position. The -- list of strings are the labels to be used. -autoIndexAxis :: Integral i => [String] -> [i] -> AxisData i -autoIndexAxis labels vs = AxisData { +autoIndexAxis' :: Integral i => Bool -> [String] -> AxisFn i +autoIndexAxis' tks labels vs = AxisData { _axis_visibility = def { _axis_show_ticks = False }, _axis_viewport = vport, _axis_tropweiv = invport, - _axis_ticks = [], + _axis_ticks = if tks then map (, 5) $ take (length labels) [0..] else [], _axis_labels = [filter (\(i,_) -> i >= imin && i <= imax) - (zip [0..] labels)], + (zip [0..] labels)], _axis_grid = [] } where @@ -51,3 +52,6 @@ invport = invLinMap round fromIntegral (imin, imax) imin = minimum vs imax = maximum vs + +autoIndexAxis :: Integral i => [String] -> AxisFn i +autoIndexAxis = autoIndexAxis' False diff --git a/Graphics/Rendering/Chart/Axis/Int.hs b/Graphics/Rendering/Chart/Axis/Int.hs --- a/Graphics/Rendering/Chart/Axis/Int.hs +++ b/Graphics/Rendering/Chart/Axis/Int.hs @@ -14,11 +14,58 @@ ) where import Data.List(genericLength) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating instance PlotValue Int where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Int8 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Int16 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Int32 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Int64 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word8 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word16 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word32 where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word64 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis diff --git a/Graphics/Rendering/Chart/Backend/Impl.hs b/Graphics/Rendering/Chart/Backend/Impl.hs --- a/Graphics/Rendering/Chart/Backend/Impl.hs +++ b/Graphics/Rendering/Chart/Backend/Impl.hs @@ -10,7 +10,7 @@ module Graphics.Rendering.Chart.Backend.Impl where -import Control.Monad.Reader +import Control.Monad import Control.Monad.Operational import Graphics.Rendering.Chart.Geometry @@ -22,20 +22,20 @@ -- | The abstract drawing operation generated when using the -- the chart drawing API. --- +-- -- See the documentation of the different function for the correct semantics -- of each instruction: --- +-- -- * 'strokePath', 'fillPath' --- +-- -- * 'drawText', 'textSize' --- +-- -- * 'getPointAlignFn', 'getCoordAlignFn', 'AlignmentFns' --- +-- -- * 'withTransform', 'withClipRegion' --- +-- -- * 'withLineStyle', 'withFillStyle', 'withFontStyle' --- +-- data ChartBackendInstr a where StrokePath :: Path -> ChartBackendInstr () FillPath :: Path -> ChartBackendInstr () @@ -49,22 +49,22 @@ WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a -- | A 'BackendProgram' provides the capability to render a chart somewhere. --- +-- -- The coordinate system of the backend has its initial origin (0,0) --- in the top left corner of the drawing plane. The x-axis points --- towards the top right corner and the y-axis points towards +-- in the top left corner of the drawing plane. The x-axis points +-- towards the top right corner and the y-axis points towards -- the bottom left corner. The unit used by coordinates, the font size, -- and lengths is the always the same, but depends on the backend. -- All angles are measured in radians. --- --- The line, fill and font style are set to their default values +-- +-- The line, fill and font style are set to their default values -- initially. --- --- Information about the semantics of the instructions can be +-- +-- Information about the semantics of the instructions can be -- found in the documentation of 'ChartBackendInstr'. type BackendProgram a = Program ChartBackendInstr a --- | Stroke the outline of the given path using the +-- | Stroke the outline of the given path using the -- current 'LineStyle'. This function does /not/ perform -- alignment operations on the path. See 'Path' for the exact semantic -- of paths. @@ -84,13 +84,13 @@ textSize :: String -> BackendProgram TextSize textSize text = singleton (GetTextSize text) --- | Draw a single-line textual label anchored by the baseline (vertical) +-- | Draw a single-line textual label anchored by the baseline (vertical) -- left (horizontal) point. Uses the current 'FontStyle' for drawing. drawText :: Point -> String -> BackendProgram () drawText p text = singleton (DrawText p text) -- | Apply the given transformation in this local --- environment when drawing. The given transformation +-- environment when drawing. The given transformation -- is applied after the current transformation. This -- means both are combined. withTransform :: Matrix -> BackendProgram a -> BackendProgram a @@ -98,11 +98,11 @@ -- | Use the given font style in this local -- environment when drawing text. --- --- An implementing backend is expected to guarentee +-- +-- An implementing backend is expected to guarantee -- to support the following font families: @serif@, @sans-serif@ and @monospace@; --- --- If the backend is not able to find or load a given font +-- +-- If the backend is not able to find or load a given font -- it is required to fall back to a custom fail-safe font -- and use it instead. withFontStyle :: FontStyle -> BackendProgram a -> BackendProgram a @@ -120,7 +120,7 @@ -- | Use the given clipping rectangle when drawing -- in this local environment. The new clipping region --- is intersected with the given clip region. You cannot +-- is intersected with the given clip region. You cannot -- escape the clip! withClipRegion :: Rect -> BackendProgram a -> BackendProgram a withClipRegion c p = singleton (WithClipRegion c p) diff --git a/Graphics/Rendering/Chart/Drawing.hs b/Graphics/Rendering/Chart/Drawing.hs --- a/Graphics/Rendering/Chart/Drawing.hs +++ b/Graphics/Rendering/Chart/Drawing.hs @@ -27,20 +27,20 @@ PointShape(..) , PointStyle(..) , drawPoint - + -- * Alignments and Paths , alignPath , alignFillPath , alignStrokePath , alignFillPoints , alignStrokePoints - + , alignFillPoint , alignStrokePoint - + , strokePointPath , fillPointPath - + -- * Transformation and Style Helpers , withRotation , withTranslation @@ -48,17 +48,17 @@ , withScaleX, withScaleY , withPointStyle , withDefaultStyle - + -- * Text Drawing , drawTextA , drawTextR , drawTextsR , textDrawRect , textDimension - + -- * Style Helpers , defaultColorSeq - + , solidLine , dashedLine @@ -70,12 +70,12 @@ , exes , stars , arrows - + , solidFillStyle - + -- * Backend and general Types , module Graphics.Rendering.Chart.Backend - + -- * Accessors , point_color , point_border_color @@ -95,7 +95,6 @@ import Data.Colour import Data.Colour.Names import Data.List (unfoldr) -import Data.Monoid import Graphics.Rendering.Chart.Backend import Graphics.Rendering.Chart.Geometry hiding (moveTo) @@ -128,8 +127,8 @@ -- | Changes the 'LineStyle' and 'FillStyle' to comply with -- the given 'PointStyle'. withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a -withPointStyle (PointStyle cl bcl bw _ _) m = - withLineStyle (def { _line_color = bcl, _line_width = bw, _line_join = LineJoinMiter }) $ +withPointStyle (PointStyle cl bcl bw _ _) m = + withLineStyle (def { _line_color = bcl, _line_width = bw, _line_join = LineJoinMiter }) $ withFillStyle (solidFillStyle cl) m withDefaultStyle :: BackendProgram a -> BackendProgram a @@ -148,7 +147,7 @@ close -- | Align the path using the environment's alignment function for points. --- This is generally useful when stroking. +-- This is generally useful when stroking. -- See 'alignPath' and 'getPointAlignFn'. alignStrokePath :: Path -> BackendProgram Path alignStrokePath p = do @@ -156,7 +155,7 @@ return $ alignPath f p -- | Align the path using the environment's alignment function for coordinates. --- This is generally useful when filling. +-- This is generally useful when filling. -- See 'alignPath' and 'getCoordAlignFn'. alignFillPath :: Path -> BackendProgram Path alignFillPath p = do @@ -182,14 +181,14 @@ -- | Align the point using the environment's alignment function for points. -- See 'getPointAlignFn'. alignStrokePoint :: Point -> BackendProgram Point -alignStrokePoint p = do +alignStrokePoint p = do alignfn <- getPointAlignFn return (alignfn p) -- | Align the point using the environment's alignment function for coordinates. -- See 'getCoordAlignFn'. alignFillPoint :: Point -> BackendProgram Point -alignFillPoint p = do +alignFillPoint p = do alignfn <- getCoordAlignFn return (alignfn p) @@ -217,19 +216,19 @@ drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram () drawTextA hta vta = drawTextR hta vta 0 -{- +{- The following is useful for checking out the bounding-box calculation. At present it looks okay for PNG/Cairo but is a bit off for SVG/Diagrams; this may well be down to differences in how fonts are rendered in the two backends drawTextA hta vta p txt = - drawTextR hta vta 0 p txt - >> withLineStyle (solidLine 1 (opaque red)) + drawTextR hta vta 0 p txt + >> withLineStyle (solidLine 1 (opaque red)) (textDrawRect hta vta p txt >>= \rect -> alignStrokePath (rectPath rect) >>= strokePath) -} - + -- | Draw a textual label anchored by one of its corners -- or edges, with rotation. Rotation angle is given in degrees, -- rotation is performed around anchor point. @@ -251,7 +250,7 @@ drawTextsR hta vta angle p s = case num of 0 -> return () 1 -> drawTextR hta vta angle p s - _ -> + _ -> withTranslation p $ withRotation theta $ do tss <- mapM textSize ss @@ -320,7 +319,7 @@ textDimension s = do ts <- textSize s return (textSizeWidth ts, textSizeHeight ts) - + -- ----------------------------------------------------------------------- -- Point Types and Drawing -- ----------------------------------------------------------------------- @@ -350,7 +349,7 @@ -- | Default style to use for points. instance Default PointStyle where - def = PointStyle + def = PointStyle { _point_color = opaque black , _point_border_color = transparent , _point_border_width = 0 @@ -383,7 +382,7 @@ PointShapeArrowHead theta -> withTranslation p $ withRotation (theta - pi/2) $ drawPoint (filledPolygon r 3 True cl) (Point 0 0) - PointShapePlus -> + PointShapePlus -> strokePath $ moveTo' (x+r) y <> lineTo' (x-r) y <> moveTo' x (y-r) @@ -436,7 +435,7 @@ filledCircles :: Double -- ^ Radius of circle. -> AlphaColour Double -- ^ Fill colour. -> PointStyle -filledCircles radius cl = +filledCircles radius cl = PointStyle cl transparent 0 radius PointShapeCircle -- | Style for stroked circle points. @@ -444,7 +443,7 @@ -> Double -- ^ Thickness of line. -> AlphaColour Double -- Colour of line. -> PointStyle -hollowCircles radius w cl = +hollowCircles radius w cl = PointStyle transparent cl w radius PointShapeCircle -- | Style for stroked polygon points. @@ -454,7 +453,7 @@ -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Colour of line. -> PointStyle -hollowPolygon radius w sides isrot cl = +hollowPolygon radius w sides isrot cl = PointStyle transparent cl w radius (PointShapePolygon sides isrot) -- | Style for filled polygon points. @@ -463,7 +462,7 @@ -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Fill color. -> PointStyle -filledPolygon radius sides isrot cl = +filledPolygon radius sides isrot cl = PointStyle cl transparent 0 radius (PointShapePolygon sides isrot) -- | Plus sign point style. @@ -471,7 +470,7 @@ -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle -plusses radius w cl = +plusses radius w cl = PointStyle transparent cl w radius PointShapePlus -- | Cross point style. diff --git a/Graphics/Rendering/Chart/Easy.hs b/Graphics/Rendering/Chart/Easy.hs --- a/Graphics/Rendering/Chart/Easy.hs +++ b/Graphics/Rendering/Chart/Easy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} ---------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Easy @@ -6,7 +6,7 @@ -- License : BSD-style (see chart/COPYRIGHT) -- -- A high level API for generating a plot quickly. --- +-- -- Importing the Easy module brings into scope all core functions and types required -- for working with the chart library. This includes key external dependencies such as -- Control.Lens and Data.Colour. The module also provides several helper functions for @@ -17,10 +17,10 @@ -- -- > import Graphics.Rendering.Chart.Easy -- > import Graphics.Rendering.Chart.Backend.Cairo --- > +-- > -- > signal :: [Double] -> [(Double,Double)] -- > signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5))) | x <- xs ] --- > +-- > -- > main = toFile def "example.png" $ do -- > layout_title .= "Amplitude Modulation" -- > plot (line "am" [signal [0,(0.5)..400]]) @@ -46,7 +46,7 @@ ) where import Control.Lens -import Control.Monad(when) +import Control.Monad(unless) import Data.Default.Class import Data.Colour hiding (over) -- overlaps with lens over function import Data.Colour.Names @@ -83,9 +83,9 @@ plot_points_style . point_color .= color plot_points_style . point_shape .= shape plot_points_style . point_radius .= 2 - + -- Show borders for unfilled shapes - when (not (isFilled shape)) $ do + unless (isFilled shape) $ do plot_points_style . point_border_color .= color plot_points_style . point_border_width .= 1 @@ -93,9 +93,9 @@ isFilled PointShapeCircle = True isFilled PointShapePolygon{} = True isFilled _ = False - + -- | Construct a bar chart with the given titles and data, using the --- next available colors +-- next available colors bars :: (PlotValue x, BarsPlotValue y) => [String] -> [(x,[y])] -> EC l (PlotBars x y) bars titles vals = liftEC $ do styles <- sequence [fmap mkStyle takeColor | _ <- titles] diff --git a/Graphics/Rendering/Chart/Geometry.hs b/Graphics/Rendering/Chart/Geometry.hs --- a/Graphics/Rendering/Chart/Geometry.hs +++ b/Graphics/Rendering/Chart/Geometry.hs @@ -53,8 +53,6 @@ import qualified Prelude import Prelude hiding ((^)) -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Semigroup(..)) -- The homomorphic version to avoid casts inside the code. (^) :: Num a => a -> Integer -> a diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -11,11 +11,11 @@ -- (see 'Control.Lens') for each field of the following data types: -- -- * 'Layout' --- +-- -- * 'LayoutLR' --- +-- -- * 'StackedLayouts' --- +-- -- * 'LayoutAxis' -- {-# LANGUAGE CPP #-} @@ -33,12 +33,12 @@ , StackedLayout(..) -- , LegendItem haddock complains about this being missing, but from what? , MAxisFn - + -- * Rendering , layoutToRenderable - , layoutToGrid + , layoutToGrid , layoutLRToRenderable - , layoutLRToGrid + , layoutLRToGrid , renderStackedLayouts -- * LayoutAxis lenses @@ -48,7 +48,7 @@ , laxis_generate , laxis_override , laxis_reverse - + -- * Layout lenses , layout_background , layout_plot_background @@ -69,7 +69,7 @@ , layout_axes_title_styles , layout_all_font_styles , layout_foreground - + -- * LayoutLR lenses , layoutlr_background , layoutlr_plot_background @@ -114,18 +114,17 @@ import Data.Colour import Data.Colour.Names (white) import Data.Default.Class -import Data.Maybe (fromMaybe) -- | A @MAxisFn@ is a function that generates an (optional) axis -- given the points plotted against that axis. type MAxisFn t = [t] -> Maybe (AxisData t) -- | Type of axis that is used in 'Layout' and 'LayoutLR'. --- +-- -- To generate the actual axis type ('AxisData' and 'AxisT') -- the '_laxis_generate' function is called and custom settings -- are applied with '_laxis_override'. Note that the 'AxisVisibility' --- values in 'Layout' and 'LayoutLR' override visibility related +-- values in 'Layout' and 'LayoutLR' override visibility related -- settings of the axis. data LayoutAxis x = LayoutAxis { _laxis_title_style :: FontStyle @@ -138,29 +137,29 @@ , _laxis_generate :: AxisFn x -- ^ Function that generates the axis data, based upon the -- points plotted. The default value is 'autoAxis'. - + , _laxis_override :: AxisData x -> AxisData x -- ^ Function that can be used to override the generated axis data. -- The default value is 'id'. - + , _laxis_reverse :: Bool -- ^ True if left to right (bottom to top) is to show descending values. - + } -- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'. -- This is delivered by the 'PickFn' of a 'Renderable'. -data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry. - | LayoutPick_Title String -- ^ The title. - | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis. - | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis. - | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis. - | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis. - | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates. - | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate. - | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate. - | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate. - | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate. +data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry. + | LayoutPick_Title String -- ^ The title. + | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis. + | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis. + | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis. + | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis. + | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates. + | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate. + | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate. + | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate. + | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate. deriving (Show) type LegendItem = (String,Rect -> BackendProgram ()) @@ -169,11 +168,11 @@ -- axis. The title is at the top and the legend at the bottom. It's -- parametrized by the types of values to be plotted on the x -- and y axes. -data Layout x y = Layout +data Layout x y = Layout { _layout_background :: FillStyle -- ^ How to fill the background of everything. , _layout_plot_background :: Maybe FillStyle - -- ^ How to fill the background of the plot, + -- ^ How to fill the background of the plot, -- if different from the overall background. , _layout_title :: String @@ -219,7 +218,7 @@ layoutToGrid l = grid where lp :: Grid a -> a -> Grid a - lp = case fromMaybe LegendBelow $ _legend_position <$> _layout_legend l of + lp = case maybe LegendBelow _legend_position $ _layout_legend l of LegendAbove -> flip wideAbove LegendBelow -> aboveWide LegendRight -> besideTall @@ -245,7 +244,7 @@ g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems , weights (1,1) $ tval emptyRenderable ] --- | Render the plot area of a 'Layout'. This consists of the +-- | Render the plot area of a 'Layout'. This consists of the -- actual plot area with all plots, the axis and their titles. layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y)) @@ -303,7 +302,7 @@ mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) --- | Empty 'Layout' without title and plots. The background is white and +-- | Empty 'Layout' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- and right axis will not be visible. instance (PlotValue x, PlotValue y) => Default (Layout x y) where @@ -314,7 +313,7 @@ , _layout_title = "" , _layout_title_style = def { _font_size = 15 , _font_weight = FontWeightBold } - + , _layout_x_axis = def , _layout_top_axis_visibility = def { _axis_show_line = False , _axis_show_ticks = False @@ -333,16 +332,16 @@ } ---------------------------------------------------------------------- - + -- | A LayoutLR value is a single plot area, with an x axis and -- independent left and right y axes, with a title at the top; -- legend at the bottom. It's parametrized by the types of values -- to be plotted on the x and two y axes. -data LayoutLR x y1 y2 = LayoutLR +data LayoutLR x y1 y2 = LayoutLR { _layoutlr_background :: FillStyle -- ^ How to fill the background of everything. , _layoutlr_plot_background :: Maybe FillStyle - -- ^ How to fill the background of the plot, + -- ^ How to fill the background of the plot, -- if different from the overall background. , _layoutlr_title :: String @@ -365,7 +364,7 @@ -- ^ Rules to generate the right y axis. , _layoutlr_right_axis_visibility :: AxisVisibility -- ^ Visibility options for the right axis. - + , _layoutlr_plots :: [Either (Plot x y1) (Plot x y2)] -- ^ The data sets to plot in the chart. -- They are plotted over each other. @@ -385,12 +384,12 @@ toRenderable = setPickFn nullPickFn . layoutLRToRenderable -- | Render the given 'LayoutLR'. -layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) +layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) => LayoutLR x yl yr -> Renderable (LayoutPick x yl yr) -layoutLRToRenderable l = fillBackground (_layoutlr_background l) +layoutLRToRenderable l = fillBackground (_layoutlr_background l) $ gridToRenderable (layoutLRToGrid l) -layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr) +layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr) => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr)) layoutLRToGrid l = grid where @@ -425,8 +424,8 @@ , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] -- lm = _layoutlr_margin l -layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) - => LayoutLR x yl yr +layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) + => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr)) layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{ lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l, @@ -441,7 +440,7 @@ ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] yvalsL = [ y | (Left p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] - + bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals tAxis = mkAxis E_Top (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility ) xvals lAxis = mkAxis E_Left (overrideAxisVisibility l _layoutlr_left_axis _layoutlr_left_axis_visibility ) yvalsL @@ -494,7 +493,7 @@ -- | A container for a set of vertically 'StackedLayout's. -- The x axis of the different layouts will be aligned. -data StackedLayouts x = StackedLayouts +data StackedLayouts x = StackedLayouts { _slayouts_layouts :: [StackedLayout x] -- ^ The stacked layouts from top (first element) to bottom (last element). , _slayouts_compress_legend :: Bool @@ -522,7 +521,7 @@ where g = fullOverlayUnder (fillBackground bg emptyRenderable) $ foldr (above.mkGrid) nullt (zip sls [0,1..]) - + mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ()) mkGrid (sl, i) = titleR @@ -537,21 +536,21 @@ legendR = case sl of StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems - + legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of (False,_) -> case sl of StackedLayout l -> (getLegendItems l, []) StackedLayoutLR l -> getLegendItemsLR l (True,True) -> allLegendItems (True,False) -> ([],[]) - + mkPlotArea :: LayoutAxis x -> Grid (Renderable ()) mkPlotArea axis = case sl of - StackedLayout l -> fmap noPickFn - $ layoutPlotAreaToGrid + StackedLayout l -> fmap noPickFn + $ layoutPlotAreaToGrid $ l { _layout_x_axis = axis } - StackedLayoutLR l -> fmap noPickFn - $ layoutLRPlotAreaToGrid + StackedLayoutLR l -> fmap noPickFn + $ layoutLRPlotAreaToGrid $ l { _layoutlr_x_axis = axis } showLegend = not (null (fst legenditems)) || not (null (snd legenditems)) @@ -561,37 +560,37 @@ lm = case sl of StackedLayout l -> _layout_margin l StackedLayoutLR l -> _layoutlr_margin l - + xAxis :: LayoutAxis x xAxis = case sl of StackedLayout l -> _layout_x_axis l StackedLayoutLR l -> _layoutlr_x_axis l - + usedAxis :: LayoutAxis x - usedAxis = xAxis + usedAxis = xAxis { _laxis_generate = const (_laxis_generate xAxis all_xvals) } - + bg = case sl1 of StackedLayout l -> _layout_background l StackedLayoutLR l -> _layoutlr_background l - + getXVals :: StackedLayout x -> [x] getXVals (StackedLayout l) = getLayoutXVals l getXVals (StackedLayoutLR l) = getLayoutLRXVals l - + all_xvals = concatMap getXVals sls allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) - + legendItems :: StackedLayout x -> ([LegendItem], [LegendItem]) legendItems (StackedLayout l) = (getLegendItems l, []) legendItems (StackedLayoutLR l) = getLegendItemsLR l - + noPickFn :: Renderable a -> Renderable () noPickFn = mapPickFn (const ()) ---------------------------------------------------------------------- - + addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [ @@ -623,7 +622,7 @@ data LayoutGridElements x yl yr = LayoutGridElements { lge_plots :: Renderable (LayoutPick x yl yr), - + lge_taxis :: (Maybe (AxisT x),String,FontStyle), lge_baxis :: (Maybe (AxisT x),String,FontStyle), lge_laxis :: (Maybe (AxisT yl),String,FontStyle), @@ -660,7 +659,7 @@ (btitle,_) = mktitle HTA_Centre VTA_Top 0 blbl bstyle LayoutPick_XBottomAxisTitle (ltitle,lam) = mktitle HTA_Right VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle (rtitle,ram) = mktitle HTA_Left VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle - + baxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata taxis = tval $ maybe emptyRenderable @@ -675,10 +674,10 @@ tr = tval $ axesSpacer snd tdata fst rdata br = tval $ axesSpacer snd bdata snd rdata - mktitle :: HTextAnchor -> VTextAnchor + mktitle :: HTextAnchor -> VTextAnchor -> Double -> String -> FontStyle - -> (String -> LayoutPick x yl yr) + -> (String -> LayoutPick x yl yr) -> ( Grid (Renderable (LayoutPick x yl yr)) , Grid (Renderable (LayoutPick x yl yr)) ) mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG) @@ -713,7 +712,7 @@ in _plot_render p pmfn renderSinglePlot _ _ _ _ = return () -axesSpacer :: (Ord x, Ord y) +axesSpacer :: (Ord x, Ord y) => ((Double, Double) -> Double) -> Maybe (AxisT x) -> ((Double, Double) -> Double) -> Maybe (AxisT y) -> Renderable a @@ -722,12 +721,12 @@ oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) --- | Construct a axis for the given edge using the attributes +-- | Construct a axis for the given edge using the attributes -- from a 'LayoutAxis' the given values. mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z) -mkAxis edge laxis vals = case axisVisible of - False -> Nothing - True -> Just $ AxisT edge style rev adata +mkAxis edge laxis vals = if axisVisible + then Just $ AxisT edge style rev adata + else Nothing where style = _laxis_style laxis rev = _laxis_reverse laxis @@ -736,13 +735,13 @@ axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis -- | Override the visibility of a selected axis with the selected 'AxisVisibility'. -overrideAxisVisibility :: layout - -> (layout -> LayoutAxis z) - -> (layout -> AxisVisibility) - -> LayoutAxis z -overrideAxisVisibility ly selAxis selVis = +overrideAxisVisibility :: layout + -> (layout -> LayoutAxis z) + -> (layout -> AxisVisibility) + -> LayoutAxis z +overrideAxisVisibility ly selAxis selVis = let vis = selVis ly - in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) + in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) . _laxis_override (selAxis ly) } @@ -750,7 +749,7 @@ mfill Nothing = id mfill (Just fs) = fillBackground fs --- | Empty 'LayoutLR' without title and plots. The background is white and +-- | Empty 'LayoutLR' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- axis will not be visible. instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where @@ -772,7 +771,7 @@ , _layoutlr_left_axis_visibility = def , _layoutlr_right_axis = def , _layoutlr_right_axis_visibility = def - + , _layoutlr_plots = [] , _layoutlr_legend = Just def @@ -800,19 +799,19 @@ -- | Setter to update all axis styles on a `Layout` layout_axes_styles :: Setter' (Layout x y) AxisStyle -layout_axes_styles = sets $ \af -> +layout_axes_styles = sets $ \af -> (layout_x_axis . laxis_style %~ af) . - (layout_y_axis . laxis_style %~ af) + (layout_y_axis . laxis_style %~ af) -- | Setter to update all the axes title styles on a `Layout` layout_axes_title_styles :: Setter' (Layout x y) FontStyle -layout_axes_title_styles = sets $ \af -> +layout_axes_title_styles = sets $ \af -> (layout_x_axis . laxis_title_style %~ af) . (layout_y_axis . laxis_title_style %~ af) -- | Setter to update all the font styles on a `Layout` layout_all_font_styles :: Setter' (Layout x y) FontStyle -layout_all_font_styles = sets $ \af -> +layout_all_font_styles = sets $ \af -> (layout_axes_title_styles %~ af) . (layout_x_axis . laxis_style . axis_label_style %~ af) . (layout_y_axis . laxis_style . axis_label_style %~ af) . @@ -823,25 +822,25 @@ layout_foreground :: Setter' (Layout x y) (AlphaColour Double) layout_foreground = sets $ \af -> (layout_all_font_styles . font_color %~ af) . - (layout_axes_styles . axis_line_style . line_color %~ af) + (layout_axes_styles . axis_line_style . line_color %~ af) -- | Setter to update all axis styles on a `LayoutLR` layoutlr_axes_styles :: Setter' (LayoutLR x y1 y2) AxisStyle -layoutlr_axes_styles = sets $ \af -> +layoutlr_axes_styles = sets $ \af -> (layoutlr_x_axis . laxis_style %~ af) . (layoutlr_left_axis . laxis_style %~ af) . (layoutlr_right_axis . laxis_style %~ af) -- | Setter to update all the axes title styles on a `LayoutLR` layoutlr_axes_title_styles :: Setter' (LayoutLR x y1 y2) FontStyle -layoutlr_axes_title_styles = sets $ \af -> +layoutlr_axes_title_styles = sets $ \af -> (layoutlr_x_axis . laxis_title_style %~ af) . (layoutlr_left_axis . laxis_title_style %~ af) . (layoutlr_right_axis . laxis_title_style %~ af) -- | Setter to update all the font styles on a `LayoutLR` layoutlr_all_font_styles :: Setter' (LayoutLR x y1 y2) FontStyle -layoutlr_all_font_styles = sets $ \af -> +layoutlr_all_font_styles = sets $ \af -> (layoutlr_axes_title_styles %~ af) . (layoutlr_x_axis . laxis_style . axis_label_style %~ af) . (layoutlr_left_axis . laxis_style . axis_label_style %~ af) . @@ -853,4 +852,4 @@ layoutlr_foreground :: Setter' (LayoutLR x y1 y2) (AlphaColour Double) layoutlr_foreground = sets $ \af -> (layoutlr_all_font_styles . font_color %~ af) . - (layoutlr_axes_styles . axis_line_style . line_color %~ af) + (layoutlr_axes_styles . axis_line_style . line_color %~ af) diff --git a/Graphics/Rendering/Chart/Plot/Annotation.hs b/Graphics/Rendering/Chart/Plot/Annotation.hs --- a/Graphics/Rendering/Chart/Plot/Annotation.hs +++ b/Graphics/Rendering/Chart/Plot/Annotation.hs @@ -16,15 +16,19 @@ plot_annotation_angle, plot_annotation_style, plot_annotation_background, + plot_annotation_offset, plot_annotation_values ) where import Control.Lens +import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types -import Data.Default.Class +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Plot.Types -- | Value for describing a series of text annotations -- to be placed at arbitrary points on the graph. Annotations @@ -40,6 +44,7 @@ -- ^ Rectangle which style determines the background of the annotation -- text and which '_rect_minsize' determines the additional width and -- height of the background area + _plot_annotation_offset :: Vector, _plot_annotation_values :: [(x,y,String)] } @@ -63,6 +68,7 @@ values = _plot_annotation_values p angle = _plot_annotation_angle p style = _plot_annotation_style p + offset = _plot_annotation_offset p rectangle = _plot_annotation_background p (x1,y1) = _rect_minsize rectangle drawRect (x,y,s) = do @@ -77,18 +83,19 @@ yvp VTA_Centre = y3 - (y1 + y2) / 2 yvp VTA_Bottom = y3 - y2 - y1 / 2 yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts - drawRectangle (Point (xvp hta) (yvp vta)) rectangle{ _rect_minsize = (x1+x2,y1+y2) } + drawRectangle (Point (xvp hta) (yvp vta) `pvadd` offset) rectangle{ _rect_minsize = (x1+x2,y1+y2) } drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s - point x y = pMap (LValue x, LValue y) + point x y = pMap (LValue x, LValue y) `pvadd` offset instance Default (PlotAnnotation x y) where - def = PlotAnnotation + def = PlotAnnotation { _plot_annotation_hanchor = HTA_Centre , _plot_annotation_vanchor = VTA_Centre , _plot_annotation_angle = 0 , _plot_annotation_style = def , _plot_annotation_background = def , _plot_annotation_values = [] + , _plot_annotation_offset = Vector 0 0 } $( makeLenses ''PlotAnnotation ) diff --git a/Graphics/Rendering/Chart/Plot/Bars.hs b/Graphics/Rendering/Chart/Plot/Bars.hs --- a/Graphics/Rendering/Chart/Plot/Bars.hs +++ b/Graphics/Rendering/Chart/Plot/Bars.hs @@ -7,6 +7,7 @@ -- Bar Charts -- {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Plot.Bars( PlotBars(..), @@ -14,41 +15,70 @@ PlotBarsSpacing(..), PlotBarsAlignment(..), BarsPlotValue(..), + BarHorizAnchor(..), + BarVertAnchor(..), plotBars, + plotHBars, + plot_bars_style, plot_bars_item_styles, plot_bars_titles, plot_bars_spacing, plot_bars_alignment, - plot_bars_reference, plot_bars_singleton_width, + plot_bars_label_bar_hanchor, + plot_bars_label_bar_vanchor, + plot_bars_label_text_hanchor, + plot_bars_label_text_vanchor, + plot_bars_label_angle, + plot_bars_label_style, + plot_bars_label_offset, + plot_bars_values, + plot_bars_settings, + plot_bars_values_with_labels, + + addLabels ) where +import Control.Arrow import Control.Lens import Control.Monad -import Data.List(nub,sort) -import Graphics.Rendering.Chart.Geometry hiding (x0, y0) -import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Plot.Types -import Graphics.Rendering.Chart.Axis import Data.Colour (opaque) import Data.Colour.Names (black) import Data.Default.Class - +import Data.Tuple(swap) +import Data.List(nub,sort) +import Graphics.Rendering.Chart.Axis +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Geometry hiding (x0, y0) +import Graphics.Rendering.Chart.Plot.Types +import Graphics.Rendering.Chart.Utils class PlotValue a => BarsPlotValue a where - barsReference :: a + barsIsNull :: a -> Bool + -- | The starting level for the chart, a function of some statistic + -- (normally the lowest value or just const 0). + barsReference :: [a] -> a barsAdd :: a -> a -> a instance BarsPlotValue Double where - barsReference = 0 + barsIsNull a = a == 0.0 + barsReference = const 0 barsAdd = (+) + instance BarsPlotValue Int where - barsReference = 0 + barsIsNull a = a == 0 + barsReference = const 0 barsAdd = (+) +instance BarsPlotValue LogValue where + barsIsNull (LogValue a) = a == 0.0 + barsReference as = + 10.0 ^^ (floor (log10 $ minimum $ filter (/= 0.0) as) :: Integer) + barsAdd = (+) + data PlotBarsStyle = BarsStacked -- ^ Bars for a fixed x are stacked vertically -- on top of each other. @@ -70,148 +100,312 @@ | BarsRight -- ^ The right edge of bars is at deviceX deriving (Show) +data BarHorizAnchor + = BHA_Left + | BHA_Centre + | BHA_Right + deriving (Show) + +data BarVertAnchor + = BVA_Bottom + | BVA_Centre + | BVA_Top + deriving (Show) + -- | Value describing how to plot a set of bars. -- Note that the input data is typed [(x,[y])], ie for each x value -- we plot several y values. Typically the size of each [y] list would -- be the same. -data PlotBars x y = PlotBars { +data BarsSettings = BarsSettings { -- | This value specifies whether each value from [y] should be -- shown beside or above the previous value. - _plot_bars_style :: PlotBarsStyle, + _bars_settings_style :: PlotBarsStyle, -- | The style in which to draw each element of [y]. A fill style -- is required, and if a linestyle is given, each bar will be -- outlined. - _plot_bars_item_styles :: [ (FillStyle,Maybe LineStyle) ], - - -- | The title of each element of [y]. These will be shown in the legend. - _plot_bars_titles :: [String], + _bars_settings_item_styles :: [ (FillStyle,Maybe LineStyle) ], -- | This value controls how the widths of the bars are -- calculated. Either the widths of the bars, or the gaps between -- them can be fixed. - _plot_bars_spacing :: PlotBarsSpacing, + _bars_settings_spacing :: PlotBarsSpacing, -- | This value controls how bars for a fixed x are aligned with -- respect to the device coordinate corresponding to x. - _plot_bars_alignment :: PlotBarsAlignment, + _bars_settings_alignment :: PlotBarsAlignment, - -- | The starting level for the chart (normally 0). - _plot_bars_reference :: y, + _bars_settings_singleton_width :: Double, - _plot_bars_singleton_width :: Double, + -- | The point on the bar to horizontally anchor the label to + _bars_settings_label_bar_hanchor :: BarHorizAnchor, - -- | The actual points to be plotted. - _plot_bars_values :: [ (x,[y]) ] -} + -- | The point on the bar to vertically anchor the label to + _bars_settings_label_bar_vanchor :: BarVertAnchor, -instance BarsPlotValue y => Default (PlotBars x y) where - def = PlotBars - { _plot_bars_style = BarsClustered - , _plot_bars_item_styles = cycle istyles - , _plot_bars_titles = [] - , _plot_bars_spacing = BarsFixGap 10 2 - , _plot_bars_alignment = BarsCentered - , _plot_bars_values = [] - , _plot_bars_singleton_width = 20 - , _plot_bars_reference = barsReference + -- | The anchor point on the label. + _bars_settings_label_text_hanchor :: HTextAnchor, + + -- | The anchor point on the label. + _bars_settings_label_text_vanchor :: VTextAnchor, + + -- | Angle, in degrees, to rotate the label about the anchor point. + _bars_settings_label_angle :: Double, + + -- | The style to use for the label. + _bars_settings_label_style :: FontStyle, + + -- | The offset from the anchor point to display the label at. + _bars_settings_label_offset :: Vector +} +instance Default BarsSettings where + def = BarsSettings + { _bars_settings_style = BarsClustered + , _bars_settings_item_styles = cycle istyles + , _bars_settings_spacing = BarsFixGap 10 2 + , _bars_settings_alignment = BarsCentered + , _bars_settings_singleton_width = 20 + , _bars_settings_label_bar_hanchor = BHA_Centre + , _bars_settings_label_bar_vanchor = BVA_Top + , _bars_settings_label_text_hanchor = HTA_Centre + , _bars_settings_label_text_vanchor = VTA_Bottom + , _bars_settings_label_angle = 0 + , _bars_settings_label_style = def + , _bars_settings_label_offset = Vector 0 0 } where istyles = map mkstyle defaultColorSeq mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black)) +data PlotBars x y = PlotBars { + _plot_bars_settings :: BarsSettings, + -- | The title of each element of [y]. These will be shown in the legend. + _plot_bars_titles :: [String], + -- | The actual points to be plotted, and their labels + _plot_bars_values_with_labels :: [(x, [(y, String)])] +} +instance Default (PlotBars x y) where + def = PlotBars + { _plot_bars_settings = def + , _plot_bars_titles = [] + , _plot_bars_values_with_labels = [] + } plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot { - _plot_render = renderPlotBars p, + _plot_render = \pmap -> renderBars s vals yref0 + (barRect pmap) (mapX pmap), _plot_legend = zip (_plot_bars_titles p) (map renderPlotLegendBars - (_plot_bars_item_styles p)), - _plot_all_points = allBarPoints p + (_bars_settings_item_styles s)), + _plot_all_points = allBarPoints s vals } + where + s = _plot_bars_settings p + vals = _plot_bars_values_with_labels p + yref0 = refVal s vals -renderPlotBars :: (BarsPlotValue y) => PlotBars x y -> PointMapFn x y -> BackendProgram () -renderPlotBars p pmap = case _plot_bars_style p of + barRect pmap xos width x y0 y1 = Rect (Point (x'+xos) y0') (Point (x'+xos+width) y') where + Point x' y' = mapXY pmap (x,y1) + Point _ y0' = mapXY pmap (x,y0) + + mapX pmap x = p_x (mapXY pmap (x, yref0)) + +plotHBars :: (BarsPlotValue x) => PlotBars y x -> Plot x y +plotHBars p = Plot { + _plot_render = \pmap -> renderBars s vals xref0 + (barRect pmap) (mapY pmap), + _plot_legend = zip (_plot_bars_titles p) + (map renderPlotLegendBars + (_bars_settings_item_styles s)), + _plot_all_points = swap $ allBarPoints s vals + } + where + s = _plot_bars_settings p + vals = _plot_bars_values_with_labels p + xref0 = refVal s vals + + barRect pmap yos height y x0 x1 = Rect (Point x0' (y'+yos)) (Point x' (y'+yos+height)) where + Point x' y' = mapXY pmap (x1,y) + Point x0' _ = mapXY pmap (x0,y) + + mapY pmap y = p_y (mapXY pmap (xref0, y)) + +renderBars :: (BarsPlotValue v) => + BarsSettings + -> [(k, [(v, String)])] + -> v + -> (Double -> Double -> k -> v -> v -> Rect) + -> (k -> Double) + -> BackendProgram () +renderBars p vals vref0 r mapk = case _bars_settings_style p of BarsClustered -> forM_ vals clusteredBars BarsStacked -> forM_ vals stackedBars where - clusteredBars (x,ys) = do - forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> - withFillStyle fstyle $ - alignFillPath (barPath (offset i) x yref0 y) + clusteredBars (k,vs) = do + let offset i = case _bars_settings_alignment p of + BarsLeft -> fromIntegral i * bsize + BarsRight -> fromIntegral (i-nvs) * bsize + BarsCentered -> fromIntegral (2*i-nvs) * bsize/2 + forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (fstyle,_)) -> + unless (barsIsNull v) $ + withFillStyle fstyle $ + alignFillPath (barPath (offset i) k vref0 v) >>= fillPath - forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> - whenJust mlstyle $ \lstyle -> - withLineStyle lstyle $ - alignStrokePath (barPath (offset i) x yref0 y) + forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (_,mlstyle)) -> + unless (barsIsNull v) $ + whenJust mlstyle $ \lstyle -> + withLineStyle lstyle $ + alignStrokePath (barPath (offset i) k vref0 v) >>= strokePath - - offset = case _plot_bars_alignment p of - BarsLeft -> \i -> fromIntegral i * width - BarsRight -> \i -> fromIntegral (i-nys) * width - BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2 + withFontStyle (_bars_settings_label_style p) $ + forM_ (zip [0,1..] vs) $ \(i, (v, txt)) -> + unless (null txt) $ do + let ha = _bars_settings_label_bar_hanchor p + let va = _bars_settings_label_bar_vanchor p + let pt = rectCorner ha va (r (offset i) bsize k vref0 v) + drawTextR + (_bars_settings_label_text_hanchor p) + (_bars_settings_label_text_vanchor p) + (_bars_settings_label_angle p) + (pvadd pt $ _bars_settings_label_offset p) + txt - stackedBars (x,ys) = do - let y2s = zip (yref0:stack ys) (stack ys) - let ofs = case _plot_bars_alignment p of + stackedBars (k,vs) = do + let (vs', lbls) = unzip vs + let vs'' = map (\v -> if barsIsNull v then vref0 else v) (stack vs') + let v2s = zip (vref0:vs'') vs'' + let ofs = case _bars_settings_alignment p of BarsLeft -> 0 - BarsRight -> -width - BarsCentered -> -(width/2) - forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> - withFillStyle fstyle $ - alignFillPath (barPath ofs x y0 y1) + BarsRight -> -bsize + BarsCentered -> -(bsize/2) + forM_ (zip v2s styles) $ \((v0,v1), (fstyle,_)) -> + unless (v0 >= v1) $ + withFillStyle fstyle $ + alignFillPath (barPath ofs k v0 v1) >>= fillPath - forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> - whenJust mlstyle $ \lstyle -> - withLineStyle lstyle $ - alignStrokePath (barPath ofs x y0 y1) + forM_ (zip v2s styles) $ \((v0,v1), (_,mlstyle)) -> + unless (v0 >= v1) $ + whenJust mlstyle $ \lstyle -> + withLineStyle lstyle $ + alignStrokePath (barPath ofs k v0 v1) >>= strokePath + withFontStyle (_bars_settings_label_style p) $ + forM_ (zip v2s lbls) $ \((v0, v1), txt) -> + unless (null txt) $ do + let ha = _bars_settings_label_bar_hanchor p + let va = _bars_settings_label_bar_vanchor p + let pt = rectCorner ha va (r ofs bsize k v0 v1) + drawTextR + (_bars_settings_label_text_hanchor p) + (_bars_settings_label_text_vanchor p) + (_bars_settings_label_angle p) + (pvadd pt $ _bars_settings_label_offset p) + txt - barPath xos x y0 y1 = do - let (Point x' y') = pmap' (x,y1) - let (Point _ y0') = pmap' (x,y0) - rectPath (Rect (Point (x'+xos) y0') (Point (x'+xos+width) y')) + styles = _bars_settings_item_styles p - yref0 = _plot_bars_reference p - vals = _plot_bars_values p - width = case _plot_bars_spacing p of - BarsFixGap gap minw -> let w = max (minXInterval - gap) minw in - case _plot_bars_style p of - BarsClustered -> w / fromIntegral nys + barPath os k v0 v1 = rectPath $ r os bsize k v0 v1 + + bsize = case _bars_settings_spacing p of + BarsFixGap gap minw -> let w = max (minKInterval - gap) minw in + case _bars_settings_style p of + BarsClustered -> w / fromIntegral nvs BarsStacked -> w BarsFixWidth width' -> width' - styles = _plot_bars_item_styles p - minXInterval = let diffs = zipWith (-) (tail mxs) mxs + minKInterval = let diffs = zipWith (-) (tail mks) mks in if null diffs - then _plot_bars_singleton_width p + then _bars_settings_singleton_width p else minimum diffs where - xs = fst (allBarPoints p) - mxs = nub $ sort $ map mapX xs + mks = nub $ sort $ map (mapk . fst) vals - nys = maximum [ length ys | (_,ys) <- vals ] + nvs = maximum $ map (length . snd) vals - pmap' = mapXY pmap - mapX x = p_x (pmap' (x,barsReference)) +rectCorner :: BarHorizAnchor -> BarVertAnchor -> Rect -> Point +rectCorner h v (Rect (Point x0 y0) (Point x1 y1)) = Point x' y' where + x' = case h of + BHA_Left -> x0 + BHA_Right -> x1 + BHA_Centre -> (x0 + x1) / 2 + y' = case v of + BVA_Bottom -> y0 + BVA_Top -> y1 + BVA_Centre -> (y0 + y1) / 2 -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) f = f a -whenJust _ _ = return () +-- Helper function for printing bar values as labels +addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])] +addLabels = map . second $ map (\y -> (y, show y)) -allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y]) -allBarPoints p = case _plot_bars_style p of - BarsClustered -> ( [x| (x,_) <- pts], y0:concat [ys| (_,ys) <- pts] ) - BarsStacked -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] ) - where - pts = _plot_bars_values p - y0 = _plot_bars_reference p +refVal :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> y +refVal p vals = barsReference $ case _bars_settings_style p of + BarsClustered -> concatMap (map fst . snd) vals + BarsStacked -> concatMap (take 1 . dropWhile barsIsNull . stack . map fst . snd) vals +allBarPoints :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> ([x],[y]) +allBarPoints p vals = case _bars_settings_style p of + BarsClustered -> + let ys = concatMap (map fst) yls in + ( xs, barsReference ys:ys ) + BarsStacked -> + let ys = map (stack . map fst) yls in + ( xs, barsReference (concatMap (take 1 . dropWhile barsIsNull) ys):concat ys) + where (xs, yls) = unzip vals + stack :: (BarsPlotValue y) => [y] -> [y] stack = scanl1 barsAdd renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> BackendProgram () -renderPlotLegendBars (fstyle,_) r = - withFillStyle fstyle $ +renderPlotLegendBars (fstyle,_) r = + withFillStyle fstyle $ fillPath (rectPath r) +$( makeLenses ''BarsSettings ) $( makeLenses ''PlotBars ) + +-- Lens provided for backward compat. + +-- Note that this one does not satisfy the lens laws, as it discards/overwrites the labels. +plot_bars_values :: Lens' (PlotBars x y) [(x, [y])] +plot_bars_values = lens getter setter + where + getter = mapYs fst . _plot_bars_values_with_labels + setter pb vals' = pb { _plot_bars_values_with_labels = mapYs (, "") vals' } + mapYs :: (a -> b) -> [(c, [a])] -> [(c, [b])] + mapYs f = map (over _2 $ map f) + +plot_bars_style :: Lens' (PlotBars x y) PlotBarsStyle +plot_bars_style = plot_bars_settings . bars_settings_style + +plot_bars_item_styles :: Lens' (PlotBars x y) [(FillStyle, Maybe LineStyle)] +plot_bars_item_styles = plot_bars_settings . bars_settings_item_styles + +plot_bars_spacing :: Lens' (PlotBars x y) PlotBarsSpacing +plot_bars_spacing = plot_bars_settings . bars_settings_spacing + +plot_bars_alignment :: Lens' (PlotBars x y) PlotBarsAlignment +plot_bars_alignment = plot_bars_settings . bars_settings_alignment + +plot_bars_singleton_width :: Lens' (PlotBars x y) Double +plot_bars_singleton_width = plot_bars_settings . bars_settings_singleton_width + +plot_bars_label_bar_hanchor :: Lens' (PlotBars x y) BarHorizAnchor +plot_bars_label_bar_hanchor = plot_bars_settings . bars_settings_label_bar_hanchor + +plot_bars_label_bar_vanchor :: Lens' (PlotBars x y) BarVertAnchor +plot_bars_label_bar_vanchor = plot_bars_settings . bars_settings_label_bar_vanchor + +plot_bars_label_text_hanchor :: Lens' (PlotBars x y) HTextAnchor +plot_bars_label_text_hanchor = plot_bars_settings . bars_settings_label_text_hanchor + +plot_bars_label_text_vanchor :: Lens' (PlotBars x y) VTextAnchor +plot_bars_label_text_vanchor = plot_bars_settings . bars_settings_label_text_vanchor + +plot_bars_label_angle :: Lens' (PlotBars x y) Double +plot_bars_label_angle = plot_bars_settings . bars_settings_label_angle + +plot_bars_label_style :: Lens' (PlotBars x y) FontStyle +plot_bars_label_style = plot_bars_settings . bars_settings_label_style + +plot_bars_label_offset :: Lens' (PlotBars x y) Vector +plot_bars_label_offset = plot_bars_settings . bars_settings_label_offset diff --git a/Graphics/Rendering/Chart/Plot/Candle.hs b/Graphics/Rendering/Chart/Plot/Candle.hs --- a/Graphics/Rendering/Chart/Plot/Candle.hs +++ b/Graphics/Rendering/Chart/Plot/Candle.hs @@ -24,7 +24,6 @@ ) where import Control.Lens hiding (op) -import Data.Monoid import Graphics.Rendering.Chart.Geometry hiding (close) import Graphics.Rendering.Chart.Drawing @@ -75,7 +74,7 @@ pts = _plot_candle_values p renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> BackendProgram () -renderPlotCandle p pmap = +renderPlotCandle p pmap = mapM_ (drawCandle p . candlemap) (_plot_candle_values p) where candlemap (Candle x lo op mid cl hi) = @@ -96,7 +95,7 @@ -- the pixel coordinate system is inverted wrt the value coords. when f $ withFillStyle (if open >= close then _plot_candle_rise_fill_style ps - else _plot_candle_fall_fill_style ps) $ + else _plot_candle_fall_fill_style ps) $ fillPath $ moveTo' (x-wd) open <> lineTo' (x-wd) close <> lineTo' (x+wd) close @@ -119,7 +118,7 @@ <> lineTo' (x+tl) lo <> moveTo' (x-tl) hi <> lineTo' (x+tl) hi - + when (ct > 0) $ strokePath $ moveTo' (x-ct) mid <> lineTo' (x+ct) mid @@ -137,7 +136,7 @@ close = (mid + hi) / 2 instance Default (PlotCandle x y) where - def = PlotCandle + def = PlotCandle { _plot_candle_title = "" , _plot_candle_line_style = solidLine 1 $ opaque blue , _plot_candle_fill = False diff --git a/Graphics/Rendering/Chart/Plot/ErrBars.hs b/Graphics/Rendering/Chart/Plot/ErrBars.hs --- a/Graphics/Rendering/Chart/Plot/ErrBars.hs +++ b/Graphics/Rendering/Chart/Plot/ErrBars.hs @@ -25,7 +25,6 @@ ) where import Control.Lens -import Data.Monoid import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing @@ -76,7 +75,7 @@ pts = _plot_errbars_values p renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> BackendProgram () -renderPlotErrBars p pmap = +renderPlotErrBars p pmap = mapM_ (drawErrBar.epmap) (_plot_errbars_values p) where epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = @@ -91,7 +90,7 @@ drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do let tl = _plot_errbars_tick_length ps let oh = _plot_errbars_overhang ps - withLineStyle (_plot_errbars_line_style ps) $ + withLineStyle (_plot_errbars_line_style ps) $ strokePath $ moveTo' (xl-oh) y <> lineTo' (xh+oh) y <> moveTo' x (yl-oh) @@ -117,7 +116,7 @@ y = (p_y p1 + p_y p2)/2 instance Default (PlotErrBars x y) where - def = PlotErrBars + def = PlotErrBars { _plot_errbars_title = "" , _plot_errbars_line_style = solidLine 1 $ opaque blue , _plot_errbars_tick_length = 3 diff --git a/Graphics/Rendering/Chart/Plot/Histogram.hs b/Graphics/Rendering/Chart/Plot/Histogram.hs --- a/Graphics/Rendering/Chart/Plot/Histogram.hs +++ b/Graphics/Rendering/Chart/Plot/Histogram.hs @@ -7,6 +7,7 @@ , defaultPlotHist , defaultFloatPlotHist , defaultNormedPlotHist + , histToBins -- * Accessors , plot_hist_title , plot_hist_bins @@ -20,7 +21,6 @@ ) where import Control.Monad (when) -import Data.Monoid import Data.Maybe (fromMaybe) import qualified Data.Foldable as F import qualified Data.Vector as V @@ -161,6 +161,7 @@ let y = (p_y p1 + p_y p2) / 2 in strokePath $ moveTo' (p_x p1) y <> lineTo' (p_x p2) y +-- | Obtain the bin dimensions of a given @PlotHist@. histToBins :: (RealFrac x, Num y, Ord y) => PlotHist x y -> [((x,x), y)] histToBins hist = filter_zeros $ zip bounds $ counts diff --git a/Graphics/Rendering/Chart/Plot/Pie.hs b/Graphics/Rendering/Chart/Plot/Pie.hs --- a/Graphics/Rendering/Chart/Plot/Pie.hs +++ b/Graphics/Rendering/Chart/Plot/Pie.hs @@ -1,229 +1,228 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Plot.Pie --- Copyright : (c) Tim Docker 2008, 2014 --- License : BSD-style (see chart/COPYRIGHT) --- --- A basic pie chart. --- --- Pie charts are handled different to other plots, in that they --- have their own layout, and can't be composed with other plots. A --- pie chart is rendered with code in the following form: --- --- @ --- values :: [PieItem] --- values = [...] --- layout :: PieLayout --- layout = pie_plot ^: pie_data ^= values --- $ def --- renderable = toRenderable layout --- @ -{-# LANGUAGE TemplateHaskell #-} - -module Graphics.Rendering.Chart.Plot.Pie( - PieLayout(..), - PieChart(..), - PieItem(..), - - pieToRenderable, - pieChartToRenderable, - - pie_title, - pie_title_style, - pie_plot, - pie_background, - pie_margin, - pie_data, - pie_colors, - pie_label_style, - pie_label_line_style, - pie_start_angle, - pitem_label, - pitem_offset, - pitem_value, - -) where --- original code thanks to Neal Alexander - --- see ../Drawing.hs for why we do not use hiding (moveTo) for --- lens < 4 -import Control.Lens -import Data.Colour -import Data.Colour.Names (white) -import Data.Monoid -import Data.Default.Class -import Control.Monad - -import Graphics.Rendering.Chart.Geometry hiding (moveTo) -import qualified Graphics.Rendering.Chart.Geometry as G -import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Grid - -data PieLayout = PieLayout { - _pie_title :: String, - _pie_title_style :: FontStyle, - _pie_plot :: PieChart, - _pie_background :: FillStyle, - _pie_margin :: Double -} - -data PieChart = PieChart { - _pie_data :: [PieItem], - _pie_colors :: [AlphaColour Double], - _pie_label_style :: FontStyle, - _pie_label_line_style :: LineStyle, - _pie_start_angle :: Double - -} - -data PieItem = PieItem { - _pitem_label :: String, - _pitem_offset :: Double, - _pitem_value :: Double -} - -instance Default PieChart where - def = PieChart - { _pie_data = [] - , _pie_colors = defaultColorSeq - , _pie_label_style = def - , _pie_label_line_style = solidLine 1 $ opaque black - , _pie_start_angle = 0 - } - -instance Default PieItem where - def = PieItem "" 0 0 - -instance Default PieLayout where - def = PieLayout - { _pie_background = solidFillStyle $ opaque white - , _pie_title = "" - , _pie_title_style = def { _font_size = 15 - , _font_weight = FontWeightBold } - , _pie_plot = def - , _pie_margin = 10 - } - -instance ToRenderable PieLayout where - toRenderable = setPickFn nullPickFn . pieToRenderable - -pieChartToRenderable :: PieChart -> Renderable (PickFn a) -pieChartToRenderable p = Renderable { minsize = minsizePie p - , render = renderPie p - } - -instance ToRenderable PieChart where - toRenderable = setPickFn nullPickFn . pieChartToRenderable - -pieToRenderable :: PieLayout -> Renderable (PickFn a) -pieToRenderable p = fillBackground (_pie_background p) ( - gridToRenderable $ aboveN - [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title) - , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) - (pieChartToRenderable $ _pie_plot p) - ] ) - where - title = label (_pie_title_style p) HTA_Centre VTA_Top (_pie_title p) - lm = _pie_margin p - -extraSpace :: PieChart -> BackendProgram (Double, Double) -extraSpace p = do - textSizes <- mapM (textDimension . _pitem_label) (_pie_data p) - let maxw = foldr (max.fst) 0 textSizes - let maxh = foldr (max.snd) 0 textSizes - let maxo = foldr (max._pitem_offset) 0 (_pie_data p) - let extra = label_rgap + label_rlength + maxo - return (extra + maxw, extra + maxh ) - -minsizePie :: PieChart -> BackendProgram (Double, Double) -minsizePie p = do - (extraw,extrah) <- extraSpace p - return (extraw * 2, extrah * 2) - -renderPie :: PieChart -> (Double, Double) -> BackendProgram (PickFn a) -renderPie p (w,h) = do - (extraw,extrah) <- extraSpace p - -- let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1) - -- let center = Point (p_x p1 + w/2) (p_y p1 + h/2) - -- - let center = Point (w/2) (h/2) - let radius = min (w - 2*extraw) (h - 2*extrah) / 2 - - foldM_ (paint center radius) (_pie_start_angle p) - (zip (_pie_colors p) content) - return nullPickFn - - where - -- p1 = Point 0 0 - -- p2 = Point w h - content = let total = sum (map _pitem_value (_pie_data p)) - in [ pitem{_pitem_value=_pitem_value pitem/total} - | pitem <- _pie_data p ] - - paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) - -> BackendProgram Double - paint center radius a1 (color,pitem) = do - let ax = 360.0 * _pitem_value pitem - let a2 = a1 + (ax / 2) - let a3 = a1 + ax - let offset = _pitem_offset pitem - - pieSlice (ray a2 offset) a1 a3 color - pieLabel (_pitem_label pitem) a2 offset - - return a3 - - where - pieLabel :: String -> Double -> Double -> BackendProgram () - pieLabel name angle offset = - withFontStyle (_pie_label_style p) $ - withLineStyle (_pie_label_line_style p) $ do - let p1 = ray angle (radius+label_rgap+label_rlength+offset) - p1a <- alignStrokePoint p1 - (tw,_) <- textDimension name - let (offset',anchor) = if angle < 90 || angle > 270 - then ((0+),HTA_Left) - else ((0-),HTA_Right) - p0 <- alignStrokePoint $ ray angle (radius + label_rgap+offset) - strokePath $ G.moveTo p0 - <> lineTo p1a - <> lineTo' (p_x p1a + offset' (tw + label_rgap)) (p_y p1a) - - let p2 = p1 `pvadd` Vector (offset' label_rgap) 0 - drawTextA anchor VTA_Bottom p2 name - - pieSlice :: Point -> Double -> Double -> AlphaColour Double -> BackendProgram () - pieSlice (Point x y) arc1 arc2 pColor = do - let path = arc' x y radius (radian arc1) (radian arc2) - <> lineTo' x y - <> lineTo' x y - <> close - - withFillStyle (FillStyleSolid pColor) $ - fillPath path - withLineStyle (def { _line_color = withOpacity white 0.1 }) $ - strokePath path - - ray :: Double -> Double -> Point - ray angle r = Point x' y' - where - x' = x + (cos' * x'') - y' = y + (sin' * x'') - cos' = (cos . radian) angle - sin' = (sin . radian) angle - -- TODO: is x'' defined in this way to try and avoid - -- numerical rounding? - x'' = (x + r) - x - x = p_x center - y = p_y center - - radian = (*(pi / 180.0)) - -label_rgap, label_rlength :: Double -label_rgap = 5 -label_rlength = 15 - -$( makeLenses ''PieLayout ) -$( makeLenses ''PieChart ) -$( makeLenses ''PieItem ) +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Pie +-- Copyright : (c) Tim Docker 2008, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A basic pie chart. +-- +-- Pie charts are handled different to other plots, in that they +-- have their own layout, and can't be composed with other plots. A +-- pie chart is rendered with code in the following form: +-- +-- @ +-- values :: [PieItem] +-- values = [...] +-- layout :: PieLayout +-- layout = pie_plot ^: pie_data ^= values +-- $ def +-- renderable = toRenderable layout +-- @ +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Pie( + PieLayout(..), + PieChart(..), + PieItem(..), + + pieToRenderable, + pieChartToRenderable, + + pie_title, + pie_title_style, + pie_plot, + pie_background, + pie_margin, + pie_data, + pie_colors, + pie_label_style, + pie_label_line_style, + pie_start_angle, + pitem_label, + pitem_offset, + pitem_value, + +) where +-- original code thanks to Neal Alexander + +-- see ../Drawing.hs for why we do not use hiding (moveTo) for +-- lens < 4 +import Control.Lens +import Data.Colour +import Data.Colour.Names (white) +import Data.Default.Class +import Control.Monad + +import Graphics.Rendering.Chart.Geometry hiding (moveTo) +import qualified Graphics.Rendering.Chart.Geometry as G +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Grid + +data PieLayout = PieLayout { + _pie_title :: String, + _pie_title_style :: FontStyle, + _pie_plot :: PieChart, + _pie_background :: FillStyle, + _pie_margin :: Double +} + +data PieChart = PieChart { + _pie_data :: [PieItem], + _pie_colors :: [AlphaColour Double], + _pie_label_style :: FontStyle, + _pie_label_line_style :: LineStyle, + _pie_start_angle :: Double + +} + +data PieItem = PieItem { + _pitem_label :: String, + _pitem_offset :: Double, + _pitem_value :: Double +} + +instance Default PieChart where + def = PieChart + { _pie_data = [] + , _pie_colors = defaultColorSeq + , _pie_label_style = def + , _pie_label_line_style = solidLine 1 $ opaque black + , _pie_start_angle = 0 + } + +instance Default PieItem where + def = PieItem "" 0 0 + +instance Default PieLayout where + def = PieLayout + { _pie_background = solidFillStyle $ opaque white + , _pie_title = "" + , _pie_title_style = def { _font_size = 15 + , _font_weight = FontWeightBold } + , _pie_plot = def + , _pie_margin = 10 + } + +instance ToRenderable PieLayout where + toRenderable = setPickFn nullPickFn . pieToRenderable + +pieChartToRenderable :: PieChart -> Renderable (PickFn a) +pieChartToRenderable p = Renderable { minsize = minsizePie p + , render = renderPie p + } + +instance ToRenderable PieChart where + toRenderable = setPickFn nullPickFn . pieChartToRenderable + +pieToRenderable :: PieLayout -> Renderable (PickFn a) +pieToRenderable p = fillBackground (_pie_background p) ( + gridToRenderable $ aboveN + [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title) + , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) + (pieChartToRenderable $ _pie_plot p) + ] ) + where + title = label (_pie_title_style p) HTA_Centre VTA_Top (_pie_title p) + lm = _pie_margin p + +extraSpace :: PieChart -> BackendProgram (Double, Double) +extraSpace p = do + textSizes <- mapM (textDimension . _pitem_label) (_pie_data p) + let maxw = foldr (max.fst) 0 textSizes + let maxh = foldr (max.snd) 0 textSizes + let maxo = foldr (max._pitem_offset) 0 (_pie_data p) + let extra = label_rgap + label_rlength + maxo + return (extra + maxw, extra + maxh ) + +minsizePie :: PieChart -> BackendProgram (Double, Double) +minsizePie p = do + (extraw,extrah) <- extraSpace p + return (extraw * 2, extrah * 2) + +renderPie :: PieChart -> (Double, Double) -> BackendProgram (PickFn a) +renderPie p (w,h) = do + (extraw,extrah) <- extraSpace p + -- let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1) + -- let center = Point (p_x p1 + w/2) (p_y p1 + h/2) + -- + let center = Point (w/2) (h/2) + let radius = min (w - 2*extraw) (h - 2*extrah) / 2 + + foldM_ (paint center radius) (_pie_start_angle p) + (zip (_pie_colors p) content) + return nullPickFn + + where + -- p1 = Point 0 0 + -- p2 = Point w h + content = let total = sum (map _pitem_value (_pie_data p)) + in [ pitem{_pitem_value=_pitem_value pitem/total} + | pitem <- _pie_data p ] + + paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) + -> BackendProgram Double + paint center radius a1 (color,pitem) = do + let ax = 360.0 * _pitem_value pitem + let a2 = a1 + (ax / 2) + let a3 = a1 + ax + let offset = _pitem_offset pitem + + pieSlice (ray a2 offset) a1 a3 color + pieLabel (_pitem_label pitem) a2 offset + + return a3 + + where + pieLabel :: String -> Double -> Double -> BackendProgram () + pieLabel name angle offset = + withFontStyle (_pie_label_style p) $ + withLineStyle (_pie_label_line_style p) $ do + let p1 = ray angle (radius+label_rgap+label_rlength+offset) + p1a <- alignStrokePoint p1 + (tw,_) <- textDimension name + let (offset',anchor) = if angle < 90 || angle > 270 + then ((0+),HTA_Left) + else ((0-),HTA_Right) + p0 <- alignStrokePoint $ ray angle (radius + label_rgap+offset) + strokePath $ G.moveTo p0 + <> lineTo p1a + <> lineTo' (p_x p1a + offset' (tw + label_rgap)) (p_y p1a) + + let p2 = p1 `pvadd` Vector (offset' label_rgap) 0 + drawTextA anchor VTA_Bottom p2 name + + pieSlice :: Point -> Double -> Double -> AlphaColour Double -> BackendProgram () + pieSlice (Point x y) arc1 arc2 pColor = do + let path = arc' x y radius (radian arc1) (radian arc2) + <> lineTo' x y + <> lineTo' x y + <> close + + withFillStyle (FillStyleSolid pColor) $ + fillPath path + withLineStyle (def { _line_color = withOpacity white 0.1 }) $ + strokePath path + + ray :: Double -> Double -> Point + ray angle r = Point x' y' + where + x' = x + (cos' * x'') + y' = y + (sin' * x'') + cos' = (cos . radian) angle + sin' = (sin . radian) angle + -- TODO: is x'' defined in this way to try and avoid + -- numerical rounding? + x'' = (x + r) - x + x = p_x center + y = p_y center + + radian = (*(pi / 180.0)) + +label_rgap, label_rlength :: Double +label_rgap = 5 +label_rlength = 15 + +$( makeLenses ''PieLayout ) +$( makeLenses ''PieChart ) +$( makeLenses ''PieItem ) diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -17,7 +17,7 @@ PickFn, Rectangle(..), RectCornerStyle(..), - + rectangleToRenderable, drawRectangle, @@ -42,7 +42,6 @@ import Control.Monad import Control.Lens -import Data.Monoid import Data.Default.Class import Graphics.Rendering.Chart.Geometry @@ -84,7 +83,7 @@ emptyRenderable = spacer (0,0) -- | Create a blank renderable with a specified minimum size. -spacer :: RectSize -> Renderable a +spacer :: RectSize -> Renderable a spacer sz = Renderable { minsize = return sz, render = \_ -> return nullPickFn @@ -119,7 +118,7 @@ (w,h) <- minsize rd return (w+l+r,h+t+b) - rf (w,h) = + rf (w,h) = withTranslation (Point l t) $ do pickf <- render rd (w-l-r,h-t-b) return (mkpickf pickf (t,b,l,r) (w,h)) @@ -163,27 +162,27 @@ ts <- textSize s let sz = (textSizeWidth ts, textSizeHeight ts) return (xwid sz, ywid sz) - + rf (w0,h0) = withFontStyle fs $ do ts <- textSize s let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts) descent = textSizeDescent ts - + xadj HTA_Left = xwid sz/2 xadj HTA_Centre = w0/2 xadj HTA_Right = w0 - xwid sz/2 - + yadj VTA_Top = ywid sz/2 yadj VTA_Centre = h0/2 yadj VTA_Bottom = h0 - ywid sz/2 yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr - withTranslation (Point 0 (-descent)) $ - withTranslation (Point (xadj hta) (yadj vta)) $ + withTranslation (Point 0 (-descent)) $ + withTranslation (Point (xadj hta) (yadj vta)) $ withRotation rot' $ do drawText (Point (-w/2) (h/2)) s return (\_-> Just s) -- PickFn String - + rot' = rot / 180 * pi (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr) @@ -232,22 +231,22 @@ return nullPickFn where size = _rect_minsize rectangle - - fill p sz fs = - withFillStyle fs $ + + fill p sz fs = + withFillStyle fs $ fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - - stroke p sz ls = - withLineStyle ls $ + + stroke p sz ls = + withLineStyle ls $ strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - + strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare = let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1 <> lineTo' x1 y3 <> lineTo' x3 y3 <> lineTo' x3 y1 <> lineTo' x1 y1 - + strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) = let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s) <> lineTo' x1 (y3-s) @@ -258,7 +257,7 @@ <> lineTo' (x3-s) y1 <> lineTo' (x1+s) y1 <> lineTo' x1 (y1+s) - + strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) = let (x3,y3) = (x1+x2,y1+y2) in arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2 @@ -266,7 +265,7 @@ <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3) <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2) <> lineTo' x1 (y3-s) - + pi2 = pi / 2 $( makeLenses ''Rectangle ) diff --git a/Graphics/Rendering/Chart/Utils.hs b/Graphics/Rendering/Chart/Utils.hs --- a/Graphics/Rendering/Chart/Utils.hs +++ b/Graphics/Rendering/Chart/Utils.hs @@ -1,16 +1,24 @@ -- | Non chart specific utility functions. module Graphics.Rendering.Chart.Utils( isValidNumber, + log10, maybeM, + whenJust, ) where --- | Checks if the given value is and actual numeric value and not +-- | Checks if the given value is and actual numeric value and not -- a concept like NaN or infinity. isValidNumber :: (RealFloat a) => a -> Bool isValidNumber v = not (isNaN v) && not (isInfinite v) +-- | Shorthand for the decimal logarithm +log10 :: (Floating a) => a -> a +log10 = logBase 10 + -- | Version of 'Prelude.maybe' that returns a monadic value. maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b maybeM v = maybe (return v) - +-- | Specialization to () +whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () +whenJust m f = maybeM () f m