diff --git a/plots.cabal b/plots.cabal --- a/plots.cabal +++ b/plots.cabal @@ -1,5 +1,5 @@ name: plots -version: 0.1.1.1 +version: 0.1.1.2 synopsis: Diagrams based plotting library. homepage: http://github.com/cchalmers/plots license: BSD3 @@ -40,7 +40,7 @@ Plots.Types.Histogram Plots.Types.HeatMap Plots.Types.Line - -- Plots.Types.Pie + Plots.Types.Pie Plots.Types.Scatter Plots.Util Diagrams.Coordinates.Isomorphic @@ -52,8 +52,8 @@ colour, containers >= 0.3 && < 0.7, data-default >= 0.5 && < 0.8, - diagrams >= 2.0 && < 2.1, - geometry, + diagrams-core >= 1.3 && < 1.5, + diagrams-lib >= 1.3 && < 1.5, directory, distributive, transformers, diff --git a/src/Diagrams/Coordinates/Polar.hs b/src/Diagrams/Coordinates/Polar.hs --- a/src/Diagrams/Coordinates/Polar.hs +++ b/src/Diagrams/Coordinates/Polar.hs @@ -48,8 +48,8 @@ import Data.Typeable import GHC.Generics (Generic1) -import Geometry.Angle -import Geometry.TwoD.Types +import Diagrams.Angle +import Diagrams.TwoD.Types import Linear.Affine import Linear.Metric diff --git a/src/Plots.hs b/src/Plots.hs --- a/src/Plots.hs +++ b/src/Plots.hs @@ -53,7 +53,7 @@ , module Plots.Types.Histogram -- | Wedge and annular wedge. API for wedge, annular wedge and pie. - -- , module Plots.Types.Pie + , module Plots.Types.Pie -------------------------------------------------------------------- -- * Low level @@ -114,6 +114,6 @@ import Plots.Types.HeatMap import Plots.Types.Histogram import Plots.Types.Line --- import Plots.Types.Pie +import Plots.Types.Pie import Plots.Types.Scatter diff --git a/src/Plots/Axis.hs b/src/Plots/Axis.hs --- a/src/Plots/Axis.hs +++ b/src/Plots/Axis.hs @@ -30,7 +30,6 @@ -- * Predefined axes , r2Axis - , r3Axis , polarAxis -- ** Base space @@ -102,32 +101,22 @@ -- Single axis --------------------------------------------------------- -- | Render information for a single axis line. -data SingleAxis v = SingleAxis --- note the the v is only present for Style v - { saLabel :: AxisLabel v - , saLine :: AxisLine v - , saTickLabel :: TickLabels v - , saScaling :: AxisScaling - , saGridLines :: GridLines v - , saTicks :: Ticks v +data SingleAxis b v n = SingleAxis +-- note the the v is only present for Style v n + { saLabel :: AxisLabel b v n + , saLine :: AxisLine v n + , saTickLabel :: TickLabels b v n + , saScaling :: AxisScaling n + , saGridLines :: GridLines v n + , saTicks :: Ticks v n , saVisible :: Bool } -type instance V (SingleAxis v) = v -type instance N (SingleAxis v) = Double - -instance Default (SingleAxis V2) where - def = SingleAxis - { saLabel = def - , saLine = def - , saTickLabel = def - , saGridLines = def - , saTicks = def - , saScaling = def - , saVisible = True - } +type instance V (SingleAxis b v n) = v +type instance N (SingleAxis b v n) = n -instance Default (SingleAxis V3) where +instance (TypeableFloat n, Renderable (Text n) b) + => Default (SingleAxis b V2 n) where def = SingleAxis { saLabel = def , saLine = def @@ -138,43 +127,43 @@ , saVisible = True } -instance Functor f => HasTicks f (SingleAxis v) where +instance Functor f => HasTicks f (SingleAxis b v n) where bothTicks = lens saTicks (\sa ticks -> sa {saTicks = ticks}) -instance Functor f => HasMajorTicks f (SingleAxis v) where +instance Functor f => HasMajorTicks f (SingleAxis b v n) where majorTicks = bothTicks . majorTicks -instance Functor f => HasMinorTicks f (SingleAxis v) where +instance Functor f => HasMinorTicks f (SingleAxis b v n) where minorTicks = bothTicks . minorTicks -instance Functor f => HasAxisLabel f (SingleAxis v) where +instance Functor f => HasAxisLabel f (SingleAxis b v n) b where axisLabel = lens saLabel (\sa l -> sa {saLabel = l}) -instance Functor f => HasTickLabels f (SingleAxis v) where +instance Functor f => HasTickLabels f (SingleAxis b v n) b where tickLabel = lens saTickLabel (\sa tl -> sa {saTickLabel = tl}) -instance Functor f => HasAxisLine f (SingleAxis v) where +instance Functor f => HasAxisLine f (SingleAxis b v n) where axisLine = lens saLine (\sa l -> sa {saLine = l}) -instance Functor f => HasGridLines f (SingleAxis v) where +instance Functor f => HasGridLines f (SingleAxis b v n) where gridLines = lens saGridLines (\sa l -> sa {saGridLines = l}) -instance Functor f => HasMajorGridLines f (SingleAxis v) where +instance Functor f => HasMajorGridLines f (SingleAxis b v n) where majorGridLines = gridLines . majorGridLines -instance Functor f => HasMinorGridLines f (SingleAxis v) where +instance Functor f => HasMinorGridLines f (SingleAxis b v n) where minorGridLines = gridLines . minorGridLines -instance Functor f => HasAxisScaling f (SingleAxis v) where +instance Functor f => HasAxisScaling f (SingleAxis b v n) where axisScaling = lens saScaling (\sa s -> sa {saScaling = s}) -instance HasVisibility (SingleAxis v) where +instance HasVisibility (SingleAxis b v n) where visible = lens saVisible (\sa b -> sa {saVisible = b}) --- singleAxisScale :: Lens' (SingleAxis v) AxisScale +-- singleAxisScale :: Lens' (SingleAxis b v n) AxisScale -- singleAxisScale = lens saScale (\sa s -> sa {saScale = s}) --- singleAxisBound :: Lens' (SingleAxis v) (Bound n) +-- singleAxisBound :: Lens' (SingleAxis b v n) (Bound n) -- singleAxisBound = lens saBounds (\sa b -> sa {saBounds = b}) ------------------------------------------------------------------------ @@ -224,36 +213,36 @@ -- Plots are usually added to the axis using specific functions for -- those plots ('Plots.Types.Line.linePlot, 'Plots.Types.Bar.barPlot'). -- These functions use 'addPlotable' to add the plot to the axis. -data Axis c = Axis - { _axisStyle :: AxisStyle (BaseSpace c) - , _colourBar :: ColourBar - , _colourBarR :: (Double,Double) - , _legend :: Legend - , _axisTitle :: Title (BaseSpace c) +data Axis b c n = Axis + { _axisStyle :: AxisStyle b (BaseSpace c) n + , _colourBar :: ColourBar b n + , _colourBarR :: (n,n) + , _legend :: Legend b n + , _axisTitle :: Title b (BaseSpace c) n -- , _axisTitle :: AxisTitle - , _axisPlots :: [DynamicPlot (BaseSpace c)] - , _plotModifier :: Endo (StyledPlot (BaseSpace c)) + , _axisPlots :: [DynamicPlot b (BaseSpace c) n] + , _plotModifier :: Endo (StyledPlot b (BaseSpace c) n) -- the v in each axis is only used for the style - , _axes :: c (SingleAxis (BaseSpace c)) + , _axes :: c (SingleAxis b (BaseSpace c) n) } deriving Typeable -- | Lens onto the separate axes of an axis. Allows changing the -- coordinate system as long as the 'BaseSpace' is the same. -- -- @ --- 'axes' :: 'Lens'' ('Axis' c) (c ('SingleAxis' v)) +-- 'axes' :: 'Lens'' ('Axis' b c n) (c ('SingleAxis' b v n)) -- @ axes :: (v ~ BaseSpace c, v ~ BaseSpace c') - => Lens (Axis c) - (Axis c') - (c (SingleAxis v)) - (c' (SingleAxis v)) + => Lens (Axis b c n) + (Axis b c' n) + (c (SingleAxis b v n)) + (c' (SingleAxis b v n)) axes = lens _axes (\(Axis a1 a2 a3 a4 a5 a6 a7 _) a8 -> Axis a1 a2 a3 a4 a5 a6 a7 a8) -- | The list of plots currently in the axis. -axisPlots :: BaseSpace c ~ v => Lens' (Axis c) [DynamicPlot v] +axisPlots :: BaseSpace c ~ v => Lens' (Axis b c n) [DynamicPlot b v n] axisPlots = lens _axisPlots (\a ps -> a {_axisPlots = ps}) -- | Traversal over the current plots in the axis. @@ -264,7 +253,7 @@ -- @ -- 'finalPlots' . 'connectingLine' .= 'True' -- @ -currentPlots :: BaseSpace c ~ v => Traversal' (Axis c) (DynamicPlot v) +currentPlots :: BaseSpace c ~ v => Traversal' (Axis b c n) (DynamicPlot b v n) currentPlots = axisPlots . traversed -- | Setter over the final plot before the axis is rendered. @@ -277,74 +266,71 @@ -- 'finalPlots' . 'connectingLine' .= 'True' -- @ -- -finalPlots :: BaseSpace c ~ v => Setter' (Axis c) (StyledPlot v) +finalPlots :: BaseSpace c ~ v => Setter' (Axis b c n) (StyledPlot b v n) finalPlots = sets $ \f a -> a {_plotModifier = _plotModifier a <> Endo f} -- | Lens onto the modifier set by 'finalPlots'. This gets applied to -- all plots in the axis, just before they are rendered. -plotModifier :: BaseSpace c ~ v => Lens' (Axis c) (Endo (StyledPlot v)) +plotModifier :: BaseSpace c ~ v => Lens' (Axis b c n) (Endo (StyledPlot b v n)) plotModifier = lens _plotModifier (\a f -> a {_plotModifier = f}) -- Axis instances ------------------------------------------------------ -type instance V (Axis c) = BaseSpace c -type instance N (Axis c) = Double +type instance V (Axis b v n) = BaseSpace v +type instance N (Axis b v n) = n -instance (Applicative f, Traversable c) => HasTicks f (Axis c) where +instance (Applicative f, Traversable c) => HasTicks f (Axis b c n) where bothTicks = axes . traverse . bothTicks -instance (Applicative f, Traversable c) => HasMajorTicks f (Axis c) where +instance (Applicative f, Traversable c) => HasMajorTicks f (Axis b c n) where majorTicks = axes . traverse . majorTicks -instance (Applicative f, Traversable c) => HasMinorTicks f (Axis c) where +instance (Applicative f, Traversable c) => HasMinorTicks f (Axis b c n) where minorTicks = axes . traverse . minorTicks -instance (Applicative f, Traversable c) => HasGridLines f (Axis c) where +instance (Applicative f, Traversable c) => HasGridLines f (Axis b c n) where gridLines = axes . traverse . gridLines -instance (Applicative f, Traversable c) => HasMajorGridLines f (Axis c) where +instance (Applicative f, Traversable c) => HasMajorGridLines f (Axis b c n) where majorGridLines = axes . traverse . majorGridLines -instance (Applicative f, Traversable c) => HasMinorGridLines f (Axis c) where +instance (Applicative f, Traversable c) => HasMinorGridLines f (Axis b c n) where minorGridLines = axes . traverse . minorGridLines -instance (Applicative f, Traversable c) => HasAxisLine f (Axis c) where - axisLine = axes . traverse . axisLine - -instance (Applicative f, Traversable c) => HasAxisLabel f (Axis c) where +instance (Applicative f, Traversable c) => HasAxisLabel f (Axis b c n) b where axisLabel = axes . traverse . axisLabel -instance (Applicative f, Traversable c) => HasTickLabels f (Axis c) where +instance (Applicative f, Traversable c) => HasTickLabels f (Axis b c n) b where tickLabel = axes . traverse . tickLabel -instance (Applicative f, Traversable c) => HasAxisScaling f (Axis c) where +instance (Applicative f, Traversable c) => HasAxisScaling f (Axis b c n) where axisScaling = axes . traverse . axisScaling -instance Settable f => HasPlotOptions f (Axis c) where +instance Settable f => HasPlotOptions f (Axis b c n) b where plotOptions = finalPlots . plotOptions -instance Settable f => HasPlotStyle f (Axis c) where +instance Settable f => HasPlotStyle f (Axis b c n) b where plotStyle = finalPlots . plotStyle -instance HasLegend (Axis c) where +instance HasLegend (Axis b c n) b where legend = lens _legend (\a l -> a {_legend = l}) -instance HasTitle (Axis c) where +instance HasTitle (Axis b c n) b where title = lens _axisTitle (\a t -> a {_axisTitle = t}) -- | The size used for the rendered axis. -axisSize :: HasLinearMap c => Lens' (Axis c) (SizeSpec c Double) -axisSize = axes . column renderSize . iso mkSizeSpec getSpec +axisSize :: (HasLinearMap c, Num n, Ord n) => Lens' (Axis b c n) (SizeSpec c n) +axisSize = axes . column renderSize . iso mkSizeSpec getSpec -- column axisScaling . asSizeSpec -- iso mkSizeSpec getSpec -- | The range used for the colour bar limits. This is automatically set -- when using 'heatMap' or 'heatMap'' -colourBarRange :: Lens' (Axis v) (Double,Double) +colourBarRange :: Lens' (Axis b v n) (n,n) colourBarRange = lens _colourBarR (\a r -> a {_colourBarR = r}) -instance HasAxisStyle (Axis v) where +instance HasAxisStyle (Axis b v n) b where axisStyle = lens _axisStyle (\a sty -> a {_axisStyle = sty}) -instance HasColourBar (Axis v) where +instance HasColourBar (Axis b v n) b where colourBar = lens _colourBar (\a cb -> a {_colourBar = cb}) -- Axis functions ------------------------------------------------------ @@ -352,11 +338,11 @@ -- $plotable -- The 'Plotable' class defines ways of converting the data type to a -- diagram for some axis. There are several variants for adding an axis --- with constraints @('InSpace' v a, 'Plotable' a b)@: +-- with constraints @('InSpace' v n a, 'Plotable' a b)@: -- -- @ --- 'addPlotable' :: a -> 'PlotState' a b -> 'AxisState' v --- 'addPlotable'' :: a -> 'AxisState' v +-- 'addPlotable' :: a -> 'PlotState' a b -> 'AxisState' b v n +-- 'addPlotable'' :: a -> 'AxisState' b v n -- @ -- -- The last argument is a 'PlotState' so you can use @do@ notation to @@ -377,23 +363,23 @@ -- | Add a 'Plotable' 'Plot' to an 'Axis'. addPlot - :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p) - => Plot p -- ^ the plot - -> m () -- ^ add plot to the 'Axis' + :: (InSpace (BaseSpace c) n p, MonadState (Axis b c n) m, Plotable p b) + => Plot p b -- ^ the plot + -> m () -- ^ add plot to the 'Axis' addPlot p = axisPlots <>= [DynamicPlot p] -- | Add something 'Plotable' to the 'Axis' with a stateful modification -- of the 'Plot'. addPlotable - :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p, HasLinearMap (BaseSpace c)) + :: (InSpace (BaseSpace c) n p, MonadState (Axis b c n) m, Plotable p b) => p -- ^ the raw plot - -> State (Plot p) () -- ^ changes to the plot + -> State (Plot p b) () -- ^ changes to the plot -> m () -- ^ add plot to the 'Axis' addPlotable p s = addPlot $ execState s (mkPlot p) -- | Simple version of 'AddPlotable' without any changes 'Plot'. addPlotable' - :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p, HasLinearMap (BaseSpace c)) + :: (InSpace (BaseSpace v) n p, MonadState (Axis b v n) m, Plotable p b) => p -- ^ the raw plot -> m () -- ^ add plot to the 'Axis' addPlotable' p = addPlotable p (return ()) @@ -403,7 +389,11 @@ ------------------------------------------------------------------------ -- | The default axis for plots in the 'V2' coordinate system. -r2Axis :: Axis V2 +r2Axis + :: (TypeableFloat n, + Renderable (Text n) b, + Renderable (Path V2 n) b) + => Axis b V2 n r2Axis = Axis { _axisStyle = fadedColours , _colourBar = defColourBar @@ -417,110 +407,95 @@ , _axes = pure def } --- | The default axis for plots in the 'V2' coordinate system. -r3Axis :: Axis V3 -r3Axis = Axis - { _axisStyle = fadedColours3D - , _colourBar = defColourBar - , _colourBarR = (0,1) - , _axisTitle = def - - , _legend = def - , _axisPlots = [] - , _plotModifier = mempty - - , _axes = pure def - } - -- The x-axis ---------------------------------------------------------- -- | Lens onto the x-axis of an 'Axis'. -xAxis :: R1 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) +xAxis :: R1 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) xAxis = axes . _x -- | The label for the x-axis. Shorthand for @'xAxis' . 'axisLabelText'@. -xLabel :: R1 c => Lens' (Axis c) String +xLabel :: R1 c => Lens' (Axis b c n) String xLabel = xAxis . axisLabelText -- | The minimum x value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -xMin :: R1 c => Lens' (Axis c) (Maybe Double) +xMin :: R1 c => Lens' (Axis b c n) (Maybe n) xMin = xAxis . boundMin -- | The minimum x value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -xMax :: R1 c => Lens' (Axis c) (Maybe Double) +xMax :: R1 c => Lens' (Axis b c n) (Maybe n) xMax = xAxis . boundMax -- The y-axis ---------------------------------------------------------- -- | Lens onto the y-axis of an 'Axis'. -yAxis :: R2 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) +yAxis :: R2 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) yAxis = axes . _y -- | The label for the y-axis. Shorthand for @'yAxis' . 'axisLabelText'@. -yLabel :: R2 c => Lens' (Axis c) String +yLabel :: R2 c => Lens' (Axis b c n) String yLabel = yAxis . axisLabelText -- | The minimum y value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -yMin :: R2 c => Lens' (Axis c) (Maybe Double) +yMin :: R2 c => Lens' (Axis b c n) (Maybe n) yMin = yAxis . boundMin -- | The minimum y value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -yMax :: R2 c => Lens' (Axis c) (Maybe Double) +yMax :: R2 c => Lens' (Axis b c n) (Maybe n) yMax = yAxis . boundMax -- The z-axis ---------------------------------------------------------- -- | Lens onto the z-axis of an 'Axis'. -zAxis :: R3 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) +zAxis :: R3 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) zAxis = axes . _z -- | The label for the z-axis. Shorthand for @'zAxis' . 'axisLabelText'@. -zLabel :: R3 c => Lens' (Axis c) String +zLabel :: R3 c => Lens' (Axis b c n) String zLabel = zAxis . axisLabelText -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -zMin :: R3 c => Lens' (Axis c) (Maybe Double) +zMin :: R3 c => Lens' (Axis b c n) (Maybe n) zMin = zAxis . boundMin -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -zMax :: R3 c => Lens' (Axis c) (Maybe Double) +zMax :: R3 c => Lens' (Axis b c n) (Maybe n) zMax = zAxis . boundMax -- The r-axis ---------------------------------------------------------- -- | Lens onto the radial axis of an 'Axis'. -rAxis :: Radial c => Lens' (Axis c) (SingleAxis (BaseSpace c)) +rAxis :: Radial c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) rAxis = axes . _radial -- | The label for the radial axis. Shorthand for @'rAxis' . 'axisLabelText'@. -rLabel :: Radial c => Lens' (Axis c) String +rLabel :: Radial c => Lens' (Axis b c n) String rLabel = rAxis . axisLabelText -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. --- rMin :: R3 c => Lens' (Axis c) (Maybe Double) +-- rMin :: R3 c => Lens' (Axis b c n) (Maybe n) -- rMin = zAxis . boundMin -- | The minimum radial value for the axis. If the value if 'Nothing' -- (the 'Default'), the bounds will be infered by the plots in the -- axis. -rMax :: Radial c => Lens' (Axis c) (Maybe Double) +rMax :: Radial c => Lens' (Axis b c n) (Maybe n) rMax = rAxis . boundMax -- The theta-axis ------------------------------------------------------ -- | Lens onto the radial axis of an 'Axis'. -thetaAxis :: Circle c => Lens' (Axis c) (SingleAxis (BaseSpace c)) +thetaAxis :: Circle c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) thetaAxis = axes . el etheta -- | The label for the radial axis. Shorthand for @'rAxis' . 'axisLabelText'@. -thetaLabel :: Circle c => Lens' (Axis c) String +thetaLabel :: Circle c => Lens' (Axis b c n) String thetaLabel = thetaAxis . axisLabelText @@ -546,7 +521,11 @@ -- R3 Axis -polarAxis :: Axis Polar +polarAxis + :: (TypeableFloat n, + Renderable (Text n) b, + Renderable (Path V2 n) b) + => Axis b Polar n polarAxis = Axis { _axisStyle = fadedColours , _colourBar = defColourBar diff --git a/src/Plots/Axis/ColourBar.hs b/src/Plots/Axis/ColourBar.hs --- a/src/Plots/Axis/ColourBar.hs +++ b/src/Plots/Axis/ColourBar.hs @@ -39,8 +39,9 @@ import Data.Bool (bool) import qualified Data.Foldable as F --- import Diagrams.Core.Transform (fromSymmetric) -import Diagrams.Prelude hiding (orient) +import Data.Typeable +import Diagrams.Core.Transform (fromSymmetric) +import Diagrams.Prelude hiding (gap) import Diagrams.TwoD.Text import Plots.Axis.Grid import Plots.Axis.Labels @@ -49,30 +50,29 @@ import Plots.Types import Plots.Util -import Geometry.TwoD.Transform - -- | Options for drawing a colour bar. Note that for an axis, the -- 'ColourMap' is stored in the 'AxisStyle'. These options are for -- other aspects of the bar, not the colours used. -data ColourBar = ColourBar +data ColourBar b n = ColourBar { cbPlacement :: Placement , cbVisible :: Bool - , cbTicks :: MajorTicks V2 - , cbMinorTicks :: MinorTicks V2 - , cbGridLines :: MajorGridLines V2 - , cbTickLabels :: TickLabels V2 - , cbDraw :: ColourMap -> Diagram V2 - , cbWidth :: Double - , cbLengthFun :: Double -> Double - , cbGap :: Double - , cbStyle :: Style V2 Double + , cbTicks :: MajorTicks V2 n + , cbMinorTicks :: MinorTicks V2 n + , cbGridLines :: MajorGridLines V2 n + , cbTickLabels :: TickLabels b V2 n + , cbDraw :: ColourMap -> QDiagram b V2 n Any + , cbWidth :: n + , cbLengthFun :: n -> n + , cbGap :: n + , cbStyle :: Style V2 n } -type instance V ColourBar = V2 -type instance N ColourBar = Double +type instance V (ColourBar b n) = V2 +type instance N (ColourBar b n) = n -- | The default colour bar. -defColourBar :: ColourBar +defColourBar :: (Renderable (Text n) b, Renderable (Path V2 n) b, TypeableFloat n) + => ColourBar b n defColourBar = ColourBar { cbPlacement = rightMid , cbVisible = False @@ -87,9 +87,9 @@ , cbStyle = mempty } -class HasColourBar a where +class HasColourBar a b | a -> b where -- | Lens onto the 'ColourBar'. - colourBar :: Lens' a ColourBar + colourBar :: Lens' a (ColourBar b (N a)) -- | How to draw the colour bar. Expects a 1 by 1 box with the -- gradient going from left to right, without an outline with origin @@ -100,40 +100,40 @@ -- 'Plots.Style.axisColourMap' from "Plots.Style" -- -- Default is 'gradientColourBar'. - colourBarDraw :: Lens' a (ColourMap -> Diagram V2) + colourBarDraw :: Lens' a (ColourMap -> QDiagram b V2 (N a) Any) colourBarDraw = colourBar . lens cbDraw (\c a -> c {cbDraw = a}) -- | The width (orthogonal to the colour bar direction) of the colour -- bar. -- -- 'Default' is @20@. - colourBarWidth :: Lens' a Double + colourBarWidth :: Lens' a (N a) colourBarWidth = colourBar . lens cbWidth (\c a -> c {cbWidth = a}) -- | Set the length of the colour bar given the length of the axis the -- colour bar is aligned to. -- -- 'Default' is 'id'. - colourBarLengthFunction :: Lens' a (Double -> Double) + colourBarLengthFunction :: Lens' a (N a -> N a) colourBarLengthFunction = colourBar . lens cbLengthFun (\c a -> c {cbLengthFun = a}) -- | Gap between the axis and the colour bar (if rendered with an axis). -- -- 'Default' is @20@. - colourBarGap :: Lens' a Double + colourBarGap :: Lens' a (N a) colourBarGap = colourBar . lens cbGap (\c a -> c {cbGap = a}) -- | Style used for the outline of a colour bar. - colourBarStyle :: Lens' a (Style V2 Double) + colourBarStyle :: Lens' a (Style V2 (N a)) colourBarStyle = colourBar . lens cbStyle (\c a -> c {cbStyle = a}) -instance HasColourBar ColourBar where +instance HasColourBar (ColourBar b n) b where colourBar = id -instance HasGap ColourBar where +instance HasGap (ColourBar b n) where gap = colourBarGap -instance HasPlacement ColourBar where +instance HasPlacement (ColourBar b n) where placement = lens cbPlacement (\c p -> c {cbPlacement = p}) -- This is a kinda strange instance that I'm using as an experiment. @@ -153,7 +153,7 @@ -- When reversing the direction we map E <-> S and N <-> W. The gap -- direction is rotated to match the new position and anchor has its x -- and y flipped. -instance HasOrientation ColourBar where +instance HasOrientation (ColourBar b n) where orientation = lens getter setter where getter p @@ -183,32 +183,32 @@ & placementAnchor %~ flipX_Y & gapDirection ._Dir %~ flipX_Y -instance ApplyStyle ColourBar -instance HasStyle ColourBar where - style = colourBarStyle +instance Typeable n => HasStyle (ColourBar b n) where + applyStyle sty = colourBarStyle %~ applyStyle sty -instance Functor f => HasMajorTicks f ColourBar where +instance Functor f => HasMajorTicks f (ColourBar b n) where majorTicks = lens cbTicks (\c a -> c {cbTicks = a}) -instance Functor f => HasMinorTicks f ColourBar where +instance Functor f => HasMinorTicks f (ColourBar b n) where minorTicks = lens cbMinorTicks (\c a -> c {cbMinorTicks = a}) -instance Functor f => HasMajorGridLines f ColourBar where +instance Functor f => HasMajorGridLines f (ColourBar b n) where majorGridLines = lens cbGridLines (\c a -> c {cbGridLines = a}) -instance Functor f => HasTickLabels f ColourBar where +instance Functor f => HasTickLabels f (ColourBar b n) b where tickLabel = lens cbTickLabels (\c a -> c {cbTickLabels = a}) -instance HasVisibility ColourBar where +instance HasVisibility (ColourBar b n) where visible = lens cbVisible (\c a -> c {cbVisible = a}) -- | Add a colour bar to an object, using the bounding box for the object. addColourBar - :: BoundingBox V2 Double -- ^ bounding box to place against - -> ColourBar + :: (TypeableFloat n, Renderable (Path V2 n) b) + => BoundingBox V2 n -- ^ bounding box to place against + -> ColourBar b n -- -> ColourMap - -> (Double,Double) - -> Diagram V2 + -> (n,n) + -> QDiagram b V2 n Any addColourBar bb cbo@ColourBar {..} cm bnds | cbVisible = placeAgainst bb cbPlacement cbGap cb | otherwise = mempty @@ -224,11 +224,12 @@ -- | Render a colour bar by it's self at a given width. Note this -- ignores 'colourBarGap' and 'colourBarLengthFunction'. renderColourBar - :: ColourBar -- ^ options for colour bar - -> ColourMap -- ^ map to use - -> (Double,Double) -- ^ bounds of the values on the colour bar - -> Double -- ^ length of the colour bar - -> Diagram V2 + :: (TypeableFloat n, Renderable (Path V2 n) b) + => ColourBar b n -- ^ options for colour bar + -> ColourMap -- ^ map to use + -> (n,n) -- ^ bounds of the values on the colour bar + -> n -- ^ length of the colour bar + -> QDiagram b V2 n Any renderColourBar cb@ColourBar {..} cm bnds@(lb,ub) l | cbVisible = bar # xy id reflectY # o id (reflectY . _reflectX_Y) @@ -257,7 +258,7 @@ bar = outline <> tks <> minorTks <> gLines <> colours -- the outline - outline = rect l w # applyStyle (cbStyle & _fillTexture ?~ _AC ## transparent) + outline = rect l w # applyStyle (cbStyle & _fillTexture .~ _AC ## transparent) -- displaying the colour map colours = cbDraw cm # centerXY # scaleX l # scaleY w @@ -268,6 +269,7 @@ tks | cbTicks ^. hidden = mempty | otherwise = F.foldMap (\x -> aTick # translate (V2 (f x) (-w/2))) tickXs' + # applyStyle (cbTicks ^. majorTicksStyle) aTick = someTick (cbTicks ^. majorTicksAlignment) (cbTicks ^. majorTicksLength) minorTickXs = view minorTicksFunction cbMinorTicks tickXs bnds @@ -280,17 +282,17 @@ someTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> fromVertices [mkP2 0 (-d*bb), mkP2 0 (d*aa)] - AutoTick -> fromVertices [mkP2 0 (-d) , mkP2 0 d ] + -> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa) + AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d -- grid lines gridXs = filter inRange $ view majorGridLinesFunction cbGridLines tickXs bnds gLines | cbGridLines ^. hidden = mempty | otherwise = F.foldMap mkGridLine gridXs - # (stroke :: Path V2 Double -> Diagram V2) + # strokePath # applyStyle (cbGridLines ^. majorGridLinesStyle) - mkGridLine x = fromVertices [mkP2 (f x) (-w/2), mkP2 (f x) (w/2)] + mkGridLine x = mkP2 (f x) (-w/2) ~~ mkP2 (f x) (w/2) -- tick labels tickLabelXs = view tickLabelFunction cbTickLabels tickXs' bnds @@ -319,21 +321,22 @@ -- This may not be supported by all backends. -- -- <> -gradientColourBar :: ColourMap -> Diagram V2 +gradientColourBar :: (TypeableFloat n, Renderable (Path V2 n) b) => ColourMap -> QDiagram b V2 n Any gradientColourBar cm = rect 1 1 # fillTexture grad # lw none where - stops = map (\(x,c) -> (c,fromRational x)) (colourList cm) - grad = mkLinearGradient stops origin unitX -- defaultLG & _LG . lGradStops .~ stops + stops = map (\(x,c) -> GradientStop (SomeColor c) (fromRational x)) (colourList cm) + grad = defaultLG & _LG . lGradStops .~ stops -- | Construct a colour bar made up of @n@ solid square paths. The final -- diagram is 1 by 1, with origin at the middle of the left side. This -- can be used as the 'colourBarDraw' function. -- -- <> -pathColourBar :: Int -> ColourMap -> Diagram V2 +pathColourBar :: (TypeableFloat n, Renderable (Path V2 n) b) + => Int -> ColourMap -> QDiagram b V2 n Any pathColourBar n cm = ifoldMap mkR xs where mkR i x = rect d' 1 @@ -355,7 +358,7 @@ flipX_Y (V2 x y) = V2 (-y) (-x) _reflectionX_Y :: (Additive v, R2 v, Num n) => Transformation v n -_reflectionX_Y = undefined -- fromSymmetric $ (_xy %~ flipX_Y) <-> (_xy %~ flipX_Y) +_reflectionX_Y = fromSymmetric $ (_xy %~ flipX_Y) <-> (_xy %~ flipX_Y) _reflectX_Y :: (InSpace v n t, R2 v, Transformable t) => t -> t _reflectX_Y = transform _reflectionX_Y diff --git a/src/Plots/Axis/Grid.hs b/src/Plots/Axis/Grid.hs --- a/src/Plots/Axis/Grid.hs +++ b/src/Plots/Axis/Grid.hs @@ -63,14 +63,14 @@ -- Major grid lines ------------------------------------------------------------------------ -data MajorGridLines v = MajorGridLines - { magFun :: GridLineFunction Double - , magStyle :: Style v Double +data MajorGridLines v n = MajorGridLines + { magFun :: GridLineFunction n + , magStyle :: Style v n , magVisible :: Bool } deriving Typeable -type instance V (MajorGridLines v) = v -type instance N (MajorGridLines v) = Double +type instance V (MajorGridLines v n) = v +type instance N (MajorGridLines v n) = n class HasMajorGridLines f a where -- | The options for how to draw the grid lines. This can be used on @@ -81,46 +81,45 @@ -- 'majorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) -- 'majorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) -- @ - majorGridLines :: LensLike' f a (MajorGridLines (V a)) + majorGridLines :: LensLike' f a (MajorGridLines (V a) (N a)) -- | The function to calculate location of the major grid lines given -- location of the major ticks and bounds. - majorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction Double) + majorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction (N a)) majorGridLinesFunction = majorGridLines . lens magFun (\gl maf -> gl {magFun = maf}) -- | The style applied to the major grid lines. - majorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) Double) + majorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) (N a)) majorGridLinesStyle = majorGridLines . lens magStyle (\gl sty -> gl {magStyle = sty}) -instance HasMajorGridLines f (MajorGridLines v) where +instance HasMajorGridLines f (MajorGridLines v n) where majorGridLines = id -instance Default (MajorGridLines v) where +instance (Typeable n, Floating n) => Default (MajorGridLines v n) where def = MajorGridLines { magFun = onTicksGridLineFunction , magStyle = mempty # lwO 0.8 , magVisible = True } -instance HasVisibility (MajorGridLines v) where +instance HasVisibility (MajorGridLines v n) where visible = lens magVisible (\gl b -> gl {magVisible = b}) -instance ApplyStyle (MajorGridLines v) -instance HasStyle (MajorGridLines v) where - style = majorGridLinesStyle +instance Typeable n => HasStyle (MajorGridLines v n) where + applyStyle s = majorGridLinesStyle %~ applyStyle s ------------------------------------------------------------------------ -- Minor grid lines ------------------------------------------------------------------------ -data MinorGridLines v = MinorGridLines - { migFun :: GridLineFunction Double - , migStyle :: Style v Double +data MinorGridLines v n = MinorGridLines + { migFun :: GridLineFunction n + , migStyle :: Style v n , migVisible :: Bool } deriving Typeable -type instance V (MinorGridLines v) = v -type instance N (MinorGridLines v) = Double +type instance V (MinorGridLines v n) = v +type instance N (MinorGridLines v n) = n class HasMinorGridLines f a where -- | The options for how to draw the grid lines. This can be used on @@ -131,22 +130,22 @@ -- 'minorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) -- 'minorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) -- @ - minorGridLines :: LensLike' f a (MinorGridLines (V a)) + minorGridLines :: LensLike' f a (MinorGridLines (V a) (N a)) -- | The function to calculate location of the minor grid lines given -- location of the minor ticks and bounds. - minorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction Double) + minorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction (N a)) minorGridLinesFunction = minorGridLines . lens migFun (\gl mif -> gl {migFun = mif}) -- | The style applied to the minor grid lines. - minorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) Double) + minorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) (N a)) minorGridLinesStyle = minorGridLines . lens migStyle (\gl sty -> gl {migStyle = sty}) -instance HasMinorGridLines f (MinorGridLines v) where +instance HasMinorGridLines f (MinorGridLines v n) where minorGridLines = id -instance Default (MinorGridLines v) where +instance (Typeable n, Floating n) => Default (MinorGridLines v n) where def = MinorGridLines { migFun = onTicksGridLineFunction , migStyle = mempty # lwO 0.5 @@ -154,12 +153,11 @@ } -- | Hidden by default. -instance HasVisibility (MinorGridLines v) where +instance HasVisibility (MinorGridLines v n) where visible = lens migVisible (\gl b -> gl {migVisible = b}) -instance ApplyStyle (MinorGridLines v) -instance HasStyle (MinorGridLines v) where - style = minorGridLinesStyle +instance Typeable n => HasStyle (MinorGridLines v n) where + applyStyle s = minorGridLinesStyle %~ applyStyle s ------------------------------------------------------------------------ -- Grid lines helpers @@ -186,7 +184,7 @@ -- @ gridLinesVisible :: (HasGridLines f a, Applicative f) => LensLike' f a Bool gridLinesVisible = gridLines . vis where - vis :: Traversal' (GridLines v) Bool + vis :: Traversal' (GridLines v n) Bool vis f a = (\m mn -> a & majorGridLines . visible .~ m & minorGridLines . visible .~ mn) <$> f (a ^. majorGridLines . visible) <*> f (a ^. minorGridLines . visible) @@ -196,33 +194,33 @@ ------------------------------------------------------------------------ -- | Type holding information about both major and minor grid lines. -data GridLines v = GridLines - { majGrid :: MajorGridLines v - , minGrid :: MinorGridLines v +data GridLines v n = GridLines + { majGrid :: MajorGridLines v n + , minGrid :: MinorGridLines v n } deriving Typeable -type instance V (GridLines v) = v -type instance N (GridLines v) = Double +type instance V (GridLines v n) = v +type instance N (GridLines v n) = n class (HasMinorGridLines f a, HasMajorGridLines f a) => HasGridLines f a where - gridLines :: LensLike' f a (GridLines (V a)) + gridLines :: LensLike' f a (GridLines (V a) (N a)) -instance Functor f => HasGridLines f (GridLines v) where +instance Functor f => HasGridLines f (GridLines v n) where gridLines = id -instance Default (GridLines v) where +instance (Typeable n, Floating n) => Default (GridLines v n) where def = GridLines { majGrid = def , minGrid = def } -instance Functor f => HasMajorGridLines f (GridLines v) where +instance Functor f => HasMajorGridLines f (GridLines v n) where majorGridLines = lens majGrid (\g a -> g {majGrid = a}) -instance Functor f => HasMinorGridLines f (GridLines v) where +instance Functor f => HasMinorGridLines f (GridLines v n) where minorGridLines = lens minGrid (\g a -> g {minGrid = a}) -instance ApplyStyle (GridLines v) where +instance Typeable n => HasStyle (GridLines v n) where applyStyle s = (majorGridLines %~ applyStyle s) . (minorGridLines %~ applyStyle s) -- | Hide both major and minor grid lines. @@ -250,9 +248,9 @@ majorGridLines . visible .= True -- | Traversal over both the major and minor grid styles. This can be used at several levels in the axis: -gridLinesStyle :: (HasGridLines f a, Applicative f) => LensLike' f a (Style (V a) Double) +gridLinesStyle :: (HasGridLines f a, Applicative f) => LensLike' f a (Style (V a) (N a)) gridLinesStyle = gridLines . styles where - styles :: Traversal' (GridLines v) (Style v Double) + styles :: Traversal' (GridLines v n) (Style v n) styles f a = (\m mn -> a & majorGridLinesStyle .~ m & minorGridLinesStyle .~ mn) <$> f (a ^. majorGridLinesStyle) <*> f (a ^. minorGridLinesStyle) diff --git a/src/Plots/Axis/Labels.hs b/src/Plots/Axis/Labels.hs --- a/src/Plots/Axis/Labels.hs +++ b/src/Plots/Axis/Labels.hs @@ -46,7 +46,7 @@ -- | Function to render the axis label from a string. This is very basic -- now and will be replace by a more sophisticated system. -type TextFunction v = TextAlignment Double -> String -> Diagram v +type TextFunction b v n = TextAlignment n -> String -> QDiagram b v n Any ------------------------------------------------------------------------ -- Axis labels @@ -74,45 +74,45 @@ -- @ -- -- See 'HasAxisLabel' for more advanced settings. -data AxisLabel v = AxisLabel - { alFun :: TextFunction v +data AxisLabel b v n = AxisLabel + { alFun :: TextFunction b v n , alText :: String - , alStyle :: Style v Double - , alGap :: Double + , alStyle :: Style v n + , alGap :: n , alPos :: AxisLabelPosition , alPlacement :: AxisLabelPlacement , alVisible :: Bool } -type instance V (AxisLabel v) = v -type instance N (AxisLabel v) = Double +type instance V (AxisLabel b v n) = v +type instance N (AxisLabel b v n) = n -class HasAxisLabel f a where +class HasAxisLabel f a b | a -> b where -- | The options for the label of the axis. This can be used on -- various levels of the axis: -- -- @ -- 'axisLabel' :: 'Traversal'' ('Axis' b c n) ('AxisLabel' ('BaseSpace' c) n) - -- 'axisLabel' :: 'Lens'' ('SingleAxis' v) ('AxisLabel' v n) + -- 'axisLabel' :: 'Lens'' ('SingleAxis' b v n) ('AxisLabel' v n) -- 'axisLabel' :: 'Lens'' ('AxisLabel' v n) ('AxisLabel' v n) -- @ - axisLabel :: LensLike' f a (AxisLabel (V a)) + axisLabel :: LensLike' f a (AxisLabel b (V a) (N a)) -- | The text to use when labeling the axis. axisLabelText :: Functor f => LensLike' f a String axisLabelText = axisLabel . lens alText (\al txt -> al {alText = txt}) -- | The 'TextFunction' to render the text of the axis label. - axisLabelTextFunction :: Functor f => LensLike' f a (TextFunction (V a)) + axisLabelTextFunction :: Functor f => LensLike' f a (TextFunction b (V a) (N a)) axisLabelTextFunction = axisLabel . lens alFun (\al f -> al {alFun = f}) -- | The gap between the axis and the labels, in the direction -- corresponding to the 'axisLabelPosition'. - axisLabelGap :: Functor f => LensLike' f a Double + axisLabelGap :: Functor f => LensLike' f a (N a) axisLabelGap = axisLabel . lens alGap (\al sty -> al {alGap = sty}) -- | The 'Style' to use on the rendered text. - axisLabelStyle :: Functor f => LensLike' f a (Style (V a) Double) + axisLabelStyle :: Functor f => LensLike' f a (Style (V a) (N a)) axisLabelStyle = axisLabel . lens alStyle (\al sty -> al {alStyle = sty}) -- | The position the label will be placed parallel to the axis. @@ -124,37 +124,25 @@ axisLabelPlacement :: Functor f => LensLike' f a AxisLabelPosition axisLabelPlacement = axisLabel . lens alPos (\al sty -> al {alPos = sty}) -instance HasAxisLabel f (AxisLabel v) where +instance HasAxisLabel f (AxisLabel b v n) b where axisLabel = id -instance ApplyStyle (AxisLabel v) -instance HasStyle (AxisLabel v) where - style = axisLabelStyle +instance Typeable n => HasStyle (AxisLabel b v n) where + applyStyle = over axisLabelStyle . applyStyle -instance HasVisibility (AxisLabel v) where +instance HasVisibility (AxisLabel b v n) where visible = lens alVisible (\al b -> al {alVisible = b}) -instance HasGap (AxisLabel v) where +instance HasGap (AxisLabel b v n) where gap = axisLabelGap -instance Default (AxisLabel V2) where +instance (TypeableFloat n, Renderable (Text n) b) + => Default (AxisLabel b V2 n) where def = AxisLabel { alFun = mkText , alText = "" , alStyle = mempty & fontSize (output 11) - & backupFillColor black - , alGap = 30 - , alPos = MiddleAxisLabel - , alPlacement = OutsideAxisLabel - , alVisible = True - } - -instance Default (AxisLabel V3) where - def = AxisLabel - { alFun = mempty - , alText = "" - , alStyle = mempty & fontSize (output 11) - -- & backupFillColor black + & recommendFillColor black , alGap = 30 , alPos = MiddleAxisLabel , alPlacement = OutsideAxisLabel @@ -167,32 +155,32 @@ -- | 'TickLabels' describes how to draw the labels next to ticks. See -- 'HasTickLabels' for more options. -data TickLabels v = TickLabels - { tlFun :: [Double] -> (Double,Double) -> [(Double, String)] - , tlTextFun :: TextFunction v - , tlStyle :: Style v Double - , tlGap :: Double +data TickLabels b v n = TickLabels + { tlFun :: [n] -> (n,n) -> [(n, String)] + , tlTextFun :: TextFunction b v n + , tlStyle :: Style v n + , tlGap :: n , tlVisible :: Bool } deriving Typeable -type instance V (TickLabels v) = v -type instance N (TickLabels v) = Double +type instance V (TickLabels b v n) = v +type instance N (TickLabels b v n) = n -class HasTickLabels f a where +class HasTickLabels f a b | a -> b where -- | The options for the label of ticks. This can be used on various -- levels of the axis: -- -- @ - -- 'tickLabel' :: 'Traversal'' ('Tick' c) ('TickLabels' ('BaseSpace' c)) - -- 'tickLabel' :: 'Lens'' ('SingleAxis' v) ('TickLabels' v) - -- 'tickLabel' :: 'Lens'' ('TickLabel' v) ('TickLabels' v) + -- 'tickLabel' :: 'Traversal'' ('Tick' b c n) ('TickLabels' ('BaseSpace' c) n) + -- 'tickLabel' :: 'Lens'' ('SingleAxis' b v n) ('TickLabels' v n) + -- 'tickLabel' :: 'Lens'' ('TickLabel' v n) ('TickLabels' v n) -- @ - tickLabel :: LensLike' f a (TickLabels (V a)) + tickLabel :: LensLike' f a (TickLabels b (V a) (N a)) -- | The 'TextFunction' to render the text. -- -- 'Default' is 'mkText'. - tickLabelTextFunction :: Functor f => LensLike' f a (TextFunction (V a)) + tickLabelTextFunction :: Functor f => LensLike' f a (TextFunction b (V a) (N a)) tickLabelTextFunction = tickLabel . lens tlTextFun (\tl f -> tl {tlTextFun = f}) -- | Tick labels functions are used to draw the tick labels. They have @@ -200,48 +188,39 @@ -- position of the tick and label to use at that position. -- -- 'Default' is @'atMajorTicks' 'floatShow'@ - tickLabelFunction :: Functor f => LensLike' f a ([Double] -> (Double, Double) -> [(Double, String)]) + tickLabelFunction :: Functor f => LensLike' f a ([N a] -> (N a, N a) -> [(N a, String)]) tickLabelFunction = tickLabel . lens tlFun (\tl f -> tl {tlFun = f}) -- | The 'Style' to use on the rendered text. -- -- 'Default' is @'fontSize' ('output' 11)@. - tickLabelStyle :: Functor f => LensLike' f a (Style (V a) Double) + tickLabelStyle :: Functor f => LensLike' f a (Style (V a) (N a)) tickLabelStyle = tickLabel . lens tlStyle (\tl sty -> tl {tlStyle = sty}) -- | The gap between the axis and the tick labels. -- -- 'Default' is @12@. - tickLabelGap :: Functor f => LensLike' f a Double + tickLabelGap :: Functor f => LensLike' f a (N a) tickLabelGap = tickLabel . lens tlGap (\tl n -> tl {tlGap = n}) -instance HasTickLabels f (TickLabels v) where +instance HasTickLabels f (TickLabels b v n) b where tickLabel = id -instance HasGap (TickLabels v) where +instance HasGap (TickLabels b v n) where gap = tickLabelGap -instance Default (TickLabels V2) where +instance (TypeableFloat n, Renderable (Text n) b) + => Default (TickLabels b V2 n) where def = TickLabels { tlFun = atMajorTicks floatShow , tlTextFun = mkText , tlStyle = mempty & fontSize (output 11) - & backupFillColor black - , tlGap = 12 - , tlVisible = True - } - -instance Default (TickLabels V3) where - def = TickLabels - { tlFun = atMajorTicks floatShow - , tlTextFun = mempty - , tlStyle = mempty & fontSize (output 11) - -- & sc black + & recommendFillColor black , tlGap = 12 , tlVisible = True } -instance HasVisibility (TickLabels v) where +instance HasVisibility (TickLabels b v n) where visible = lens tlVisible (\tl b -> tl {tlVisible = b}) -- | Setter over the final positions the major ticks. This is not as @@ -258,7 +237,8 @@ -- If you want to change or add normal ticks see 'majorTicksFunction'. -- tickLabelPositions - :: (HasTickLabels f a, Settable f) => LensLike' f a [(Double, String)] + :: (HasTickLabels f a b, Settable f) + => LensLike' f a [(N a, String)] tickLabelPositions = tickLabelFunction . mapped . mapped -- | Numbers are shown as 'Float's to reduce the chance of numbers like @@ -268,7 +248,7 @@ -- | Make a 'TickLabelFunction' by specifying how to draw a single label -- from a position on the axis. -atMajorTicks :: (Double -> String) -> [Double] -> (Double,Double) -> [(Double, String)] +atMajorTicks :: (n -> String) -> [n] -> (n,n) -> [(n, String)] atMajorTicks f ticks _ = map ((,) <*> f) ticks -- -- | Use the list of strings as the labels for the axis, starting at 1 diff --git a/src/Plots/Axis/Line.hs b/src/Plots/Axis/Line.hs --- a/src/Plots/Axis/Line.hs +++ b/src/Plots/Axis/Line.hs @@ -48,20 +48,20 @@ def = BoxAxisLine -- | Information about position and style of axis lines. -data AxisLine v = AxisLine +data AxisLine v n = AxisLine { alType :: AxisLineType - -- , alArrowOpts :: Maybe ArrowOpts + , alArrowOpts :: Maybe (ArrowOpts n) , alVisible :: Bool - , alStyle :: Style v Double + , alStyle :: Style v n } deriving Typeable -type instance V (AxisLine v) = v -type instance N (AxisLine v) = Double +type instance V (AxisLine v n) = v +type instance N (AxisLine v n) = n -- | Class of object that have an 'AxisLine'. class HasAxisLine f a where -- | Lens onto the 'AxisLine'. - axisLine :: LensLike' f a (AxisLine (V a)) + axisLine :: LensLike' f a (AxisLine (V a) (N a)) -- | The position of the axis line around the axis. -- @@ -75,32 +75,28 @@ -- 'Default' is 'Nothing'. -- -- XXX (feature not currently implimented) - -- axisLineArrowOpts :: Functor f => LensLike' f a (Maybe (ArrowOpts (N a))) - -- axisLineArrowOpts = axisLine . lens alArrowOpts (\al sty -> al {alArrowOpts = sty}) + axisLineArrowOpts :: Functor f => LensLike' f a (Maybe (ArrowOpts (N a))) + axisLineArrowOpts = axisLine . lens alArrowOpts (\al sty -> al {alArrowOpts = sty}) -- | The 'Style' applied to the axis line - axisLineStyle :: Functor f => LensLike' f a (Style (V a) Double) + axisLineStyle :: Functor f => LensLike' f a (Style (V a) (N a)) axisLineStyle = axisLine . lens alStyle (\al sty -> al {alStyle = sty}) -instance HasAxisLine f (AxisLine v) where +instance HasAxisLine f (AxisLine v n) where axisLine = id -instance ApplyStyle (AxisLine v) -instance HasStyle (AxisLine v) where - style = axisLineStyle - -- Note this is different from 'NoAxisLine'. Other parts that are -- tied to the axis line will still be present when -- 'axisLineVisible' is 'False'. But if 'NoAxisLine' is set, there -- never any line for those things to attach to, so they don't -- exist. -instance HasVisibility (AxisLine v) where +instance HasVisibility (AxisLine v n) where visible = lens alVisible (\al b -> al {alVisible = b}) -instance Default (AxisLine v) where +instance Typeable n => Default (AxisLine v n) where def = AxisLine { alType = def - -- , alArrowOpts = def + , alArrowOpts = def , alVisible = True , alStyle = mempty } diff --git a/src/Plots/Axis/Render.hs b/src/Plots/Axis/Render.hs --- a/src/Plots/Axis/Render.hs +++ b/src/Plots/Axis/Render.hs @@ -39,9 +39,8 @@ import Data.List (sort) import Data.Typeable -import Geometry.BoundingBox +import Diagrams.BoundingBox import Diagrams.Prelude -import Geometry.Envelope import Diagrams.TwoD.Text import Linear hiding (rotate, translation) @@ -63,65 +62,37 @@ import Prelude -import qualified Numeric.Interval.NonEmpty as I - -import Geometry.TwoD.Transform -import Geometry.TwoD.Ellipse - -import Diagrams.Types (Prim (..), mkQD) - ------------------------------------------------------------------------ -- Mainable instances ------------------------------------------------------------------------ -instance WithOutcome (Axis Polar) -instance WithOutcome (Axis V2) -instance WithOutcome (Axis V3) - -instance RenderOutcome t (Diagram V2) => RenderOutcome t (Axis Polar) where - type MainOpts t (Axis Polar) = MainOpts t (Diagram V2) - resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V2)) - renderOutcome t opts axis = renderOutcome t opts (renderPolarAxis axis) - -instance RenderOutcome t (Diagram V2) => RenderOutcome t (Axis V2) where - type MainOpts t (Axis V2) = MainOpts t (Diagram V2) - resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V2)) - renderOutcome t opts axis = renderOutcome t opts (renderAxis axis) - -instance RenderOutcome t (Diagram V3) => RenderOutcome t (Axis V3) where - type MainOpts t (Axis V3) = MainOpts t (Diagram V3) - resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V3)) - renderOutcome t opts axis = renderOutcome t opts (renderAxis axis) - - -strokePathV :: (Typeable v, Metric v, Typeable n, OrderedField n) => Path v n -> QDiagram v n Any -strokePathV path = mkQD (Prim path) (getEnvelope path) mempty mempty - --- instance (TypeableFloat n, Mainable (Diagram V2)) --- => Mainable (Axis b Polar n) where --- type MainOpts (Axis b Polar n) = MainOpts (Diagram V2) +instance (TypeableFloat n, + Renderable (Path V2 n) b, + Mainable (QDiagram b V2 n Any)) + => Mainable (Axis b Polar n) where + type MainOpts (Axis b Polar n) = MainOpts (QDiagram b V2 n Any) --- mainRender opts = mainRender opts . renderAxis + mainRender opts = mainRender opts . renderAxis --- instance (TypeableFloat n, --- Renderable (Path V2 n) b, --- Mainable (Diagram V2)) --- => Mainable (Axis b V2 n) where --- type MainOpts (Axis b V2 n) = MainOpts (Diagram V2) +instance (TypeableFloat n, + Renderable (Path V2 n) b, + Mainable (QDiagram b V2 n Any)) + => Mainable (Axis b V2 n) where + type MainOpts (Axis b V2 n) = MainOpts (QDiagram b V2 n Any) --- mainRender opts = mainRender opts . renderAxis + mainRender opts = mainRender opts . renderAxis --- instance ToResult (Axis b v n) where --- type Args (Axis b v n) = () --- type ResultOf (Axis b v n) = Axis b v n +instance ToResult (Axis b v n) where + type Args (Axis b v n) = () + type ResultOf (Axis b v n) = Axis b v n --- toResult d _ = d + toResult d _ = d -- | 'mainWith' specialised to a 2D Axis. r2AxisMain - :: RenderOutcome t (Diagram V2) - => t - -> Axis V2 + :: (Parseable (MainOpts (QDiagram b V2 Double Any)), + Mainable (Axis b V2 Double)) + => Axis b V2 Double -> IO () r2AxisMain = mainWith @@ -137,7 +108,7 @@ -- legend entries can be obtained with 'styledPlotLegends'. This is -- what 'renderAxis' can uses internally but might be useful for -- debugging or generating your own legend. -buildPlots :: BaseSpace c ~ v => Axis c -> [StyledPlot v] +buildPlots :: BaseSpace c ~ v => Axis b c n -> [StyledPlot b v n] buildPlots a = map (appEndo $ a ^. plotModifier) $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) -- TODO: correct order @@ -147,21 +118,21 @@ ------------------------------------------------------------------------ -- | Renderable axes. -class RenderAxis c where +class RenderAxis b v n where -- | Render an axis to a diagram. The size of the diagram is -- determined by the 'axisSize'. - renderAxis :: Axis c -> Diagram (BaseSpace c) - --- R2 rendering -------------------------------------------------------- + renderAxis :: Axis b v n -> QDiagram b (BaseSpace v) n Any -- | The 'RenderAxis' class provides a default way to render an axis for -- each space. -instance RenderAxis V2 where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => RenderAxis b V2 n where -- | Render an axis and its plots, as well as the legend and colour -- bar. renderAxis = renderR2Axis -renderR2Axis :: Axis V2 -> Diagram V2 +renderR2Axis :: (TypeableFloat n, Renderable (Path V2 n) b) + => Axis b V2 n -> QDiagram b V2 n Any renderR2Axis a = frame 40 $ leg <> ttl @@ -188,41 +159,6 @@ -- styledPlots = buildPlots a --- R3 rendering -------------------------------------------------------- - - -instance RenderAxis V3 where - renderAxis = renderR3Axis - -renderR3Axis :: Axis V3 -> Diagram V3 -renderR3Axis a = -- frame 15 - -- -- $ legend - (plots :: Diagram V3) - <> (drawAxis ex ey LowerLabels :: Diagram V3) - <> (drawAxis ey ex UpperLabels :: Diagram V3) - <> (drawAxis ez ey LowerLabels :: Diagram V3) - <> (drawAxis ey ez NoLabels :: Diagram V3) - <> (drawAxis ez ex NoLabels :: Diagram V3) - <> (drawAxis ex ez NoLabels :: Diagram V3) - where - spec = AxisSpec xs t (a^.axes . column logScale) (a ^. axisColourMap) - plots = foldMap (renderStyledPlot spec) styledPlots - drawAxis ll ll2 = axisOnBasis origin xs (a^.axes.el ll) (a^.axes.column logScale) t ll ll2 - -- - (xs, tv, t') = calculateScaling (a^.axes.column axisScaling) (boundingBox styledPlots) - t = tv <> t' - -- - -- bb = fromCorners (P . apply t $ fmap fst xs) (P . apply t $ fmap snd xs) - -- leg = drawLegend bb (styledPlotLegends styledPlots) (a ^. legend) - -- - - -- The colour bar - -- cBar = addColourBar bb (a^.colourBar) (a ^. axisColourMap) (a^.colourBarRange) - -- title - -- ttl = drawTitle bb (a^.title) - -- - styledPlots = buildPlots a - -- | The position of axis labels for a data LabelPosition = NoLabels @@ -233,22 +169,23 @@ deriving (Show, Eq, Typeable) axisOnBasis - :: forall v. (HasLinearMap v, Typeable v) - => Point v Double -- start of axis - -> v (Double, Double) -- calculated bounds - -> SingleAxis v -- axis data + :: forall b v n. (v ~ V2, TypeableFloat n, HasLinearMap v, Metric v, + Renderable (Path V2 n) b, n ~ N (v n), v ~ V (v n), OrderedField n) + => Point v n -- start of axis + -> v (n, n) -- calculated bounds + -> SingleAxis b v n -- axis data -> v LogScale -- log scale - -> Transformation v Double -- transformation to apply to positions of things + -> T2 n -- transformation to apply to positions of things -> E v -- direction of axis -> E v -- orthogonal direction of axis -> LabelPosition -- where (if at all) should labels be placed? - -> Diagram v -- resulting axis + -> QDiagram b V2 n Any -- resulting axis axisOnBasis p bs a ls t e eO lp | a ^. hidden = phantom axis | otherwise = axis where axis = tickLabels <> axLabels <> ticks <> line <> grid - tStroke = strokePathV . transform t + tStroke = stroke . transform t -- axis labels (x,y etc.) axLabels @@ -326,13 +263,13 @@ maTicks | a ^. majorTicks . hidden = mempty | otherwise = foldMap (positionTick majorTick) majorTickXs' - # strokePathV + # stroke # applyStyle (a ^. majorTicksStyle) -- miTicks | a ^. minorTicks . hidden = mempty | otherwise = foldMap (positionTick minorTick) minorTickXs' - # strokePathV + # stroke # applyStyle (a ^. minorTicksStyle) -- minorTick = someTick (a ^. minorTicksAlignment) (a ^. minorTicksLength) @@ -363,16 +300,16 @@ | a ^. axisLine . hidden = mempty | otherwise = foldMap mkline (map snd ys) -- merge with ticks? # transform t - # strokePathV + # stroke # lineCap LineCapSquare # applyStyle (a^.axisLineStyle) where -- TODO: Arrow for R3 mkline y = pathFromVertices - $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v Double + $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v n -- measurements - b@(x0,x1) = bs ^. el e :: (Double, Double) -- bounds + b@(x0,x1) = bs ^. el e :: (n, n) -- bounds coscale = ep e %~ coscaleNum coscaleNum = scaleNum (bs ^. el e) (ls ^. el e) yb@(y0,y1) = bs ^. el eO . if lp == UpperLabels @@ -427,7 +364,8 @@ -- Polar ------------------------------------------------------------------------ -instance RenderAxis Polar where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => RenderAxis b Polar n where renderAxis = renderPolarAxis -- | An lower and upper bound for the bounding radius using @n@ envelope @@ -435,15 +373,15 @@ -- the bound. boundingRadiusR :: (InSpace V2 n a, Enveloped a) => Int -> a -> (n, n) boundingRadiusR (max 3 -> n) e = - case getEnvelope e of - EmptyEnvelope -> (0,0) - Envelope f -> + case appEnvelope (getEnvelope e) of + Nothing -> (0,0) + Just f -> let thetas = map (@@rad) $ enumFromToN 0 tau n - vs = map angleDir thetas + vs = map angleV thetas -- The lower bound is the maximum distance obtained from the -- envelope trials. We know the radius will be at least this far. - lowerBound = F.foldr (\v r -> max (I.sup $ f v) r) 0 vs + lowerBound = F.foldr (\v r -> max (f v) r) 0 vs -- In the worst case, there will be a point at the intersection of -- two neighbouring bounding planes from the envelope calculations. @@ -456,7 +394,9 @@ in (lowerBound, upperBound) -renderPolarAxis :: Axis Polar -> Diagram V2 +renderPolarAxis + :: (TypeableFloat n, Renderable (Path V2 n) b) + => Axis b Polar n -> QDiagram b V2 n Any renderPolarAxis a = frame 15 $ leg -- <> colourBar @@ -480,7 +420,9 @@ styledPlots = map (appEndo $ a ^. plotModifier) $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) -drawPolarAxis :: AxisSpec V2 -> Polar (SingleAxis V2) -> Diagram V2 +drawPolarAxis + :: forall b n. (Renderable (Path V2 n) b, TypeableFloat n) + => AxisSpec V2 n -> Polar (SingleAxis b V2 n) -> QDiagram b V2 n Any drawPolarAxis spec (Polar (V2 rA thetaA)) = fcA transparent $ rAx <> thetaAx where -- use a radius of the upper x bound for the axis (this is not ideal) @@ -507,9 +449,8 @@ where -- XXX for now the radial axis is on the theta=0 line. Need some -- way to change this - line = fromVertices [origin, mkP2 r 0] - # applyStyle (rA^.axisLineStyle) - # transform t + line = (origin ~~ mkP2 r 0) # applyStyle (rA^.axisLineStyle) + # transform t -- Radial axis label ------------------------------------------------- @@ -554,8 +495,8 @@ someTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> fromVertices [mkP2 0 (-d*bb), mkP2 0 (d*aa)] - AutoTick -> fromVertices [mkP2 0 (-d) , mkP2 0 d ] + -> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa) + AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d -- Radial grid lines ------------------------------------------------- @@ -566,7 +507,7 @@ majorGridRs = view majorGridLinesFunction rA majorTickRs (0,r) majorGridRs' = map (*s) $ filter rInRange majorGridRs - rMajorGridLines :: Diagram V2 + rMajorGridLines :: QDiagram b V2 n Any rMajorGridLines | rA ^. majorGridLines . hidden = mempty | otherwise = F.foldMap circle (filter (>0) majorGridRs') @@ -574,7 +515,7 @@ minorGridRs = view minorGridLinesFunction rA minorTickRs (0,r) minorGridRs' = map (*s) $ filter rInRange minorGridRs - rMinorGridLines :: Diagram V2 + rMinorGridLines :: QDiagram b V2 n Any rMinorGridLines | rA ^. minorGridLines . hidden = mempty | otherwise = F.foldMap circle (filter (>0) minorGridRs') @@ -582,17 +523,17 @@ -- Radial tick labels ------------------------------------------------ - rAxTickLabels :: Diagram V2 + rAxTickLabels :: QDiagram b V2 n Any rAxTickLabels | rA ^. tickLabel . hidden = mempty | otherwise = F.foldMap rDrawTickLabel tickLabelRs -- The positions of the tick labels. - tickLabelRs :: [(Double, String)] + tickLabelRs :: [(n, String)] tickLabelRs = view tickLabelFunction rA (filter rInRange majorTickRs) (0,r) -- Draw a single tick label given the position and the string to use - rDrawTickLabel :: (Double,String) -> Diagram V2 + rDrawTickLabel :: (n,String) -> QDiagram b V2 n Any rDrawTickLabel (x,label) = view tickLabelTextFunction rA (BoxAlignedText 0.5 1) label # translate (V2 (s*x) (- view axisLabelGap rA)) @@ -666,8 +607,8 @@ someThetaTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> fromVertices [mkP2 (-d*bb) 0, mkP2 (d*aa) 0] - AutoTick -> fromVertices [mkP2 (-d) 0 , mkP2 d 0 ] + -> mkP2 (-d*bb) 0 ~~ mkP2 (d*aa) 0 + AutoTick -> mkP2 (-d) 0 ~~ mkP2 d 0 -- Angular grid lines ------------------------------------------------ @@ -679,35 +620,35 @@ majorGridThetas = view majorGridLinesFunction thetaA majorTickThetas (0,theta) majorGridThetas' = filter thetaInRange majorGridThetas - thetaMajorGridLines :: Diagram V2 + thetaMajorGridLines :: QDiagram b V2 n Any thetaMajorGridLines | thetaA ^. majorGridLines . hidden = mempty - | otherwise = F.foldMap (\phi -> fromVertices [origin, mkP2 r 0] # rotate (phi@@rad)) majorGridThetas' + | otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) majorGridThetas' # transform t # applyStyle (thetaA ^. majorGridLinesStyle) minorGridThetas = view minorGridLinesFunction thetaA minorTickThetas (0,theta) minorGridThetas' = filter thetaInRange minorGridThetas - thetaMinorGridLines :: Diagram V2 + thetaMinorGridLines :: QDiagram b V2 n Any thetaMinorGridLines | thetaA ^. minorGridLines . hidden = mempty - | otherwise = F.foldMap (\phi -> fromVertices [origin, mkP2 r 0] # rotate (phi@@rad)) minorGridThetas' + | otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) minorGridThetas' # transform t # applyStyle (thetaA ^. minorGridLinesStyle) -- Angular tick labels ----------------------------------------------- - thetaAxTickLabels :: Diagram V2 + thetaAxTickLabels :: QDiagram b V2 n Any thetaAxTickLabels | thetaA ^. tickLabel . hidden = mempty | otherwise = F.foldMap thetaDrawTickLabel tickLabelThetas -- The positions of the tick labels. - tickLabelThetas :: [(Double, String)] + tickLabelThetas :: [(n, String)] tickLabelThetas = view tickLabelFunction thetaA majorTickThetas' (0,theta) -- Draw a single tick label given the position and the string to use - thetaDrawTickLabel :: (Double, String) -> Diagram V2 + thetaDrawTickLabel :: (n, String) -> QDiagram b V2 n Any thetaDrawTickLabel (x,label) = view tickLabelTextFunction thetaA a label # translate v diff --git a/src/Plots/Axis/Scale.hs b/src/Plots/Axis/Scale.hs --- a/src/Plots/Axis/Scale.hs +++ b/src/Plots/Axis/Scale.hs @@ -29,7 +29,7 @@ , LogScale (..) , logNumber , logPoint - -- , logDeform + , logDeform -- * Low level calculations -- | These functions are used by "Plots.Axis.Render". @@ -44,7 +44,7 @@ import Data.Default import Data.Distributive import Data.Maybe --- import qualified Data.Foldable as F +import qualified Data.Foldable as F import Diagrams import Linear @@ -71,23 +71,23 @@ -- | Data type used that concerns everything to do with the size or -- scale of the axis. -data AxisScaling = Scaling - { asRatio :: Maybe Double +data AxisScaling n = Scaling + { asRatio :: Maybe n , asMode :: ScaleMode - , asEnlarge :: Extending - , asBoundMin :: Maybe Double - , asBoundMax :: Maybe Double - , asSize :: Maybe Double + , asEnlarge :: Extending n + , asBoundMin :: Maybe n + , asBoundMax :: Maybe n + , asSize :: Maybe n , asLogScale :: LogScale -- backup bound in case there's no inferred bounds to go by - , asBackupBoundMax :: Double - , asBackupBoundMin :: Double + , asBackupBoundMax :: n + , asBackupBoundMin :: n } -type instance N AxisScaling = Double +type instance N (AxisScaling n) = n -instance Default AxisScaling where +instance Fractional n => Default (AxisScaling n) where def = Scaling { asRatio = Nothing , asMode = AutoScale @@ -101,24 +101,24 @@ } -- | How much to extend the bounds beyond any inferred bounds. -data Extending - = AbsoluteExtend !Double - | RelativeExtend !Double - deriving (Show, Ord, Eq) +data Extending n + = AbsoluteExtend n + | RelativeExtend n + deriving (Show, Ord, Eq, Functor) -- | Do not extend the axis beyond the inferred bounds. -noExtend :: Extending +noExtend :: Num n => Extending n noExtend = AbsoluteExtend 0 -- | Class of things that have an 'AxisScaling'. class HasAxisScaling f a where -- | The way to scale in one direction. - axisScaling :: LensLike' f a AxisScaling + axisScaling :: LensLike' f a (AxisScaling (N a)) -- | The ratio relative to other axis. If no ratios are set, the ratio -- is not enforced. If at least one is set, 'Nothing' ratios are -- @1@. - scaleAspectRatio :: Functor f => LensLike' f a (Maybe Double) + scaleAspectRatio :: Functor f => LensLike' f a (Maybe (N a)) scaleAspectRatio = axisScaling . lens asRatio (\as r -> as {asRatio = r}) -- | The mode to determine how to scale the bounds in a direction. @@ -137,7 +137,7 @@ -- | How much to extend the bounds over infered bounds. This is -- ignored if a 'boundMax' or 'boundMin' is set. - axisExtend :: Functor f => LensLike' f a Extending + axisExtend :: Functor f => LensLike' f a (Extending (N a)) axisExtend = axisScaling . lens asEnlarge (\as r -> as {asEnlarge = r}) -- | The maximum bound the axis. There are helper functions for @@ -149,7 +149,7 @@ -- @ -- -- Default is 'Nothing'. - boundMin :: Functor f => LensLike' f a (Maybe Double) + boundMin :: Functor f => LensLike' f a (Maybe (N a)) boundMin = axisScaling . lens asBoundMin (\as b -> as {asBoundMin = b}) -- | The maximum bound the axis. There are helper functions for @@ -162,30 +162,31 @@ -- @ -- -- Default is 'Nothing'. - boundMax :: Functor f => LensLike' f a (Maybe Double) + boundMax :: Functor f => LensLike' f a (Maybe (N a)) boundMax = axisScaling . lens asBoundMax (\as b -> as {asBoundMax = b}) -- | The size of the rendered axis. Default is @'Just' 400@. - renderSize :: Functor f => LensLike' f a (Maybe Double) + renderSize :: Functor f => LensLike' f a (Maybe (N a)) renderSize = axisScaling . lens asSize (\as s -> as {asSize = s}) -- -- backup bound in case there's no inferred bounds to go by -- asBackupBoundMax :: n -- asBackupBoundMax :: n -asSizeSpec :: HasLinearMap v => Lens' (v AxisScaling) (SizeSpec v Double) +asSizeSpec :: (HasLinearMap v, Num n, Ord n) => Lens' (v (AxisScaling n)) (SizeSpec v n) asSizeSpec = column renderSize . iso mkSizeSpec getSpec -instance HasAxisScaling f AxisScaling where +instance HasAxisScaling f (AxisScaling n) where axisScaling = id -- calculating bounds -------------------------------------------------- -- | Calculating the bounds for an axis. calculateBounds - :: AxisScaling -- ^ Scaling to use for this axis - -> Maybe (Double, Double) -- ^ Inferred bounds (from any plots) - -> (Double, Double) -- ^ Lower and upper bounds to use for this axis + :: OrderedField n + => AxisScaling n -- ^ Scaling to use for this axis + -> Maybe (n, n) -- ^ Inferred bounds (from any plots) + -> (n, n) -- ^ Lower and upper bounds to use for this axis calculateBounds Scaling {..} mInferred = (l', u') where -- bounds are only enlarged when min/max bound wasn't set l' = l & whenever (isNothing asBoundMin) (subtract x) @@ -214,10 +215,10 @@ -- - scale to match desired 'scaleAspectRatio' -- - scale to match desired 'asSizeSpec' calculateScaling - :: (HasLinearMap v, Applicative v) - => v AxisScaling -- ^ axis scaling options - -> BoundingBox v Double -- ^ bounding box from the axis plots - -> (v (Double,Double), Transformation v Double, Transformation v Double) + :: (HasLinearMap v, OrderedField n, Applicative v) + => v (AxisScaling n) -- ^ axis scaling options + -> BoundingBox v n -- ^ bounding box from the axis plots + -> (v (n,n), Transformation v n, Transformation v n) calculateScaling aScaling bb = (bounds, aspectScaling, sizeScaling) where -- final bounds of the axis @@ -230,8 +231,8 @@ -- aScaling. Otherwise no ratios are set, ignore them and scale -- such that each axis is the same length | anyOf (folded . scaleAspectRatio) isJust aScaling - = scalingV $ view (scaleAspectRatio . non 1) <$> aScaling - | otherwise = inv $ scalingV v + = vectorScaling $ view (scaleAspectRatio . non 1) <$> aScaling + | otherwise = inv $ vectorScaling v -- scaling used so the axis fits in the size spec sizeScaling = requiredScaling szSpec v' @@ -241,6 +242,11 @@ v' = apply aspectScaling v szSpec = view asSizeSpec aScaling +-- | Scale transformation using the respective scale coefficients in the vector. +vectorScaling :: (Additive v, Fractional n) => v n -> Transformation v n +vectorScaling v = fromLinear f f + where f = liftI2 (*) v <-> liftI2 (flip (/)) v + -- | Apply a function if the predicate is true. whenever :: Bool -> (a -> a) -> a -> a whenever b f = bool id f b @@ -277,9 +283,9 @@ -- | Deform an object according to the axis scale. Does nothing for -- linear scales. --- logDeform :: (InSpace v n a, F.Foldable v, Floating n, Deformable a a) --- => v LogScale -> a -> a --- logDeform v --- | allOf folded (== LinearAxis) v = id --- | otherwise = deform (Deformation $ logPoint v) +logDeform :: (InSpace v n a, F.Foldable v, Floating n, Deformable a a) + => v LogScale -> a -> a +logDeform v + | allOf folded (== LinearAxis) v = id + | otherwise = deform (Deformation $ logPoint v) diff --git a/src/Plots/Axis/Ticks.hs b/src/Plots/Axis/Ticks.hs --- a/src/Plots/Axis/Ticks.hs +++ b/src/Plots/Axis/Ticks.hs @@ -52,6 +52,7 @@ ) where import Control.Lens hiding (transform, ( # )) +import Data.Data import Data.Default import Data.Foldable as F import Data.Ord @@ -103,15 +104,15 @@ ------------------------------------------------------------------------ -- | The big ticks on the axis line. -data MajorTicks v = MajorTicks - { matFunction :: (Double,Double) -> [Double] +data MajorTicks v n = MajorTicks + { matFunction :: (n,n) -> [n] , matAlign :: TicksAlignment - , matLength :: Double - , matStyle :: Style v Double + , matLength :: n + , matStyle :: Style v n , matVisible :: Bool } -instance Default (MajorTicks v) where +instance TypeableFloat n => Default (MajorTicks v n) where def = MajorTicks { matFunction = linearMajorTicks 5 , matAlign = autoTicks @@ -120,20 +121,20 @@ , matVisible = True } -type instance V (MajorTicks v) = v -type instance N (MajorTicks v) = Double +type instance V (MajorTicks v n) = v +type instance N (MajorTicks v n) = n -- | Class of things that have a 'MajorTicks'. class HasMajorTicks f a where -- | Lens onto the 'MajorTicks' of something. - majorTicks :: LensLike' f a (MajorTicks (V a)) + majorTicks :: LensLike' f a (MajorTicks (V a) (N a)) -- | The function used to place ticks for this axis, given the bounds -- of the axis. The result of these major ticks are also used as -- guides for 'MinorTicks', 'MajorGridLines' and 'MinorGridLines'. -- -- Default is @'linearMinorTicks' 5@. - majorTicksFunction :: Functor f => LensLike' f a ((Double, Double) -> [Double]) + majorTicksFunction :: Functor f => LensLike' f a ((N a, N a) -> [N a]) majorTicksFunction = majorTicks . lens matFunction (\mat a -> mat {matFunction = a}) -- | Alignment of the major ticks. Choose between 'autoTicks' @@ -144,42 +145,38 @@ -- | The total length the major ticks. -- -- Default is @7@. - majorTicksLength :: Functor f => LensLike' f a Double + majorTicksLength :: Functor f => LensLike' f a (N a) majorTicksLength = majorTicks . lens matLength (\mat a -> mat {matLength = a}) -- | The style used to render the major ticks. -- -- Default is @'lwO' 0.6 'mempty'@ (subject to change). - majorTicksStyle :: Functor f => LensLike' f a (Style (V a) Double) + majorTicksStyle :: Functor f => LensLike' f a (Style (V a) (N a)) majorTicksStyle = majorTicks . lens matStyle (\mat sty -> mat {matStyle = sty}) -instance HasMajorTicks f (MajorTicks v) where +instance HasMajorTicks f (MajorTicks v n) where majorTicks = id -instance HasVisibility (MajorTicks v) where +instance HasVisibility (MajorTicks v n) where visible = lens matVisible (\mat b -> mat {matVisible = b}) -instance ApplyStyle (MajorTicks v) where -instance HasStyle (MajorTicks v) where - style = majorTicksStyle - ------------------------------------------------------------------------ -- Minor ticks ------------------------------------------------------------------------ -- | The small ticks on the axis line. -data MinorTicks v = MinorTicks - { mitFunction :: [Double] -> (Double,Double) -> [Double] +data MinorTicks v n = MinorTicks + { mitFunction :: [n] -> (n,n) -> [n] , mitAlign :: TicksAlignment - , mitLength :: Double - , mitStyle :: Style v Double + , mitLength :: n + , mitStyle :: Style v n , mitVisible :: Bool } -type instance V (MinorTicks v) = v -type instance N (MinorTicks v) = Double +type instance V (MinorTicks v n) = v +type instance N (MinorTicks v n) = n -instance Default (MinorTicks v) where +instance TypeableFloat n => Default (MinorTicks v n) where def = MinorTicks { mitFunction = minorTicksHelper 4 , mitAlign = autoTicks @@ -191,13 +188,13 @@ -- | Class of things that have a single 'MinorTicks'. class HasMinorTicks f a where -- | Lens onto the 'MinorTicks' of something. - minorTicks :: LensLike' f a (MinorTicks (V a)) + minorTicks :: LensLike' f a (MinorTicks (V a) (N a)) -- | The function used to place ticks for this axis, given the result -- of 'majorTicksFunction' and the bounds of the axis. -- -- Default is @'linearMinorTicks' 3@. - minorTicksFunction :: Functor f => LensLike' f a ([Double] -> (Double, Double) -> [Double]) + minorTicksFunction :: Functor f => LensLike' f a ([N a] -> (N a, N a) -> [N a]) minorTicksFunction = minorTicks . lens mitFunction (\mit a -> mit {mitFunction = a}) -- | Alignment of the minor ticks. Choose between 'autoTicks' @@ -208,56 +205,52 @@ -- | The total length the minor ticks. -- -- Default is @3@. - minorTicksLength :: Functor f => LensLike' f a Double + minorTicksLength :: Functor f => LensLike' f a (N a) minorTicksLength = minorTicks . lens mitLength (\mit a -> mit {mitLength = a}) -- | The style used to render the minor ticks. -- -- Default is @'lwO' 0.4 'mempty'@ (subject to change). - minorTicksStyle :: Functor f => LensLike' f a (Style (V a) Double) + minorTicksStyle :: Functor f => LensLike' f a (Style (V a) (N a)) minorTicksStyle = minorTicks . lens mitStyle (\mit sty -> mit {mitStyle = sty}) -instance HasMinorTicks f (MinorTicks v) where +instance HasMinorTicks f (MinorTicks v n) where minorTicks = id -instance HasVisibility (MinorTicks v) where +instance HasVisibility (MinorTicks v n) where visible = lens mitVisible (\mit sty -> mit {mitVisible = sty}) -instance ApplyStyle (MinorTicks v) where -instance HasStyle (MinorTicks v) where - style = minorTicksStyle - ------------------------------------------------------------------------ -- Both ticks ------------------------------------------------------------------------ -- | Both 'MajorTicks' and 'MinorTicks' together. -data Ticks v = Ticks (MajorTicks v) (MinorTicks v) +data Ticks v n = Ticks (MajorTicks v n) (MinorTicks v n) -- Ticks are originally split up into major and minor so we can reuse -- major for the colour bar. I'm still undecided whether it's worth all -- the extra boilerplate here. -type instance V (Ticks v) = v -type instance N (Ticks v) = Double +type instance V (Ticks v n) = v +type instance N (Ticks v n) = n -- | Class of things with both 'MajorTicks' and 'MinorTicks'. class (HasMinorTicks f a, HasMajorTicks f a) => HasTicks f a where - bothTicks :: LensLike' f a (Ticks (V a)) + bothTicks :: LensLike' f a (Ticks (V a) (N a)) -instance Functor f => HasTicks f (Ticks v) where +instance Functor f => HasTicks f (Ticks v n) where bothTicks = id -instance Functor f => HasMajorTicks f (Ticks v) where +instance Functor f => HasMajorTicks f (Ticks v n) where majorTicks f (Ticks ma mi) = f ma <&> \ma' -> Ticks ma' mi -instance Functor f => HasMinorTicks f (Ticks v) where +instance Functor f => HasMinorTicks f (Ticks v n) where minorTicks f (Ticks ma mi) = f mi <&> \mi' -> Ticks ma mi' -instance Default (Ticks v) where +instance TypeableFloat n => Default (Ticks v n) where def = Ticks def def -instance ApplyStyle (Ticks v) where - applyStyle = over ticksStyle . applyStyle +instance Typeable n => HasStyle (Ticks v n) where + applyStyle s = over ticksStyle (applyStyle s) -- | Traversal over both major and minor tick alignment. ticksAlign :: (HasTicks f a, Applicative f) => LensLike' f a TicksAlignment @@ -267,7 +260,7 @@ <$> f (a ^. majorTicksAlignment) <*> f (a ^. minorTicksAlignment) -- | Traversal over both major and minor tick styles. -ticksStyle :: (HasTicks f a, Applicative f) => LensLike' f a (Style (V a) Double) +ticksStyle :: (HasTicks f a, Applicative f) => LensLike' f a (Style (V a) (N a)) ticksStyle = bothTicks . styles where styles f a = (\m mn -> a & majorTicksStyle .~ m & minorTicksStyle .~ mn) @@ -298,7 +291,7 @@ -- you want to add or modify existing tick positions. majorTickPositions :: (HasMajorTicks f a, Settable f) - => LensLike' f a [Double] + => LensLike' f a [N a] majorTickPositions = majorTicksFunction . mapped -- | Setter over the final positions the major ticks. This is not as @@ -307,7 +300,7 @@ -- you want to add or modify existing tick positions. minorTickPositions :: (HasMinorTicks f a, Settable f) - => LensLike' f a [Double] + => LensLike' f a [N a] minorTickPositions = minorTicksFunction . mapped . mapped ------------------------------------------------------------------------ diff --git a/src/Plots/Axis/Title.hs b/src/Plots/Axis/Title.hs --- a/src/Plots/Axis/Title.hs +++ b/src/Plots/Axis/Title.hs @@ -30,17 +30,18 @@ import Diagrams.TwoD.Text import Plots.Types -data Title v = Title +data Title b v n = Title { tVisible :: Bool , tTxt :: String - , tTxtFun :: TextAlignment Double -> String -> Diagram v - , tStyle :: Style v Double + , tTxtFun :: TextAlignment n -> String -> QDiagram b v n Any + , tStyle :: Style v n , tPlacement :: Placement - , tAlignment :: TextAlignment Double - , tGap :: Double + , tAlignment :: TextAlignment n + , tGap :: n } deriving Typeable -instance Default (Title V2) where +instance (Renderable (Text n) b, TypeableFloat n) + => Default (Title b V2 n) where def = Title { tVisible = True , tTxt = "" @@ -51,31 +52,20 @@ , tGap = 20 } -instance Default (Title V3) where - def = Title - { tVisible = True - , tTxt = "" - , tTxtFun = mempty - , tStyle = mempty # fontSize (output 11) - , tPlacement = midAbove - , tAlignment = BoxAlignedText 0.5 0 - , tGap = 20 - } - -type instance V (Title v) = v -type instance N (Title v) = Double +type instance V (Title b v n) = v +type instance N (Title b v n) = n -instance HasVisibility (Title v) where +instance HasVisibility (Title b v n) where visible = lens tVisible (\t b -> t {tVisible = b}) -instance HasGap (Title v) where +instance HasGap (Title b v n) where gap = lens tGap (\t g -> t {tGap = g}) -instance HasPlacement (Title v) where +instance HasPlacement (Title b v n) where placement = titlePlacement -class HasTitle a where - title :: Lens' a (Title (V a)) +class HasTitle a b | a -> b where + title :: Lens' a (Title b (V a) (N a)) -- | The text used for the title. If the string is empty, no title is -- drawn. @@ -87,7 +77,7 @@ -- | The style applied to the title. -- -- Default is 'mempty'. - titleStyle :: Lens' a (Style (V a) Double) + titleStyle :: Lens' a (Style (V a) (N a)) titleStyle = title . lens tStyle (\t s -> t {tStyle = s}) -- | The placement of the title against the axis. @@ -99,30 +89,31 @@ -- | The function used to draw the title text. -- -- Default is 'mkText'. - titleTextFunction :: Lens' a (TextAlignment Double -> String -> Diagram (V a)) + titleTextFunction :: Lens' a (TextAlignment (N a) -> String -> QDiagram b (V a) (N a) Any) titleTextFunction = title . lens tTxtFun (\t s -> t {tTxtFun = s}) -- | The 'TextAlignment' used for the title text. This is given to the -- 'titleTextFunction'. -- -- Default is @'BoxAlignedText' 0.5 0@. - titleAlignment :: Lens' a (TextAlignment Double) + titleAlignment :: Lens' a (TextAlignment (N a)) titleAlignment = title . lens tAlignment (\t s -> t {tAlignment = s}) -- | The gap between the axis and the title. -- -- Default is 'mempty'. - titleGap :: Lens' a Double + titleGap :: Lens' a (N a) titleGap = title . lens tGap (\t s -> t {tGap = s}) -instance HasTitle (Title v) where +instance HasTitle (Title b v n) b where title = id -- | Render the title and place it around the bounding box. drawTitle - :: BoundingBox V2 Double - -> Title V2 - -> Diagram V2 + :: TypeableFloat n + => BoundingBox V2 n + -> Title b V2 n + -> QDiagram b V2 n Any drawTitle bb t | t ^. hidden || nullOf titleText t = mempty | otherwise = placeAgainst diff --git a/src/Plots/Legend.hs b/src/Plots/Legend.hs --- a/src/Plots/Legend.hs +++ b/src/Plots/Legend.hs @@ -23,58 +23,58 @@ import Data.Typeable import Diagrams.TwoD.Text -import Geometry.BoundingBox -import Diagrams.Prelude hiding (orient) +import Diagrams.BoundingBox +import Diagrams.Prelude import Plots.Types -- | The data type to describe how to draw a legend. For legend entries -- see 'Plots.Types.LegendEntry'. -data Legend = Legend +data Legend b n = Legend { lPlacement :: Placement - , lGap :: Double - , lStyle :: Style V2 Double - , lSpacing :: Double - , lTextWidth :: Double - , lTextF :: String -> Diagram V2 - , lTextStyle :: Style V2 Double + , lGap :: n + , lStyle :: Style V2 n + , lSpacing :: n + , lTextWidth :: n + , lTextF :: String -> QDiagram b V2 n Any + , lTextStyle :: Style V2 n , lOrientation :: Orientation , lVisible :: Bool } deriving Typeable -type instance V Legend = V2 -type instance N Legend = Double +type instance V (Legend b n) = V2 +type instance N (Legend b n) = n -class HasLegend a where +class HasLegend a b | a -> b where -- | Lens onto the 'Legend' of something. - legend :: Lens' a Legend + legend :: Lens' a (Legend b (N a)) -- | The 'Placement' of the legend relative to the 'Plots.Axis.Axis'. legendPlacement :: Lens' a Placement legendPlacement = legend . lens lPlacement (\l a -> l {lPlacement = a}) -- | The gap between the legend and the axis. - legendGap :: Lens' a Double + legendGap :: Lens' a (N a) legendGap = legend . lens lGap (\l a -> l {lGap = a}) -- | The style applied to the surronding box of the legend. - legendStyle :: Lens' a (Style V2 Double) + legendStyle :: Lens' a (Style V2 (N a)) legendStyle = legend . lens lStyle (\l a -> l {lStyle = a}) -- | The spacing between entries in the legend. - legendSpacing :: Lens' a Double + legendSpacing :: Lens' a (N a) legendSpacing = legend . lens lSpacing (\l a -> l {lSpacing = a}) -- | The space given for the text in the legend. - legendTextWidth :: Lens' a Double + legendTextWidth :: Lens' a (N a) legendTextWidth = legend . lens lTextWidth (\l a -> l {lTextWidth = a}) -- | The function to generate the legend text. - legendTextFunction :: Lens' a (String -> Diagram V2) + legendTextFunction :: Lens' a (String -> QDiagram b V2 (N a) Any) legendTextFunction = legend . lens lTextF (\l a -> l {lTextF = a}) -- | The style applied to the legend text. - legendTextStyle :: Lens' a (Style V2 Double) + legendTextStyle :: Lens' a (Style V2 (N a)) legendTextStyle = legend . lens lTextStyle (\l a -> l {lTextStyle = a}) -- | The way the legend entries are listed. (This will likely be @@ -82,16 +82,16 @@ legendOrientation :: Lens' a Orientation legendOrientation = legend . lens lOrientation (\l a -> l {lOrientation = a}) -instance HasLegend Legend where +instance HasLegend (Legend b n) b where legend = id -instance HasGap Legend where +instance HasGap (Legend b n) where gap = legendGap -instance HasPlacement Legend where +instance HasPlacement (Legend b n) where placement = legendPlacement -instance Default Legend where +instance (TypeableFloat n, Renderable (Text n) b) => Default (Legend b n) where def = Legend { lPlacement = rightTop , lGap = 20 @@ -104,26 +104,24 @@ , lVisible = True } -instance HasVisibility Legend where +instance HasVisibility (Legend b n) where visible = lens lVisible (\l a -> l {lVisible = a}) -instance ApplyStyle Legend - --- | The style for the bounding box of the legend. -instance HasStyle Legend where - style = legendStyle - {-# INLINE style #-} +instance TypeableFloat n => HasStyle (Legend b n) where + applyStyle sty = over legendStyle (applyStyle sty) -instance HasOrientation Legend where +instance HasOrientation (Legend b n) where orientation = legendOrientation -- | Draw a legend to the bounding box using the legend entries and -- legend options. drawLegend - :: BoundingBox V2 Double -- ^ bounding box to place legend against - -> [(Diagram V2, String)] -- ^ diagram pictures along with their key - -> Legend -- ^ options for drawing the legend - -> Diagram V2 -- ^ rendered legend + :: (TypeableFloat n, + Renderable (Path V2 n) b) + => BoundingBox V2 n -- ^ bounding box to place legend against + -> [(QDiagram b V2 n Any, String)] -- ^ diagram pictures along with their key + -> Legend b n -- ^ options for drawing the legend + -> QDiagram b V2 n Any -- ^ rendered legend drawLegend bb entries l | l ^. hidden || null entries = mempty | otherwise = placeAgainst diff --git a/src/Plots/Name.hs b/src/Plots/Name.hs --- a/src/Plots/Name.hs +++ b/src/Plots/Name.hs @@ -3,48 +3,48 @@ module Plots.Name where --- import Control.Lens --- -- import Data.Map (Map) --- import Data.Ord (comparing) --- import Data.Function --- import Data.Typeable --- import Diagrams.Types.Names --- import Diagrams.Prelude hiding (view) +import Control.Lens +-- import Data.Map (Map) +import Data.Ord (comparing) +import Data.Function +import Data.Typeable +import Diagrams.Core.Names +import Diagrams.Prelude hiding (view) --- data PlotName = PlotName --- { _plotName :: String --- , _namedSize2D :: SizeSpec V2 Double --- , _namedT2 :: T2 Double --- } deriving Typeable +data PlotName n = PlotName + { _plotName :: String + , _namedSize2D :: SizeSpec V2 n + , _namedT2 :: T2 n + } deriving Typeable --- makeLenses ''PlotName +makeLenses ''PlotName --- instance Show PlotName where --- show pn = "Plot: " ++ view plotName pn +instance Show (PlotName n) where + show pn = "Plot: " ++ view plotName pn --- -- equating :: Eq b => (a -> b) -> a -> a -> Bool --- -- equating = on (==) +-- equating :: Eq b => (a -> b) -> a -> a -> Bool +-- equating = on (==) --- instance Eq PlotName where --- (==) = on (==) (view plotName) +instance Eq (PlotName n) where + (==) = on (==) (view plotName) --- instance Ord PlotName where --- compare = comparing (view plotName) +instance Ord (PlotName n) where + compare = comparing (view plotName) --- instance IsName PlotName +instance Typeable n => IsName (PlotName n) --- -- _AName :: IsName a => Prism' AName a --- -- _AName = prism' AName (\(AName a) -> cast a) +-- _AName :: IsName a => Prism' AName a +-- _AName = prism' AName (\(AName a) -> cast a) --- -- _Names :: IsName a => Traversal' Name a --- -- _Names = _Wrapped' . traverse . _AName +-- _Names :: IsName a => Traversal' Name a +-- _Names = _Wrapped' . traverse . _AName --- -- _NamedString :: Traversal' Name String --- -- _NamedString = _Names +-- _NamedString :: Traversal' Name String +-- _NamedString = _Names --- -- _NamedPlot :: Typeable n => Traversal' Name (PlotName n) --- -- _NamedPlot = _Names +-- _NamedPlot :: Typeable n => Traversal' Name (PlotName n) +-- _NamedPlot = _Names --- -- diaNames :: OrderedField n => QDiagram b V2 n Any -> Map Name [P2 n] --- -- diaNames = over (mapped . traversed) location . view (subMap . _Wrapped') +-- diaNames :: OrderedField n => QDiagram b V2 n Any -> Map Name [P2 n] +-- diaNames = over (mapped . traversed) location . view (subMap . _Wrapped') diff --git a/src/Plots/Style.hs b/src/Plots/Style.hs --- a/src/Plots/Style.hs +++ b/src/Plots/Style.hs @@ -29,7 +29,6 @@ -- ** Predefined styles , fadedColours - , fadedColours3D , vividColours , blackAndWhite @@ -83,10 +82,6 @@ import Diagrams.Prelude hiding (magma) import Linear -import Diagrams.ThreeD.Attributes - -import Geometry - -- | Plot styles are used to style each plot in an axis. Every 'Axis' -- comes with a list of plots styles (contained in the 'AxisStyle') -- which get applied the plots upon rendering. @@ -126,23 +121,23 @@ -- 'histogramPlot') -- * 'markerStyle' - style used for markers in 'scatterPlot' -- * 'plotMarker' - marker used in 'scatterPlot' -data PlotStyle v = PlotStyle +data PlotStyle b v n = PlotStyle { _plotColour :: Colour Double - , _lineStyle :: Colour Double -> Style v Double - , _markerStyle :: Colour Double -> Style v Double - , _areaStyle :: Colour Double -> Style v Double - , _textStyle :: Colour Double -> Style v Double - , _plotMarker :: Diagram v + , _lineStyle :: Colour Double -> Style v n + , _markerStyle :: Colour Double -> Style v n + , _areaStyle :: Colour Double -> Style v n + , _textStyle :: Colour Double -> Style v n + , _plotMarker :: QDiagram b v n Any } deriving Typeable -- XXX link to examples in haddock? -type instance V (PlotStyle v) = v -type instance N (PlotStyle v) = Double +type instance V (PlotStyle b v n) = v +type instance N (PlotStyle b v n) = n -- | Class for objects that contain a 'PlotStyle'. -class HasPlotStyle f a where +class HasPlotStyle f a b | a -> b where -- | Lens onto the 'PlotStyle'. - plotStyle :: LensLike' f a (PlotStyle (V a)) + plotStyle :: LensLike' f a (PlotStyle b (V a) (N a)) -- | The 'plotColour' is the overall colour of the plot. This is passed -- to the other styles ('lineStyle', 'markerStyle' etc.) to give an @@ -157,60 +152,61 @@ -- | This style is applied to any plots made up of lines only (like -- 'Path' plots). This is a less general version of -- 'lineStyleFunction'. - lineStyle :: Settable f => LensLike' f a (Style (V a) Double) + lineStyle :: Settable f => LensLike' f a (Style (V a) (N a)) lineStyle = lineStyleFunction . mapped -- | A version 'lineStyle' with access to the current 'plotColour' -- when 'applyLineStyle' is used. - lineStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) + lineStyleFunction :: Functor f => LensLike' f a (Colour Double -> + Style (V a) (N a)) lineStyleFunction = plotStyle . lens _lineStyle (\p f -> p {_lineStyle = f}) -- | This style is applied to any markers in the plot (usually the -- 'plotMarker'). This is a less general version of -- 'markerStyleFunction'. - markerStyle :: Settable f => LensLike' f a (Style (V a) Double) + markerStyle :: Settable f => LensLike' f a (Style (V a) (N a)) markerStyle = markerStyleFunction . mapped -- | A version 'lineStyle' with access to the current 'plotColour' when -- 'applyMarkerStyle' is used. - markerStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) + markerStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) markerStyleFunction = plotStyle . lens _markerStyle (\p f -> p {_markerStyle = f}) -- | This style is applied to any filled areas in a plot (like -- 'Plots.Types.Bar' or 'Plots.Styles.Ribbon'). This is a less -- general version of 'areaStyleFunction'. - areaStyle :: Settable f => LensLike' f a (Style (V a) Double) + areaStyle :: Settable f => LensLike' f a (Style (V a) (N a)) areaStyle = areaStyleFunction . mapped -- | A version 'areaStyle' with access to the current 'plotColour' when -- 'applyAreaStyle' is used. - areaStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) + areaStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) areaStyleFunction = plotStyle . lens _areaStyle (\p f -> p {_areaStyle = f}) -- | This style is applied to text plots. This is a less general -- version of 'textStyleFunction'. - textStyle :: Settable f => LensLike' f a (Style (V a) Double) + textStyle :: Settable f => LensLike' f a (Style (V a) (N a)) textStyle = textStyleFunction . mapped -- | A version 'textStyle' with access to the current 'plotColour' when -- 'applyAreaStyle' is used. - textStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) + textStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) textStyleFunction = plotStyle . lens _textStyle (\p f -> p {_textStyle = f}) -- | This diagram is used as any markers in a plot (like -- 'Plots.Types.Scatter'). The 'markerStyle' will be applied to this -- marker when the plot gets rendered. - plotMarker :: Functor f => LensLike' f a (Diagram (V a)) + plotMarker :: Functor f => LensLike' f a (QDiagram b (V a) (N a) Any) plotMarker = plotStyle . lens _plotMarker (\p f -> p {_plotMarker = f}) -- | A traversal over all the styles ('lineStyle', 'markerStyle', -- 'areaStyle' and 'textStyle') of a 'PlotStyle'. This is a less -- general version of 'plotStyleFunctions'. - plotStyles :: Settable f => LensLike' f a (Style (V a) Double) + plotStyles :: Settable f => LensLike' f a (Style (V a) (N a)) plotStyles = plotStyleFunctions . mapped -- | A version of 'plotStyles' with access to the 'plotColour'. - plotStyleFunctions :: Applicative f => LensLike' f a (Colour Double -> Style (V a) Double) + plotStyleFunctions :: Applicative f => LensLike' f a (Colour Double -> Style (V a) (N a)) plotStyleFunctions = plotStyle . t where t f PlotStyle {..} = PlotStyle @@ -221,7 +217,7 @@ <*> f _textStyle <*> pure _plotMarker -instance HasPlotStyle f (PlotStyle v) where +instance HasPlotStyle f (PlotStyle b v n) b where plotStyle = id -- Applying styles ----------------------------------------------------- @@ -229,48 +225,48 @@ -- | Apply the 'lineStyle' from a 'PlotStyle'. -- -- @ --- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t +-- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t -- @ applyLineStyle - :: (InSpace v Double t, ApplyStyle t) - => PlotStyle v -> t -> t + :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) + => a -> t -> t applyLineStyle (view plotStyle -> sty) = applyStyle $ (sty ^. lineStyleFunction) (sty ^. plotColour) -- | Apply the 'markerStyle' from a 'PlotStyle'. -- -- @ --- applyMarkerStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t +-- applyMarkerStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t -- @ applyMarkerStyle - :: (InSpace v Double t, ApplyStyle t) - => PlotStyle v -> t -> t + :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) + => a -> t -> t applyMarkerStyle (view plotStyle -> sty) = applyStyle $ (sty ^. markerStyleFunction) (sty ^. plotColour) -- | Apply the 'areaStyle from a 'PlotStyle'. -- -- @ --- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t +-- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t -- @ applyAreaStyle - :: (InSpace v Double t, ApplyStyle t) - => PlotStyle v -> t -> t + :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) + => a -> t -> t applyAreaStyle (view plotStyle -> sty) = applyStyle $ (sty ^. areaStyleFunction) (sty ^. plotColour) -- | Apply the 'textStyle' from a 'PlotStyle'. -- -- @ --- applyTextStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t +-- applyTextStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t -- @ applyTextStyle - :: (InSpace v Double t, ApplyStyle t) - => PlotStyle v -> t -> t + :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) + => a -> t -> t applyTextStyle (view plotStyle -> sty) = applyStyle $ (sty ^. textStyleFunction) (sty ^. plotColour) -instance (Metric v, Traversable v) => Transformable (PlotStyle v) where +instance (Metric v, Traversable v, OrderedField n) => Transformable (PlotStyle b v n) where transform t = (plotMarker %~ transform t) . (plotStyles %~ transform t) ------------------------------------------------------------------------ @@ -279,15 +275,15 @@ -- | The 'AxisStyle' determines the 'Style's of the plots in an axis. -- There are various predefined styles to change the look of the plot. -data AxisStyle v = AxisStyle ColourMap [PlotStyle v] +data AxisStyle b v n = AxisStyle ColourMap [PlotStyle b v n] -type instance V (AxisStyle v) = v -type instance N (AxisStyle v) = Double +type instance V (AxisStyle b v n) = v +type instance N (AxisStyle b v n) = n -- | Class of things that have an 'AxisStyle'. -class HasAxisStyle a where +class HasAxisStyle a b | a -> b where -- | Lens onto the 'AxisStyle'. - axisStyle :: Lens' a (AxisStyle (V a)) + axisStyle :: Lens' a (AxisStyle b (V a) (N a)) -- | The 'ColourMap' is used to draw the 'Plots.Axis.ColourBar' and -- render plots like 'Plots.HeatMap'. @@ -297,14 +293,14 @@ -- | Traversal over the 'PlotStyle's in an 'AxisStyle'. There are always -- an infinite number of 'PlotStyle's in an 'AxisStyle'. - axisStyles :: IndexedTraversal' Int a (PlotStyle (V a)) + axisStyles :: IndexedTraversal' Int a (PlotStyle b (V a) (N a)) axisStyles = axisStyle . stys . traversed where stys f (AxisStyle c ss) = f ss <&> \ss' -> AxisStyle c ss' -instance HasAxisStyle (AxisStyle v) where +instance HasAxisStyle (AxisStyle b v n) b where axisStyle = id -instance Applicative f => HasPlotStyle f (AxisStyle v) where +instance Applicative f => HasPlotStyle f (AxisStyle b v n) b where plotStyle = axisStyles ------------------------------------------------------------------------ @@ -331,7 +327,7 @@ -- | Theme using 'funColours' with faded fills and thick lines. -- -- <> -fadedColours :: AxisStyle V2 +fadedColours :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n fadedColours = AxisStyle viridis $ zipWith mkStyle (cycle colours1) (cycle $ map stroke filledMarkers) where @@ -340,20 +336,10 @@ fadeS c = mempty # fc (blend 0.1 white c) # lc c # lwO 1 fillS c = mempty # fc c # lw none -fadedColours3D :: AxisStyle V3 -fadedColours3D = AxisStyle viridis $ - zipWith mkStyle (cycle colours1) shapeMarkers - where - mkStyle c = PlotStyle c lineS fadeS fadeS fillS - lineS c = mempty # lwO 3 :: Style V3 Double - fadeS c = mempty # sc (blend 0.1 white c) # lwO 3 :: Style V3 Double - fillS c = mempty # sc c # lw none :: Style V3 Double - - -- | Theme using 'funColours' with no lines on 'areaStyle. -- -- <> -vividColours :: AxisStyle V2 +vividColours :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n vividColours = AxisStyle viridis $ zipWith mkStyle (cycle colours2) (cycle $ map (scale 1.2 . stroke) filledMarkers) where @@ -365,7 +351,7 @@ -- | Theme without any colours, useful for black and white documents. -- -- <> -blackAndWhite :: AxisStyle V2 +blackAndWhite :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n blackAndWhite = AxisStyle greys $ zipWith3 mkStyle (cycle colours) (cycle lineStyles) (cycle $ map stroke filledMarkers) where @@ -411,18 +397,9 @@ -- | Markers which have a filling, used for 'fadedColours' and -- 'vividColours'. -shapeMarkers :: [Diagram V3] -shapeMarkers = scale 11 $ cycle - [ cube - , sphere - , cone - ] - --- | Markers which have a filling, used for 'fadedColours' and --- 'vividColours'. filledMarkers :: RealFloat n => [Path V2 n] -filledMarkers = scale 11 . map (centerXY . toPath) $ cycle - [ circle 0.5 :: RealFloat n => Trail V2 n +filledMarkers = scale 11 . map (centerXY . pathFromTrail) $ cycle + [ circle 0.5 , square 1 , triangle 1 , diamond (1 / sqrt 2) @@ -454,27 +431,27 @@ asterisk n x = mconcat . take n . iterate (rotateBy (1/fromIntegral n)) - $ fromVertices [origin, mkP2 0 x] + $ (0 ^& 0) ~~ (0 ^& x) -- | A rotated 'square'. -diamond :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t -diamond = fromLocTrail . rotateBy (1/8) . square +diamond :: (InSpace V2 n t, TrailLike t) => n -> t +diamond = trailLike . rotateBy (1/8) . square -- | A rotated 'plus'. -crossShape :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t -crossShape = fromLocTrail . rotateBy (1/8) . plus +crossShape :: (InSpace V2 n t, TrailLike t) => n -> t +crossShape = trailLike . rotateBy (1/8) . plus -- | Filled in @+@ symbol. -plus :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t -plus x = fromLocLoop . (`at` mkP2 (x/6) (x/6)) - . glueLine . mconcat . take 4 - . iterate (rotateBy (1/4)) . (^?! _init) +plus :: (InSpace V2 n t, TrailLike t) => n -> t +plus x = trailLike . (`at` mkP2 (x/6) (x/6)) + . wrapTrail . glueLine . mconcat . take 4 + . iterate (rotateBy (1/4)) . onLineSegments init $ square (x/3) -- | A filled in five sided start of size x. -star' :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t -star' x = fromLocLoop . (`at` mkP2 (-x/6) (x/6)) - . glueLine . mconcat . take 5 +star' :: (InSpace V2 n t, TrailLike t) => n -> t +star' x = trailLike . (`at` mkP2 (-x/6) (x/6)) + . wrapTrail . glueLine . mconcat . take 5 . iterate (rotateBy (-1/5)) $ spoke where spoke = fromOffsets . map r2 $ [(x/6,x/2), (x/6,-x/2)] @@ -611,8 +588,8 @@ (b,_) = M.findMax cm normalise x = (x - a) / (b - a) -toStops :: ColourMap -> [GradientStop] -toStops = map (\(x,c) -> GradientStop (opaque c) (fromRational x)) +toStops :: Fractional n => ColourMap -> [GradientStop n] +toStops = map (\(x,c) -> GradientStop (SomeColor c) (fromRational x)) . colourList -- Colour maps --------------------------------------------------------- diff --git a/src/Plots/Types.hs b/src/Plots/Types.hs --- a/src/Plots/Types.hs +++ b/src/Plots/Types.hs @@ -22,19 +22,19 @@ -- -- This module defines the various types for holding plots: -- --- [@'PlotOptions' v@] +-- [@'PlotOptions' b v n@] -- Generic options all plots have. -- --- [@'PlotMods' v@] +-- [@'PlotMods' b v n@] -- Includes 'PlotOptions' along with modifications to the 'PlotStyle'. -- --- [@'Plot' p@] +-- [@'Plot' p b@] -- A 'rawPlot' @p@ grouped with a 'PlotMods'. -- --- [@'DynamicPlot' v@] +-- [@'DynamicPlot' b v n@] -- A wrapped up 'Plot' so it can be stored in an 'Axis'. -- --- [@'StyledPlot' v@] +-- [@'StyledPlot' b v n@] -- A 'DynamicPlot' with a concrete 'PlotStyle', ready to be rendered. -- -- As well as other things like the 'Plotable' class, 'LegendEntries', @@ -131,18 +131,12 @@ import Data.Ord (comparing) import Data.Orphans () import Data.Typeable -import Diagrams.Prelude as D hiding (orient) +import Diagrams.Prelude as D import Plots.Axis.Scale import Plots.Style import Plots.Util --- XXX shouldn't need to import these -import Diagrams.Combinators as D -import Geometry.TwoD.Shapes - -import Diagrams.Types - -- Orientation --------------------------------------------------------- data Orientation = Horizontal | Vertical @@ -178,16 +172,16 @@ class HasGap a where -- | The value of the gap when rendering. - gap :: Lens' a Double + gap :: Lens' a (N a) -- | A 'Position' is a point on an axis together with an anchor and a -- direction for the gap. data Placement = Placement { pAt :: V2 Rational , pAnchor :: V2 Rational - , pGapDir :: Direction V2 Double + , pGapDir :: Direction V2 Rational } - deriving (Show, Eq) + deriving (Show, Read, Eq, Ord) -- In the future the axis position may be replaced by a reader-like -- anchor system where you can choose parts of the rendered axis as a -- position. @@ -210,7 +204,7 @@ placementAnchor = placement . lens pAnchor (\p a -> p {pAnchor = a}) -- | The direction to extend the 'gap' when positioning. - gapDirection :: Lens' a (Direction V2 Double) + gapDirection :: Lens' a (Direction V2 Rational) gapDirection = placement . lens pGapDir (\p a -> p {pGapDir = a}) instance HasPlacement Placement where @@ -223,11 +217,11 @@ pInside v = Placement { pAt = v , pAnchor = v - , pGapDir = dirBetween' (P $ fromRational <$> v) origin + , pGapDir = dirBetween' (P v) origin } -- | @dirBetween p q@ returns the directions from @p@ to @q@ -dirBetween' :: (Metric v, Floating n) => Point v n -> Point v n -> Direction v n +dirBetween' :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n dirBetween' p q = direction $ q .-. p @@ -266,11 +260,12 @@ -- | A tool for aligned one object to another. Positions @b@ around the -- bounding box of @a@ by translating @b@. placeAgainst - :: (InSpace V2 n a, SameSpace a b, Enveloped a, Enveloped b, HasOrigin b) + :: (InSpace V2 n a, SameSpace a b, Enveloped a, + HasOrigin b, Alignable b) => a -> Placement -> n -> b -> b placeAgainst a (Placement (V2 px py) (V2 ax ay) d) n b = b # anchor - # moveTo (pos .+^ n *^ fromDirection (realToFrac <$> d)) + # moveTo (pos .+^ n *^ fromDirection (fmap fromRational d)) where pos = mkP2 (lerp' px xu xl) (lerp' py yu yl) anchor = alignBy unitX (fromRational ax) . alignBy unitY (fromRational ay) @@ -285,26 +280,26 @@ -- | Type allowing use of the default legend picture (depending on the -- plot) or a custom legend picture with access to the 'PlotStyle'. -data LegendPic v +data LegendPic b v n = DefaultLegendPic - | CustomLegendPic (PlotStyle v -> Diagram v) + | CustomLegendPic (PlotStyle b v n -> QDiagram b v n Any) -instance Default (LegendPic v) where +instance Default (LegendPic b v n) where def = DefaultLegendPic -- | Data type for holding a legend entry. -data LegendEntry v = LegendEntry - { lPic :: LegendPic v +data LegendEntry b v n = LegendEntry + { lPic :: LegendPic b v n , lText :: String - , lPrecedence :: Double + , lPrecedence :: n } deriving Typeable -- | The picture used in the legend entry. -legendPicture :: Lens' (LegendEntry v) (LegendPic v) +legendPicture :: Lens' (LegendEntry b v n) (LegendPic b v n) legendPicture = lens lPic (\l pic -> l {lPic = pic}) -- | The text used in the legend entry. -legendText :: Lens' (LegendEntry v) String +legendText :: Lens' (LegendEntry b v n) String legendText = lens lText (\l txt -> l {lText = txt}) -- | The order in which the legend entries are rendered. If precedences @@ -312,15 +307,15 @@ -- axis. -- -- Default is @0@. -legendPrecedence :: Lens' (LegendEntry v) Double +legendPrecedence :: Lens' (LegendEntry b v n) n legendPrecedence = lens lPrecedence (\l n -> l {lPrecedence = n}) -type instance V (LegendEntry v) = v -type instance N (LegendEntry v) = Double +type instance V (LegendEntry b v n) = v +type instance N (LegendEntry b v n) = n -- | Make a legend entry with a default 'legendPicture' and -- 'legendPrecedence' 0 using the string as the 'legendText'. -mkLegendEntry :: String -> LegendEntry v +mkLegendEntry :: Num n => String -> LegendEntry b v n mkLegendEntry x = LegendEntry DefaultLegendPic x 0 ------------------------------------------------------------------------ @@ -330,24 +325,24 @@ -- Generic Plot info -- | Data type for holding information all plots must contain. -data PlotOptions v = PlotOptions +data PlotOptions b v n = PlotOptions { poName :: Name , poClipPlot :: Bool - , poLegend :: [LegendEntry v] + , poLegend :: [LegendEntry b v n] , poVisible :: Bool - , poTransform :: Transformation v Double + , poTransform :: Transformation v n -- , poPostPlotBoundingBox :: BoundingBox v n -> BoundingBox v n - -- , poPlotPostProduction :: QDiagram v Any -> QDiagram v Any + -- , poPlotPostProduction :: QDiagram b v n Any -> QDiagram b v n Any } deriving Typeable -type instance V (PlotOptions v) = v -type instance N (PlotOptions v) = Double +type instance V (PlotOptions b v n) = v +type instance N (PlotOptions b v n) = n -- | Class of things that have 'PlotOptions'. -class HasPlotOptions f a where +class HasPlotOptions f a b | a -> b where {-# MINIMAL plotOptions #-} -- | Lens onto the 'PlotOptions'. - plotOptions :: LensLike' f a (PlotOptions (V a)) + plotOptions :: LensLike' f a (PlotOptions b (V a) (N a)) -- | The 'Name' applied to the plot. This gives a way to reference a -- specific plot in a rendered axis. @@ -367,7 +362,7 @@ -- | The legend entries to be used for the current plot. -- -- 'Default' is 'mempty'. - legendEntries :: Functor f => LensLike' f a [LegendEntry (V a)] + legendEntries :: Functor f => LensLike' f a [LegendEntry b (V a) (N a)] legendEntries = plotOptions . lens poLegend (\g a -> g {poLegend = a}) {-# INLINE legendEntries #-} @@ -375,7 +370,7 @@ -- coordinates. -- -- 'Default' is 'mempty'. - plotTransform :: Functor f => LensLike' f a (Transformation (V a) Double) + plotTransform :: Functor f => LensLike' f a (Transformation (V a) (N a)) plotTransform = plotOptions . lens poTransform (\g a -> g {poTransform = a}) {-# INLINE plotTransform #-} @@ -387,7 +382,7 @@ plotVisible = plotOptions . lens poVisible (\po b -> po {poVisible = b}) {-# INLINE plotVisible #-} -instance (HasBasis v, Foldable v) => Default (PlotOptions v) where +instance (Additive v, Num n) => Default (PlotOptions b v n) where def = PlotOptions { poName = mempty , poClipPlot = True @@ -398,25 +393,25 @@ -- , poPlotPostProduction = id } -instance HasPlotOptions f (PlotOptions v) where +instance HasPlotOptions f (PlotOptions b v n) b where plotOptions = id {-# INLINE plotOptions #-} -instance HasLinearMap v => Transformable (PlotOptions v) where +instance (HasLinearMap v, Num n) => Transformable (PlotOptions b v n) where transform = over plotTransform . transform --- instance HasBounds (PlotOptions v) v where +-- instance HasBounds (PlotOptions b v n) v where -- bounds = plotBounds -- | Move origin by applying to @plotTransform@. -instance Additive v => HasOrigin (PlotOptions v) where +instance (Additive v, Num n) => HasOrigin (PlotOptions b v n) where moveOriginTo = over plotTransform . moveOriginTo -instance Qualifiable (PlotOptions v) where +instance Qualifiable (PlotOptions b v n) where n .>> p = over plotName (n .>>) p -- XXX template haskell getting in the way --- instance HasVisibility (PlotOptions v) where +-- instance HasVisibility (PlotOptions b v n) where -- visible = plotVisible -- | Add a 'LegendEntry' to something with 'PlotOptions' using the @@ -424,27 +419,27 @@ -- some typical examples: -- -- @ --- 'key' :: 'String' -> 'State' ('Plot' ('ScatterPlot' v)) () --- 'key' :: 'String' -> 'State' ('DynamicPlot' v) () --- 'key' :: 'String' -> 'State' ('PlotMods' v) () +-- 'key' :: 'String' -> 'State' ('Plot' ('ScatterPlot' v n) b) () +-- 'key' :: 'String' -> 'State' ('DynamicPlot' b v n) () +-- 'key' :: 'String' -> 'State' ('PlotMods' b v n) () -- @ -- -- If you only care about the name of the legend, use 'key'. -key :: (HasPlotOptions Identity a, MonadState a m) => String -> m () +key :: (HasPlotOptions Identity a b, MonadState a m, Num (N a)) => String -> m () key = addLegendEntry . mkLegendEntry -- | Add a 'LegendEntry' to something with 'PlotOptions'. Here are some -- typical examples: -- -- @ --- 'addLegendEntry' :: 'LegendEntry' v -> 'State' ('Plot' ('ScatterPlot' v)) () --- 'addLegendEntry' :: 'LegendEntry' v -> 'State' ('DynamicPlot' v) () +-- 'addLegendEntry' :: 'LegendEntry' b v n -> 'State' ('Plot' ('ScatterPlot' v n) b) () +-- 'addLegendEntry' :: 'LegendEntry' b v n -> 'State' ('DynamicPlot' b v n) () -- @ -- -- If you only care about the name of the legend, use 'key'. addLegendEntry - :: (HasPlotOptions Identity a, MonadState a m) - => LegendEntry (V a) + :: (HasPlotOptions Identity a b, MonadState a m) + => LegendEntry b (V a) (N a) -> m () addLegendEntry l = legendEntries <>= [l] @@ -456,17 +451,17 @@ ------------------------------------------------------------------------ -- | Information from the 'Plots.Axis.Axis' necessary to render a 'Plotable'. -data AxisSpec v = AxisSpec - { _specBounds :: v (Double, Double) - , _specTrans :: Transformation v Double +data AxisSpec v n = AxisSpec + { _specBounds :: v (n, n) + , _specTrans :: Transformation v n , _specScale :: v LogScale , _specColourMap :: ColourMap } makeLenses ''AxisSpec -type instance V (AxisSpec v) = v -type instance N (AxisSpec v) = Double +type instance V (AxisSpec v n) = v +type instance N (AxisSpec v n) = n -- | Scale a number by log10-ing it and linearly scaling it so it's -- within the same range. @@ -477,9 +472,7 @@ where d = b - a -- | Apply log scaling and the transform to a point. -specPoint - :: (Applicative v, Additive v, Foldable v) - => AxisSpec v -> Point v Double -> Point v Double +specPoint :: (Applicative v, Additive v, Floating n) => AxisSpec v n -> Point v n -> Point v n specPoint (AxisSpec bs tr ss _) p = papply tr $ over _Point (scaleNum <$> bs <*> ss <*>) p @@ -488,38 +481,36 @@ ------------------------------------------------------------------------ -- | Class defining how plots should be rendered. -class (Typeable p, Enveloped p, N p ~ Double) => Plotable p where +class (Typeable p, Enveloped p) => Plotable p b where -- | Render a plot according to the 'AxisSpec', using the 'PlotStyle'. renderPlotable - :: InSpace v Double p - => AxisSpec v - -> PlotStyle v + :: InSpace v n p + => AxisSpec v n + -> PlotStyle b v n -> p - -> Diagram v + -> QDiagram b v n Any -- | The default legend picture when the 'LegendPic' is -- 'DefaultLegendPic'. defLegendPic - :: InSpace v Double p - => PlotStyle v + :: InSpace v n p + => PlotStyle b v n -> p - -> Diagram v + -> QDiagram b v n Any defLegendPic = mempty -instance (Typeable v, HasLinearMap v) => Plotable (Diagram v) where +instance (Typeable b, Typeable v, Metric v, Typeable n, OrderedField n) + => Plotable (QDiagram b v n Any) b where renderPlotable s _ dia = dia # transform (s^.specTrans) -strokePathV :: (Typeable v, Metric v, Typeable n, OrderedField n) => Path v n -> QDiagram v n Any -strokePathV path = mkQD (Prim path) (getEnvelope path) mempty mempty - -instance (Typeable v, R1 v, HasLinearMap v) => Plotable (Path v Double) where +instance (TypeableFloat n, Renderable (Path V2 n) b) => Plotable (Path V2 n) b where renderPlotable s sty path - = strokePathV path + = stroke path # transform (s^.specTrans) # applyLineStyle sty defLegendPic sty _ - = strokePathV (fromVertices [(-10) *^ unitX, 10 *^ unitX]) + = (p2 (-10,0) ~~ p2 (10,0)) # applyLineStyle sty ------------------------------------------------------------------------ @@ -536,26 +527,26 @@ hidden = visible . involuted not {-# INLINE hidden #-} -instance HasVisibility (PlotOptions v) where +instance HasVisibility (PlotOptions b v n) where visible = plotVisible -instance HasVisibility (PlotMods v) where +instance HasVisibility (PlotMods b v n) where visible = plotVisible -instance HasVisibility (Plot p) where +instance HasVisibility (Plot p b) where visible = plotVisible -instance HasVisibility (DynamicPlot v) where +instance HasVisibility (DynamicPlot b v n) where visible = plotVisible -instance HasVisibility (StyledPlot v) where +instance HasVisibility (StyledPlot b v n) where visible = plotVisible -- | Set 'visible' to 'False' for the given setter. -- -- @ --- 'hide' 'minorTicks' :: 'State' ('Axis' v) () --- 'hide' ('xAxis' . 'gridLines') :: 'State' ('Axis' v) () +-- 'hide' 'minorTicks' :: 'State' ('Axis' b v n) () +-- 'hide' ('xAxis' . 'gridLines') :: 'State' ('Axis' b v n) () -- @ hide :: (MonadState s m, HasVisibility a) => ASetter' s a -> m () hide l = l . visible .= False @@ -563,8 +554,8 @@ -- | Set 'visible' to 'True' for the given setter. -- -- @ --- 'display' 'minorGridLines' :: 'State' ('Axis' v) () --- 'display' 'colourBar' :: 'State' ('Axis' v) () +-- 'display' 'minorGridLines' :: 'State' ('Axis' b v n) () +-- 'display' 'colourBar' :: 'State' ('Axis' b v n) () -- @ display :: (MonadState s m, HasVisibility a) => ASetter' s a -> m () display l = l . visible .= True @@ -574,20 +565,20 @@ ------------------------------------------------------------------------ -- | A 'PlotOptions' with modifications to a 'PlotStyle'. -data PlotMods v - = PlotMods (PlotOptions v) (PlotStyle v -> PlotStyle v) +data PlotMods b v n + = PlotMods (PlotOptions b v n) (PlotStyle b v n -> PlotStyle b v n) -type instance V (PlotMods v) = v -type instance N (PlotMods v) = Double +type instance V (PlotMods b v n) = v +type instance N (PlotMods b v n) = n -instance Functor f => HasPlotOptions f (PlotMods v) where +instance Functor f => HasPlotOptions f (PlotMods b v n) b where plotOptions f (PlotMods opts sty) = f opts <&> \opts' -> PlotMods opts' sty -instance Settable f => HasPlotStyle f (PlotMods v) where +instance Settable f => HasPlotStyle f (PlotMods b v n) b where plotStyle = sty . mapped where sty f (PlotMods opts s) = f s <&> \s' -> PlotMods opts s' -instance (HasBasis v, Foldable v) => Default (PlotMods v) where +instance (Additive v, Num n) => Default (PlotMods b v n) where def = PlotMods def id ------------------------------------------------------------------------ @@ -596,35 +587,35 @@ -- | A parameterised plot, together with a 'PlotMods'. This type has an -- instance of many classes for modifying specific plots. -data Plot p = +data Plot p b = Plot p - (PlotOptions (V p)) - (PlotStyle (V p) -> PlotStyle (V p)) + (PlotOptions b (V p) (N p)) + (PlotStyle b (V p) (N p) -> PlotStyle b (V p) (N p)) deriving Typeable -type instance V (Plot p) = V p -type instance N (Plot p) = Double +type instance V (Plot p b) = V p +type instance N (Plot p b) = N p -instance Functor f => HasPlotOptions f (Plot p) where +instance Functor f => HasPlotOptions f (Plot p b) b where plotOptions f (Plot p opts sty) = f opts <&> \opts' -> Plot p opts' sty -instance Settable f => HasPlotStyle f (Plot p) where +instance Settable f => HasPlotStyle f (Plot p b) b where plotStyle = sty . mapped where sty f (Plot p opts s) = f s <&> \s' -> Plot p opts s' -instance HasOrientation p => HasOrientation (Plot p) where +instance HasOrientation p => HasOrientation (Plot p b) where orientation = rawPlot . orientation -- | Make a 'Plot' with 'Default' 'PlotOptions'. -mkPlot :: (InSpace v Double p, HasBasis v, Foldable v) => p -> Plot p +mkPlot :: (Additive (V p), Num (N p)) => p -> Plot p b mkPlot p = Plot p def id -- | Lens onto the raw 'Plotable' inside a 'Plot'. -rawPlot :: SameSpace p p' => Lens (Plot p) (Plot p') p p' +rawPlot :: SameSpace p p' => Lens (Plot p b) (Plot p' b) p p' rawPlot f (Plot p opts ps) = f p <&> \p' -> Plot p' opts ps -- | The modifications to the 'PlotOptions' and 'PlotStyle' in a 'Plot'. -plotMods :: Lens' (Plot p) (PlotMods (V p)) +plotMods :: Lens' (Plot p b) (PlotMods b (V p) (N p)) plotMods f (Plot p opts ps) = f (PlotMods opts ps) <&> \(PlotMods opts' ps') -> Plot p opts' ps' @@ -633,38 +624,38 @@ ------------------------------------------------------------------------ -- | A wrapped up 'Plot', used to store plots in an 'Axis'. -data DynamicPlot v where - DynamicPlot :: (InSpace v Double p, Plotable p) => Plot p -> DynamicPlot v +data DynamicPlot b v n where + DynamicPlot :: (InSpace v n p, Plotable p b) => Plot p b -> DynamicPlot b v n deriving Typeable -type instance V (DynamicPlot v) = v -type instance N (DynamicPlot v) = Double +type instance V (DynamicPlot b v n) = v +type instance N (DynamicPlot b v n) = n -- | Prism for a 'DynamicPlot'. -_DynamicPlot :: Plotable p => Prism' (DynamicPlot (V p)) (Plot p) +_DynamicPlot :: (Plotable p b, Typeable b) => Prism' (DynamicPlot b (V p) (N p)) (Plot p b) _DynamicPlot = prism' DynamicPlot (\(DynamicPlot p) -> cast p) -- | Traversal over the dynamic plot without the 'Plotable' constraint -- '_DynamicPlot' has. -dynamicPlot :: forall p. Typeable p => Traversal' (DynamicPlot (V p)) (Plot p) +dynamicPlot :: forall p b. (Typeable p, Typeable b) + => Traversal' (DynamicPlot b (V p) (N p)) (Plot p b) dynamicPlot f d@(DynamicPlot p) = case eq p of Just Refl -> f p <&> \p' -> DynamicPlot p' Nothing -> pure d - where eq :: Typeable a => a -> Maybe (a :~: Plot p) + where eq :: Typeable a => a -> Maybe (a :~: Plot p b) eq _ = eqT - -instance Functor f => HasPlotOptions f (DynamicPlot v) where +instance Functor f => HasPlotOptions f (DynamicPlot b v n) b where plotOptions f (DynamicPlot (Plot p opts sty)) = f opts <&> \opts' -> DynamicPlot (Plot p opts' sty) -instance Settable f => HasPlotStyle f (DynamicPlot v) where +instance Settable f => HasPlotStyle f (DynamicPlot b v n) b where plotStyle = sty . mapped where - sty :: Setter' (DynamicPlot v) (PlotStyle v -> PlotStyle v) + sty :: Setter' (DynamicPlot b v n) (PlotStyle b v n -> PlotStyle b v n) sty f (DynamicPlot (Plot p opts s)) = f s <&> \s' -> DynamicPlot (Plot p opts s') -- | The modifications to the 'PlotOptions' and 'PlotStyle' in a 'DynamicPlot'. -dynamicPlotMods :: Lens' (DynamicPlot v) (PlotMods v) +dynamicPlotMods :: Lens' (DynamicPlot b v n) (PlotMods b v n) dynamicPlotMods f (DynamicPlot (Plot p opts ps)) = f (PlotMods opts ps) <&> \(PlotMods opts' ps') -> DynamicPlot (Plot p opts' ps') @@ -677,32 +668,32 @@ -- with 'styledPlotLegend'. -- -- You can make a 'StyledPlot' with 'styleDynamic' -data StyledPlot v where +data StyledPlot b v n where StyledPlot - :: Plotable p + :: Plotable p b => p - -> PlotOptions (V p) - -> PlotStyle (V p) - -> StyledPlot (V p) + -> PlotOptions b (V p) (N p) + -> PlotStyle b (V p) (N p) + -> StyledPlot b (V p) (N p) -type instance V (StyledPlot v) = v -type instance N (StyledPlot v) = Double +type instance V (StyledPlot b v n) = v +type instance N (StyledPlot b v n) = n -instance Functor f => HasPlotOptions f (StyledPlot v) where +instance Functor f => HasPlotOptions f (StyledPlot b v n) b where plotOptions f (StyledPlot p opts sty) = f opts <&> \opts' -> StyledPlot p opts' sty -instance HasLinearMap v => Enveloped (StyledPlot v) where +instance (Metric v, OrderedField n) => Enveloped (StyledPlot b v n) where getEnvelope (StyledPlot p opts _) = getEnvelope p & transform (poTransform opts) -instance Functor f => HasPlotStyle f (StyledPlot v) where +instance Functor f => HasPlotStyle f (StyledPlot b v n) b where plotStyle f (StyledPlot p opts sty) = f sty <&> StyledPlot p opts -- | Traversal over a raw plot of a styled plot. The type of the plot -- must match for the traversal to be successful. -styledPlot :: forall p. Typeable p => Traversal' (StyledPlot (V p)) p +styledPlot :: forall p b. Typeable p => Traversal' (StyledPlot b (V p) (N p)) p styledPlot f s@(StyledPlot p opts sty) = case eq p of Just Refl -> f p <&> \p' -> StyledPlot p' opts sty @@ -711,17 +702,21 @@ eq _ = eqT -- | Give a 'DynamicPlot' a concrete 'PlotStyle'. -styleDynamic :: PlotStyle v -> DynamicPlot v -> StyledPlot v +styleDynamic :: PlotStyle b v n -> DynamicPlot b v n -> StyledPlot b v n styleDynamic sty (DynamicPlot (Plot p opts styF)) = StyledPlot p opts (styF sty) -- | Render a 'StyledPlot' given an and 'AxisSpec'. -renderStyledPlot :: HasLinearMap v => AxisSpec v -> StyledPlot v -> Diagram v +renderStyledPlot + :: TypeableFloat n + => AxisSpec V2 n + -> StyledPlot b V2 n + -> QDiagram b V2 n Any renderStyledPlot aSpec (StyledPlot p opts sty) = renderPlotable aSpec sty p - & whenever (opts^.hidden) D.phantom - -- & whenever (opts^.clipPlot) (clipTo $ specRect aSpec) XXX ADD CLIPTO XXX + & whenever (opts^.hidden) phantom + & whenever (opts^.clipPlot) (clipTo $ specRect aSpec) -specRect :: AxisSpec V2 -> Path V2 Double +specRect :: TypeableFloat n => AxisSpec V2 n -> Path V2 n specRect aSpec = rect (xU - xL) (yU - yL) # moveTo (mkP2 ((xU+xL)/2) ((yU+yL)/2)) @@ -733,7 +728,9 @@ -- | Get the legend rendered entries from a single styled plot. The -- resulting entries are in no particular order. See also -- 'styledPlotLegends'. -singleStyledPlotLegend :: StyledPlot v -> [(Double, Diagram v, String)] -- ^ @(z-order, legend pic, legend text)@ +singleStyledPlotLegend + :: StyledPlot b v n + -> [(n, QDiagram b v n Any, String)] -- ^ @(z-order, legend pic, legend text)@ singleStyledPlotLegend (StyledPlot p opts sty) = map mk (opts ^. legendEntries) where @@ -744,7 +741,10 @@ CustomLegendPic f -> f sty -- | Render a list of legend entries, in order. -styledPlotLegends :: [StyledPlot v] -> [(Diagram v, String)] -- ^ @[(legend pic, legend text)]@ +styledPlotLegends + :: Ord n + => [StyledPlot b v n] + -> [(QDiagram b v n Any, String)] -- ^ @[(legend pic, legend text)]@ styledPlotLegends = map (\(_,p,t) -> (p,t)) . sortOn (view _1) diff --git a/src/Plots/Types/Bar.hs b/src/Plots/Types/Bar.hs --- a/src/Plots/Types/Bar.hs +++ b/src/Plots/Types/Bar.hs @@ -80,12 +80,10 @@ import Plots.Util import qualified Data.List as List --- import Diagrams.Core.Transform (fromSymmetric) --- import Linear.V2 (_yx) - -import Geometry.TwoD.Transform +import Diagrams.Core.Transform (fromSymmetric) +import Linear.V2 (_yx) -import Diagrams.Prelude hiding (orient) +import Diagrams.Prelude -- Single bar ---------------------------------------------------------- @@ -99,9 +97,9 @@ -- representation of a bar and is not intended to be used directly. -- | Construct a rectangle of size v with the bottom centre at point p. -rectB :: (InSpace V2 n t, Fractional n, FromTrail t) => Point V2 n -> V2 n -> t +rectB :: (InSpace V2 n t, TrailLike t) => Point V2 n -> V2 n -> t rectB p (V2 x y) = - fromLocTrail $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p .-^ V2 (x/2) 0 + trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p .-^ V2 (x/2) 0 ------------------------------------------------------------------------ -- Bar layout @@ -109,49 +107,49 @@ -- | The way an individual bar plot or a group of bars plots are laid -- out on the axis. -data BarLayout = BarLayout +data BarLayout n = BarLayout { bOrient :: Orientation - , bWidth :: Double - , bSpacing :: Double - , bStart :: Double + , bWidth :: n + , bSpacing :: n + , bStart :: n } deriving Typeable -instance Default BarLayout where +instance Fractional n => Default (BarLayout n) where def = BarLayout Horizontal 0.8 1 1 -type instance N BarLayout = Double +type instance N (BarLayout n) = n -instance HasOrientation BarLayout where +instance HasOrientation (BarLayout n) where orientation = lens bOrient (\bl o -> bl {bOrient = o}) -- | Class of things that have a modifiable 'BarLayout'. class HasOrientation a => HasBarLayout a where -- | Lens onto the 'BarLayout' - barLayout :: Lens' a BarLayout + barLayout :: Lens' a (BarLayout (N a)) -- | The width bar for single / stacked bars or the width of a group -- for grouped bar plot. -- -- Default is @0.8@ - barWidth :: Lens' a Double + barWidth :: Lens' a (N a) barWidth = barLayout . lens bWidth (\bl w -> bl {bWidth = w}) -- | The spacing between each bar or group of bars. -- -- Default is @1@ - barSpacing :: Lens' a Double + barSpacing :: Lens' a (N a) barSpacing = barLayout . lens bSpacing (\bl s -> bl {bSpacing = s}) -- | The distance from the axis to centre of the first bar. -- -- Default is @1@ - barStart :: Lens' a Double + barStart :: Lens' a (N a) barStart = barLayout . lens bStart (\bl x -> bl {bStart = x}) -instance HasBarLayout BarLayout where +instance HasBarLayout (BarLayout n) where barLayout = id -instance HasBarLayout a => HasBarLayout (Plot a) where +instance HasBarLayout a => HasBarLayout (Plot a b) where barLayout = rawPlot . barLayout ------------------------------------------------------------------------ @@ -165,18 +163,18 @@ -- A 'BarPlot' is not intended to be constructed directly, instead use -- one of the helper functions. -data BarPlot = BarPlot - { bpData :: [(Double,Double)] - , bpLayout :: BarLayout +data BarPlot n = BarPlot + { bpData :: [(n,n)] + , bpLayout :: BarLayout n } deriving Typeable -type instance V BarPlot = V2 -type instance N BarPlot = Double +type instance V (BarPlot n) = V2 +type instance N (BarPlot n) = n -instance HasOrientation BarPlot where +instance HasOrientation (BarPlot n) where orientation = barLayout . orientation -instance Enveloped BarPlot where +instance OrderedField n => Enveloped (BarPlot n) where getEnvelope BarPlot {..} = getEnvelope . orient bpLayout _reflectXY id . (id :: Path v n -> Path v n) $ ifoldMap drawBar bpData @@ -184,7 +182,8 @@ drawBar i (a,b) = rectB (mkP2 x a) (V2 (view barWidth bpLayout) (b - a)) where x = view barStart bpLayout + fromIntegral i * view barSpacing bpLayout -instance Plotable BarPlot where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (BarPlot n) b where renderPlotable s sty BarPlot {..} = ifoldMap drawBar bpData # orient bpLayout _reflectXY id @@ -206,9 +205,9 @@ | otherwise = rect 4 10 -- The legend bars don't look right if the line width is too big so we limit it - sty' = sty & areaStyle . _lw . mapped %~ atMost (local 0.8) + sty' = sty & areaStyle . _lw %~ atMost (local 0.8) -instance HasBarLayout BarPlot where +instance HasBarLayout (BarPlot n) where barLayout = lens bpLayout (\bp l -> bp {bpLayout = l}) ------------------------------------------------------------------------ @@ -216,11 +215,11 @@ ------------------------------------------------------------------------ -- | Create equidistant bars using the values. -mkBars :: F.Foldable f => BarLayout -> f Double -> BarPlot +mkBars :: (F.Foldable f, Num n) => BarLayout n -> f n -> BarPlot n mkBars bl (F.toList -> ns) = mkFloatingBars bl (map (0,) ns) -- | Create equidistant bars with lower and upper bounds for each bar. -mkFloatingBars :: F.Foldable f => BarLayout -> f (Double,Double) -> BarPlot +mkFloatingBars :: F.Foldable f => BarLayout n -> f (n,n) -> BarPlot n mkFloatingBars bl (F.toList -> ns) = BarPlot { bpData = ns , bpLayout = bl @@ -229,9 +228,10 @@ -- | Create uniform bars from groups of data, placing one group after -- the other. mkRunningBars - :: BarLayout - -> [[(Double, Double)]] - -> [BarPlot] + :: Num n + => BarLayout n + -> [[(n,n)]] + -> [BarPlot n] mkRunningBars bl = snd . foldr f (view barStart bl, []) where f d (x, bs) = (x + dx, mkFloatingBars bl {bStart = x} d : bs) @@ -241,9 +241,10 @@ -- other. The first list will be the same as @mkUniformBars opts (map -- (0,) ys)@, subsequent lists will be placed on top. mkStackedBars - :: BarLayout - -> [[Double]] -- values - -> [BarPlot] + :: Num n + => BarLayout n + -> [[n]] -- values + -> [BarPlot n] mkStackedBars bl = snd . List.mapAccumR f (repeat 0) where -- y0s are the base values for this set of bars, these accumulate @@ -254,10 +255,11 @@ -- | Similar to 'mkMultiStacked' but stack has the same height. mkStackedEqualBars - :: Double -- ^ value each bar reaches - -> BarLayout - -> [[Double]] -- ^ values - -> [BarPlot] + :: Fractional n + => n -- ^ value each bar reaches + -> BarLayout n + -> [[n]] -- ^ values + -> [BarPlot n] mkStackedEqualBars yM bl yss = mkStackedBars bl yss' where -- Multiplier for each bar to reach the desired height. @@ -271,10 +273,11 @@ -- as a single bar when using the 'BarPlotsOpts'. There is an addition -- parameter to adjust the width of each individual bar. mkGroupedBars - :: Double -- ^ width factor of individual bars (1 = touching) - -> BarLayout - -> [[Double]] - -> [BarPlot] + :: Fractional n + => n -- ^ width factor of individual bars (1 = touching) + -> BarLayout n + -> [[n]] + -> [BarPlot n] mkGroupedBars w bl xs = flip imap xs $ \i ns -> mkBars @@ -291,10 +294,10 @@ -- temporary functions that will be in next lib release -_reflectionXY :: (HasLinearMap v, R2 v, Num n) => Transformation v n -_reflectionXY = reflectionX <> reflectionY +_reflectionXY :: (Additive v, R2 v, Num n) => Transformation v n +_reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) -_reflectXY :: (InSpace v n t, R2 v, HasLinearMap v, Transformable t) => t -> t +_reflectXY :: (InSpace v n t, R2 v, Transformable t) => t -> t _reflectXY = transform _reflectionXY ---------------------------------------------------------------------------------- @@ -318,9 +321,11 @@ -- -- > barExample = renderAxis barAxis barPlot - :: (MonadState (Axis V2) m, F.Foldable f) - => f Double -- ^ bar heights - -> State (Plot BarPlot) () -- ^ changes to the bars + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f) + => f n -- ^ bar heights + -> State (Plot (BarPlot n) b) () -- ^ changes to the bars -> m () -- ^ changes to the 'Axis' barPlot ns = addPlotable (mkBars def ns) @@ -339,9 +344,11 @@ -- -- > barExample' = renderAxis barAxis' barPlot' - :: (MonadState (Axis V2) m, F.Foldable f) - => f Double -- ^ bar heights - -> m () -- ^ changes to the 'Axis' + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f) + => f n -- ^ bar heights + -> m () -- ^ changes to the 'Axis' barPlot' ns = addPlotable' (mkBars def ns) -- | A add 'BarPlot' to an 'Axis' while naming the bars. @@ -361,9 +368,11 @@ -- > -- > namedBarExample = renderAxis namedBarAxis namedBarPlot - :: (MonadState (Axis V2) m, F.Foldable f) - => f (String, Double) -- ^ bar heights with name - -> State (Plot BarPlot) () -- ^ changes to the bars + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f) + => f (String,n) -- ^ bar heights with name + -> State (Plot (BarPlot n) b) () -- ^ changes to the bars -> m () -- ^ changes to the 'Axis' namedBarPlot d s = do addPlot bp @@ -387,16 +396,20 @@ -- -- > namedBarExample' = renderAxis namedBarAxis' namedBarPlot' - :: (MonadState (Axis V2) m, F.Foldable f) - => f (String, Double) -- ^ bar heights with name - -> m () -- ^ add plot to the 'Axis' + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f) + => f (String,n) -- ^ bar heights with name + -> m () -- ^ add plot to the 'Axis' namedBarPlot' ns = namedBarPlot ns (return ()) -- | Same as 'barPlot' but with lower and upper bounds for the bars. floatingBarPlot - :: (MonadState (Axis V2) m, F.Foldable f) - => f (Double,Double) -- ^ bar limits - -> State (Plot BarPlot) () -- ^ changes to the bars + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f) + => f (n,n) -- ^ bar limits + -> State (Plot (BarPlot n) b) () -- ^ changes to the bars -> m () floatingBarPlot ns = addPlotable (mkFloatingBars def ns) @@ -429,26 +442,26 @@ -- -- * Add labels to each (group of) bars with 'labelBars'. -- -data MultiBarState a = MultiBarState - { mbsLayout :: BarLayout +data MultiBarState b n a = MultiBarState + { mbsLayout :: BarLayout n -- ^ options for building bar plots - , mbsMods :: [(a, Endo (PlotMods V2))] + , mbsMods :: [(a, Endo (PlotMods b V2 n))] -- ^ the data along with an adjustment to the plot properties , mbsLabels :: [String] -- ^ labels to be placed at the bottom of each bar - , mbsBarFun :: BarLayout -> [[Double]] -> [BarPlot] + , mbsBarFun :: BarLayout n -> [[n]] -> [BarPlot n] -- ^ function used to build bar plots } -type instance N (MultiBarState a) = Double +type instance N (MultiBarState b n a) = n -instance HasOrientation (MultiBarState a) where +instance HasOrientation (MultiBarState b n a) where orientation = barLayout . orientation -instance HasBarLayout (MultiBarState a) where +instance HasBarLayout (MultiBarState b n a) where barLayout = lens mbsLayout (\mbs l -> mbs {mbsLayout = l}) -- > import Plots @@ -479,7 +492,7 @@ -- Adding to axis ------------------------------------------------------ -multiFun :: Lens' (MultiBarState a) (BarLayout -> [[Double]] -> [BarPlot]) +multiFun :: Lens' (MultiBarState b n a) (BarLayout n -> [[n]] -> [BarPlot n]) multiFun = lens mbsBarFun (\mbs f -> mbs {mbsBarFun = f}) -- | Bars that are grouped together such that each group is a single @@ -490,7 +503,7 @@ -- -- <> -groupedBars :: State (MultiBarState a) () +groupedBars :: Fractional n => State (MultiBarState b n a) () groupedBars = groupedBars' 1 -- | Bars that are grouped together such that each group is a single @@ -502,7 +515,7 @@ -- -- <> -- -groupedBars' :: Double -> State (MultiBarState a) () +groupedBars' :: Fractional n => n -> State (MultiBarState b n a) () groupedBars' n = multiFun .= mkGroupedBars n -- | Bars stacked on top of each other. @@ -511,7 +524,7 @@ -- -- <> -- -stackedBars :: State (MultiBarState a) () +stackedBars :: Num n => State (MultiBarState b n a) () stackedBars = multiFun .= mkStackedBars -- | Bars stacked on top of each other where every bar is the given @@ -522,7 +535,7 @@ -- -- <> -- -stackedEqualBars :: Double -> State (MultiBarState a) () +stackedEqualBars :: Fractional n => n -> State (MultiBarState b n a) () stackedEqualBars n = multiFun .= mkStackedEqualBars n -- | Normal 'bars' where each data set follows the last. @@ -531,7 +544,7 @@ -- -- <> -- -runningBars :: State (MultiBarState a) () +runningBars :: Num n => State (MultiBarState b n a) () runningBars = multiFun .= \l xs -> mkRunningBars l (map (map (0,)) xs) -- | Construct multiple bars, grouped together. See 'MultiBarState' for @@ -567,10 +580,13 @@ -- -- > multiBarExample = renderAxis multiBarAxis multiBars - :: (MonadState (Axis V2) m, F.Foldable f, F.Foldable g) + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + F.Foldable f, + F.Foldable g) => f a -- ^ data for multi plot - -> (a -> g Double) -- ^ extract bar heights from each data set - -> State (MultiBarState a) () -- ^ state to make changes to the plot + -> (a -> g n) -- ^ extract bar heights from each data set + -> State (MultiBarState b n a) () -- ^ state to make changes to the plot -> m () -- ^ changes to the 'Axis' multiBars (F.toList -> as) f st = do -- add the plots @@ -598,7 +614,9 @@ -- | Place labels under the centre of each bar using the 'BarLayout' by -- changing that 'axisTickLabels', using the provided string in order. -barLayoutAxisLabels :: MonadState (Axis V2) m => BarLayout -> [String] -> m () +barLayoutAxisLabels + :: (MonadState (Axis b V2 n) m, Fractional n) + => BarLayout n -> [String] -> m () barLayoutAxisLabels bl ls = unless (null ls) $ axes . orient bl _y _x &= do @@ -621,11 +639,11 @@ -- * 'key' - add a legend entry for that group of bars -- onBars - :: (a -> State (PlotMods V2) ()) + :: (a -> State (PlotMods b V2 n) ()) -- ^ Modifier the 'PlotOptions' and 'PlotStyle' for the bars -- associated with the data from @a@. - -> State (MultiBarState a) () + -> State (MultiBarState b n a) () -- ^ Changes to each data set when executing 'multiBars'. onBars f = mods . mapped %= \(a, endo) -> (a, endo <> Endo (execState (f a))) @@ -634,7 +652,7 @@ class HasLabels a where labels :: Lens' a [String] -instance HasLabels (MultiBarState a) where +instance HasLabels (MultiBarState b n a) where labels = lens mbsLabels (\mbs ls -> mbs {mbsLabels = ls}) -- | Labels to use for each bar (or group of bars) along the axis. diff --git a/src/Plots/Types/HeatMap.hs b/src/Plots/Types/HeatMap.hs --- a/src/Plots/Types/HeatMap.hs +++ b/src/Plots/Types/HeatMap.hs @@ -45,13 +45,13 @@ , pixelHeatRender' -- * Heat matrix - , HeatMatrix (..) + , HeatMatrix , heatImage , hmPoints + , hmSize -- * Low level construction , mkHeatMap - , mkHeatSurface , mkHeatMatrix , mkHeatMatrix' @@ -76,12 +76,8 @@ import Plots.Style import Plots.Types -import Diagrams.TwoD.Image - -import Geometry.ThreeD.Shapes - ------------------------------------------------------------------------ --- HeatMap +-- Heatmap ------------------------------------------------------------------------ -- | 2D Array of 'Double's. @@ -200,10 +196,16 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pixelHeatRender myHM viridis -- -pixelHeatRender :: HeatMatrix -> ColourMap -> Diagram V2 -pixelHeatRender hm cm = alignBL $ imageEmb (ImageRGB8 img) +pixelHeatRender + :: (Renderable (DImage n Embedded) b, TypeableFloat n) + => HeatMatrix + -> ColourMap + -> QDiagram b V2 n Any +pixelHeatRender hm cm = + alignBL . image $ DImage (ImageRaster (ImageRGB8 img)) x y mempty where - img = heatImage hm cm + img = heatImage hm cm + V2 x y = hmSize hm -- | Render an heatmap as an 'ImageRGB8' with @n@ pixels per heat matrix -- point. @@ -219,11 +221,17 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pixelHeatRender' 10 myHM viridis -- -pixelHeatRender' :: Int -> HeatMatrix -> ColourMap -> Diagram V2 +pixelHeatRender' + :: (Renderable (DImage n Embedded) b, TypeableFloat n) + => Int + -> HeatMatrix + -> ColourMap + -> QDiagram b V2 n Any pixelHeatRender' n hm cm = - scale (1/fromIntegral n) . alignBL $ imageEmb (ImageRGB8 img) + scale (1/fromIntegral n) . alignBL . image $ DImage (ImageRaster (ImageRGB8 img)) (x*n) (y*n) mempty where - img = scaleImage n $ heatImage hm cm + img = scaleImage n $ heatImage hm cm + V2 x y = hmSize hm -- | Scale an image so each pixel takes (n*n) pixels. This can be -- useful for using 'heatImage' on small heat matrices to give a @@ -320,7 +328,11 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pathHeatRender myHM viridis -- -pathHeatRender :: HeatMatrix -> ColourMap -> Diagram V2 +pathHeatRender + :: (Renderable (Path V2 n) b, TypeableFloat n) + => HeatMatrix + -> ColourMap + -> QDiagram b V2 n Any pathHeatRender hm@(HeatMatrix _ _ a b) cm = ifoldMapOf hmPoints mk hm # lwO 0 where normalise d = (d - a) / (b - a) @@ -343,23 +355,23 @@ -- | A mapping from points in a 2D axis do 'Double's. These 'Double's -- are converted to colours using the axis 'ColourMap'. -data HeatMap v = HeatMap +data HeatMap b n = HeatMap { hMatrix :: HeatMatrix - , hStart :: P2 Double - , hSize :: V2 Double - , hGridSty :: Style v Double + , hStart :: P2 n + , hSize :: V2 n + , hGridSty :: Style V2 n , hGridVisible :: Bool , hLimits :: Maybe (Double,Double) - , hDraw :: HeatMatrix -> ColourMap -> Diagram v + , hDraw :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any } deriving Typeable -type instance V (HeatMap v) = v -type instance N (HeatMap v) = Double +type instance V (HeatMap b n) = V2 +type instance N (HeatMap b n) = n -- | Class of things that let you change the heatmap options. -class HasHeatMap f a where +class HasHeatMap f a b | a -> b where -- | Lens onto the heatmap options. - heatMapOptions :: LensLike' f a (HeatMap (V a)) + heatMapOptions :: LensLike' f a (HeatMap b (N a)) -- | Whether there should be grid lines draw for the heat map. -- @@ -371,19 +383,19 @@ -- visible. -- -- Default is 'mempty'. - heatMapGridStyle :: Functor f => LensLike' f a (Style (V a) Double) + heatMapGridStyle :: Functor f => LensLike' f a (Style V2 (N a)) heatMapGridStyle = heatMapOptions . lens hGridSty (\s b -> (s {hGridSty = b})) -- | The size of each individual square in the heat map. -- -- Default is @'V2' 1 1@. - heatMapSize :: Functor f => LensLike' f a (V2 Double) + heatMapSize :: Functor f => LensLike' f a (V2 (N a)) heatMapSize = heatMapOptions . lens hSize (\s b -> (s {hSize = b})) -- | The size of the full extent of the heat map. -- -- Default is extent of the heat matrix. - heatMapExtent :: Functor f => LensLike' f a (V2 Double) + heatMapExtent :: (Functor f, Fractional (N a)) => LensLike' f a (V2 (N a)) heatMapExtent = heatMapOptions . l where l f hm = f (hSize hm * s) <&> \x -> hm { hSize = x / s } where s = fmap fromIntegral (hmSize $ hMatrix hm) @@ -391,11 +403,11 @@ -- | The starting point at the bottom left corner of the heat map. -- -- Default is 'origin' - heatMapStart :: Functor f => LensLike' f a (P2 Double) + heatMapStart :: Functor f => LensLike' f a (P2 (N a)) heatMapStart = heatMapOptions . lens hStart (\s b -> (s {hStart = b})) -- | The center point of the heat map. - heatMapCentre :: Functor f => LensLike' f a (P2 Double) + heatMapCentre :: (Functor f, Fractional (N a)) => LensLike' f a (P2 (N a)) heatMapCentre = heatMapOptions . l where l f hm = f (hStart hm .+^ v) <&> \p -> hm { hStart = p .-^ v } where v = fmap fromIntegral (hmSize $ hMatrix hm) * hSize hm / 2 @@ -409,31 +421,26 @@ -- 'pixelHeatRender'. -- -- Default is 'pathHeatRender'. - heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> Diagram (V a)) + heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any) heatMapRender = heatMapOptions . lens hDraw (\s b -> (s {hDraw = b})) -instance HasHeatMap f (HeatMap v) where +instance HasHeatMap f (HeatMap b n) b where heatMapOptions = id -instance (Functor f, HasHeatMap f a) => HasHeatMap f (Plot a) where +instance (Functor f, HasHeatMap f a b) => HasHeatMap f (Plot a b) b where heatMapOptions = rawPlot . heatMapOptions -instance Enveloped (HeatMap V2) where +instance OrderedField n => Enveloped (HeatMap b n) where getEnvelope hm = getEnvelope (fromCorners p (p .+^ v)) where p = view heatMapStart hm v = view heatMapExtent hm -instance Enveloped (HeatMap V3) where - getEnvelope hm = getEnvelope (fromCorners (v3 p) (v3 $ p .+^ v)) - where p = view heatMapStart hm - v = view heatMapExtent hm - v3 (P (V2 x y)) = P $ V3 x y 0 - -instance Plotable (HeatMap V2) where +instance (Typeable b, TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (HeatMap b n) b where renderPlotable s _sty HeatMap {..} = transform (s^.specTrans) $ grid <> hDraw matrix' (s^.specColourMap) - # scaleV hSize + # transform (scaleV hSize) # moveTo hStart where --- TODO @@ -449,30 +456,13 @@ -- XXX make better defLegendPic sty HeatMap {..} = square 5 # applyAreaStyle sty -instance Plotable (HeatMap V3) where - renderPlotable s _sty HeatMap {..} = - transform (s^.specTrans) $ - grid <> hDraw matrix' (s^.specColourMap) - # scaleV (v3 hSize) - # moveTo (p3 hStart) - where - v3 (V2 x y) = V3 x y 1 - p3 (P (V2 x y)) = P $ V3 x y 0 - --- TODO - grid = mempty - - --- XXX need to give _range to the axis somehow (for colour bar range) - matrix' = case hLimits of - -- Just r@(a,b) -> (r, hMatrix { hmFun = (/ (b - a)) . (+a) . hmFun hMatrix }) - -- Nothing -> normaliseHeatMatrix hMatrix - Just (a,b) -> hMatrix { hmBoundLower = a, hmBoundUpper = b } - Nothing -> hMatrix - - -- XXX make better - defLegendPic sty HeatMap {..} = cube # scale 5 # applyAreaStyle sty +scaleV :: (Additive v, Fractional n) => v n -> Transformation v n +scaleV v = fromLinear f f + where f = (liftU2 (*) v) <-> (\u -> liftU2 (/) u v) --- | Construct a 'HeatMap' using the given 'HeatMatrix'. -mkHeatMap :: HeatMatrix -> HeatMap V2 +-- | Construct a 'Heatmap' using the given 'HeatMatrix'. +mkHeatMap :: (Renderable (Path V2 n) b, TypeableFloat n) + => HeatMatrix -> HeatMap b n mkHeatMap mat = HeatMap { hMatrix = mat , hStart = origin @@ -483,17 +473,6 @@ , hDraw = pathHeatRender } -mkHeatSurface :: HeatMatrix -> HeatMap V3 -mkHeatSurface mat = HeatMap - { hMatrix = mat - , hStart = origin - , hSize = V2 1 1 - , hGridSty = mempty - , hGridVisible = False - , hLimits = Nothing - , hDraw = undefined - } - -- Adding to axis ------------------------------------------------------ -- | Add a 'HeatMap' plot using the extent of the heatmap and a @@ -521,9 +500,12 @@ heatMap :: (F.Foldable f, F.Foldable g, - MonadState (Axis V2) m) + TypeableFloat n, + Typeable b, + MonadState (Axis b V2 n) m, + Renderable (Path V2 n) b) => f (g Double) - -> State (Plot (HeatMap V2)) () + -> State (Plot (HeatMap b n) b) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' heatMap xss s = do @@ -533,21 +515,6 @@ -- (don't like this way of doing it) colourBarRange .= over both realToFrac (a,b) -heatSurface - :: (F.Foldable f, - F.Foldable g, - MonadState (Axis V3) m) - => f (g Double) - -> State (Plot (HeatMap V3)) () - -- ^ changes to plot options - -> m () -- ^ add plot to 'Axis' -heatSurface xss s = do - let hm@(HeatMatrix _ _ a b) = mkHeatMatrix' xss - addPlotable (mkHeatSurface hm) s - - -- (don't like this way of doing it) - colourBarRange .= over both realToFrac (a,b) - -- | Add a 'HeatMap' plot using the extent of the heatmap and a -- generating function. -- @@ -574,7 +541,10 @@ heatMap' :: (F.Foldable f, F.Foldable g, - MonadState (Axis V2) m) + TypeableFloat n, + Typeable b, + MonadState (Axis b V2 n) m, + Renderable (Path V2 n) b) => f (g Double) -> m () -- ^ add plot to 'Axis' heatMap' xss = heatMap xss (return ()) @@ -604,10 +574,13 @@ -- heatMapIndexed :: (VectorLike V2 Int i, - MonadState (Axis V2) m) + TypeableFloat n, + Typeable b, + MonadState (Axis b V2 n) m, + Renderable (Path V2 n) b) => i -- ^ extent of array -> (i -> Double) -- ^ heat from index - -> State (Plot (HeatMap V2)) () + -> State (Plot (HeatMap b n) b) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' heatMapIndexed i f s = do @@ -643,14 +616,12 @@ -- heatMapIndexed' :: (VectorLike V2 Int i, - MonadState (Axis V2) m) + TypeableFloat n, + Typeable b, + MonadState (Axis b V2 n) m, + Renderable (Path V2 n) b) => i -- ^ extent of array -> (i -> Double) -- ^ heat from index -> m () -- ^ add plot to 'Axis' heatMapIndexed' i f = heatMapIndexed i f (return ()) - --- heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> Diagram (V a)) - --- surfaceRender :: HeatMatrix -> ColourMap -> Diagram V3 --- surfaceRender hm cm = diff --git a/src/Plots/Types/Histogram.hs b/src/Plots/Types/Histogram.hs --- a/src/Plots/Types/Histogram.hs +++ b/src/Plots/Types/Histogram.hs @@ -64,7 +64,8 @@ import qualified Data.Vector as V import qualified Statistics.Sample.Histogram as Stat -import Diagrams.Prelude hiding (orient) +import Diagrams.Core.Transform (fromSymmetric) +import Diagrams.Prelude import Linear.V2 (_yx) import Plots.Axis @@ -72,38 +73,38 @@ import Plots.Types import Plots.Util -import Geometry.TwoD.Transform -- | Construct a rectangle of size $v$ with the bottom left at point $p$. -rectBL :: (InSpace V2 n t, FromTrail t) => Point V2 n -> V2 n -> t +rectBL :: (InSpace V2 n t, TrailLike t) => Point V2 n -> V2 n -> t rectBL p (V2 x y) = - fromLocTrail $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p + trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p ------------------------------------------------------------------------ -- GHistogram plot ------------------------------------------------------------------------ -- | Simple histogram type supporting uniform bins. -data HistogramPlot = HistogramPlot - { hWidth :: Double - , hStart :: Double - , hValues :: [Double] +data HistogramPlot n = HistogramPlot + { hWidth :: n + , hStart :: n + , hValues :: [n] , hOrient :: Orientation } deriving Typeable -type instance V HistogramPlot = V2 -type instance N HistogramPlot = Double +type instance V (HistogramPlot n) = V2 +type instance N (HistogramPlot n) = n -instance Enveloped HistogramPlot where +instance OrderedField n => Enveloped (HistogramPlot n) where getEnvelope HistogramPlot {..} = - -- don't like this reduntent code - getEnvelope . orient hOrient _reflectXY id . (id :: Path V2 Double -> Path V2 Double) $ + -- don't like this redundant code + getEnvelope . orient hOrient _reflectXY id . (id :: Path v n -> Path v n) $ ifoldMap drawBar hValues where drawBar i h = rectBL (mkP2 x 0) (V2 hWidth h) where x = hStart + fromIntegral i * hWidth -instance Plotable HistogramPlot where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (HistogramPlot n) b where renderPlotable s sty HistogramPlot {..} = ifoldMap drawBar hValues # orient hOrient _reflectXY id @@ -120,9 +121,9 @@ $ alignB (rect 4 7) ||| alignB (rect 4 10) ||| alignB (rect 4 6) where -- The legend bars don't look right if the line width is too big so we limit it - sty' = sty & areaStyle . _lw . mapped %~ atMost (local 0.8) + sty' = sty & areaStyle . _lw %~ atMost (local 0.8) -instance HasOrientation HistogramPlot where +instance HasOrientation (HistogramPlot n) where orientation = lens hOrient $ \hp o -> hp {hOrient = o} ------------------------------------------------------------------------ @@ -131,21 +132,23 @@ -- | Plot an already computed histogram with equally sized bins. computedHistogram - :: (MonadState (Axis V2) m, F.Foldable f) - => Double -- ^ start of first bin - -> Double -- ^ width of each bin - -> f Double -- ^ heights of the bins - -> State (Plot HistogramPlot) () + :: (MonadState (Axis b V2 n) m, + Plotable (HistogramPlot n) b, + F.Foldable f) + => n -- ^ start of first bin + -> n -- ^ width of each bin + -> f n -- ^ heights of the bins + -> State (Plot (HistogramPlot n) b) () -> m () computedHistogram x0 w xs = addPlotable (mkComputedHistogram x0 w xs) -- | Construct a 'HistogramPlot' from raw histogram data. mkComputedHistogram :: F.Foldable f - => Double -- ^ start of first bin - -> Double -- ^ width of each bin - -> f Double -- ^ heights of the bins - -> HistogramPlot + => n -- ^ start of first bin + -> n -- ^ width of each bin + -> f n -- ^ heights of the bins + -> HistogramPlot n mkComputedHistogram x0 w xs = HistogramPlot x0 w (F.toList xs) Horizontal ---------------------------------------------------------------------------- @@ -189,7 +192,7 @@ -- | The way to normalise the data from a histogram. The default method -- is 'count'. newtype NormalisationMethod = - NM { runNM :: Double -> V.Vector Double -> V.Vector Double } + NM { runNM :: forall n. Fractional n => n -> V.Vector n -> V.Vector n } -- width -> heights -> normalised heights instance Default NormalisationMethod where @@ -252,17 +255,17 @@ -- | Options for binning histogram data. For now only very basic -- histograms building is supported. -data HistogramOptions = HistogramOptions +data HistogramOptions n = HistogramOptions { hBins :: Int - , hRange :: Maybe (Double, Double) + , hRange :: Maybe (n, n) , hNorm :: NormalisationMethod , oOrient :: Orientation } -type instance V HistogramOptions = V2 -type instance N HistogramOptions = Double +type instance V (HistogramOptions n) = V2 +type instance N (HistogramOptions n) = n -instance Default HistogramOptions where +instance Default (HistogramOptions n) where def = HistogramOptions { hBins = 10 , hRange = Nothing @@ -270,12 +273,12 @@ , oOrient = Vertical } -instance HasOrientation HistogramOptions where +instance HasOrientation (HistogramOptions n) where orientation = lens oOrient $ \ho o -> ho {oOrient = o} class HasOrientation a => HasHistogramOptions a where -- | Options for building the histogram from data. - histogramOptions :: Lens' a HistogramOptions + histogramOptions :: Lens' a (HistogramOptions (N a)) -- | The number of bins (bars) to use for the histogram. Must be -- positive. @@ -288,7 +291,7 @@ -- data outside the range is ignored. -- -- 'Default' is 'Nothing'. - binRange :: Lens' a (Maybe (Double, Double)) + binRange :: Lens' a (Maybe (N a, N a)) binRange = histogramOptions . lens hRange (\ho r -> ho {hRange = r}) -- | Should the resulting histogram be normalised so the total area is @@ -298,15 +301,17 @@ normaliseSample :: Lens' a NormalisationMethod normaliseSample = histogramOptions . lens hNorm (\ho b -> ho {hNorm = b}) -instance HasHistogramOptions HistogramOptions where +instance HasHistogramOptions (HistogramOptions n) where histogramOptions = id -instance HasHistogramOptions a => HasHistogramOptions (Plot a) where +instance HasHistogramOptions a => HasHistogramOptions (Plot a b) where histogramOptions = rawPlot . histogramOptions -- | Create a histogram by binning the data using the -- 'HistogramOptions'. -mkHistogramPlot :: F.Foldable f => HistogramOptions -> f Double -> HistogramPlot +mkHistogramPlot + :: (F.Foldable f, RealFrac n) + => HistogramOptions n -> f n -> HistogramPlot n mkHistogramPlot HistogramOptions {..} xs = HistogramPlot { hWidth = w @@ -321,9 +326,10 @@ (a,b) = fromMaybe (range hBins v) hRange -- Taken from Statistics, which was limited to 'Double'. -range :: Int -- ^ Number of bins (must be positive). - -> V.Vector Double -- ^ Sample data (cannot be empty). - -> (Double, Double) +range :: (Ord n, Fractional n) + => Int -- ^ Number of bins (must be positive). + -> V.Vector n -- ^ Sample data (cannot be empty). + -> (n, n) range nBins xs | nBins < 1 = error "Plots.Types.Histogram: invalid bin count" | V.null xs = error "Plots.Types.Histogram: empty sample" @@ -371,40 +377,40 @@ -- -- > histogramExample = renderAxis histogramAxis histogramPlot - :: (MonadState (Axis V2) m, F.Foldable f) - => f Double -- ^ data - -> State (Plot HistogramOptions) () -- ^ changes to plot options + :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, F.Foldable f, RealFrac n) + => f n -- ^ data + -> State (Plot (HistogramOptions n) b) () -- ^ changes to plot options -> m () -- ^ add plot to axis histogramPlot ns s = addPlot (hoPlot & rawPlot %~ \ho -> mkHistogramPlot ho ns) where hoPlot = mkPlot def &~ s -- | Make a 'HistogramPlot' without changes to the plot options. histogramPlot' - :: (MonadState (Axis V2) m, F.Foldable f) - => f Double -- ^ data + :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, F.Foldable f, RealFrac n) + => f n -- ^ data -> m () -- ^ add plot to axis histogramPlot' d = histogramPlot d (return ()) -- | Add a 'HistogramPlot' using a fold over the data. histogramPlotOf - :: (MonadState (Axis V2) m) - => Fold s Double -- ^ fold over the data + :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, RealFrac n) + => Fold s n -- ^ fold over the data -> s -- ^ data to fold - -> State (Plot HistogramOptions) () -- ^ change to the plot + -> State (Plot (HistogramOptions n) b) () -- ^ change to the plot -> m () -- ^ add plot to the 'Axis' histogramPlotOf f s = histogramPlot (toListOf f s) -- | Same as 'histogramPlotOf' without any changes to the plot. histogramPlotOf' - :: MonadState (Axis V2) m - => Fold s Double -> s -> m () + :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, RealFrac n) + => Fold s n -> s -> m () histogramPlotOf' f s = histogramPlotOf f s (return ()) -- temporary functions that will be in next lib release -_reflectionXY :: (HasLinearMap v, R2 v, Num n) => Transformation v n -_reflectionXY = reflectionX <> reflectionY +_reflectionXY :: (Additive v, R2 v, Num n) => Transformation v n +_reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) -_reflectXY :: (InSpace v n t, HasLinearMap v, R2 v, Transformable t) => t -> t +_reflectXY :: (InSpace v n t, R2 v, Transformable t) => t -> t _reflectXY = transform _reflectionXY diff --git a/src/Plots/Types/Line.hs b/src/Plots/Types/Line.hs --- a/src/Plots/Types/Line.hs +++ b/src/Plots/Types/Line.hs @@ -29,8 +29,8 @@ -- * Line plots from points , linePlot , linePlot' - -- , smoothLinePlot - -- , smoothLinePlot' + , smoothLinePlot + , smoothLinePlot' -- * Construction utilities @@ -55,46 +55,47 @@ import Plots.Axis import Plots.Types -import Data.Typeable -import Geometry.Path -import qualified Data.Sequence as S (fromList, singleton) - ------------------------------------------------------------------------ -- Trails and Paths ------------------------------------------------------------------------ -trail2Path :: Located (Trail v n) -> Path v n -trail2Path = Path . S.singleton - -- | Add a 'Trail' as a 'Plot' to an 'Axis'. trailPlot - :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) - => Located (Trail v Double) -- ^ trail to plot - -> State (Plot (Path v Double)) () -- ^ changes to plot options + :: (BaseSpace c ~ v, + Plotable (Path v n) b, + MonadState (Axis b c n) m) + => Trail v n -- ^ trail to plot + -> State (Plot (Path v n) b) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' -trailPlot = pathPlot . trail2Path +trailPlot = pathPlot . toPath -- | Add a 'Trail' as a 'Plot' to an 'Axis' without changes to the plot -- options. trailPlot' - :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) - => Located (Trail v Double) -- ^ trail to plot + :: (BaseSpace c ~ v, + Plotable (Path v n) b, + MonadState (Axis b c n) m) + => Trail v n -- ^ trail to plot -> m () -- ^ add plot to the 'Axis' -trailPlot' = pathPlot' . trail2Path +trailPlot' = pathPlot' . toPath -- | Add a 'Path' as a 'Plot' to an 'Axis'. pathPlot - :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) - => Path v Double -- ^ path to plot - -> State (Plot (Path v Double)) () -- ^ changes to plot options + :: (BaseSpace c ~ v, + Plotable (Path v n) b, + MonadState (Axis b c n) m) + => Path v n -- ^ path to plot + -> State (Plot (Path v n) b) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' pathPlot = addPlotable -- | Add a 'Path' as a 'Plot' to an 'Axis' without changes to the plot -- options. pathPlot' - :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) - => Path v Double -- ^ path to plot + :: (BaseSpace c ~ v, + Plotable (Path v n) b, + MonadState (Axis b c n) m) + => Path v n -- ^ path to plot -> m () -- ^ add plot to the 'Axis' pathPlot' = addPlotable' @@ -105,56 +106,54 @@ -- | Add a 'Path' plot from a list of points. linePlot :: (BaseSpace c ~ v, - HasLinearMap v, + Metric v, F.Foldable f, - R1 v, - PointLike v Double p, - MonadState (Axis c) m) + PointLike v n p, + Plotable (Path v n) b, + MonadState (Axis b c n) m) => f p -- ^ points to turn into trail - -> State (Plot (Path v Double)) () -- ^ changes to plot options + -> State (Plot (Path v n) b) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' linePlot = addPlotable . toPath . mkTrail -- | Add a 'Path' plot from a list of points. linePlot' :: (BaseSpace c ~ v, - HasLinearMap v, + Metric v, F.Foldable f, - R1 v, - PointLike v Double p, - MonadState (Axis c) m) + PointLike v n p, + Plotable (Path v n) b, + MonadState (Axis b c n) m) => f p -- ^ points to turn into trail -> m () -- ^ add plot to the 'Axis' linePlot' = addPlotable' . toPath . mkTrail -- | Add a smooth 'Path' plot from a list of points using 'cubicSpline'. --- smoothLinePlot --- :: (BaseSpace c ~ v, --- F.Foldable f, --- Typeable v, --- HasLinearMap v, --- PointLike v Double p, --- R1 v, --- Fractional (v Double), -- needs fixing in diagrams-lib --- MonadState (Axis c) m) --- => f p -- ^ points to turn into trail --- -> State (Plot (Path v Double)) () -- ^ changes to plot options --- -> m () -- ^ add plot to the 'Axis' --- smoothLinePlot = addPlotable . cubicSpline False . toListOf (folded . unpointLike) +smoothLinePlot + :: (BaseSpace c ~ v, + F.Foldable f, + Metric v, + PointLike v n p, + Plotable (Path v n) b, + Fractional (v n), -- needs fixing in diagrams-lib + MonadState (Axis b c n) m) + => f p -- ^ points to turn into trail + -> State (Plot (Path v n) b) () -- ^ changes to plot options + -> m () -- ^ add plot to the 'Axis' +smoothLinePlot = addPlotable . cubicSpline False . toListOf (folded . unpointLike) -- | Add a smooth 'Path' plot from a list of points using 'cubicSpline' -- without changes to the plot options. --- smoothLinePlot' --- :: (BaseSpace c ~ v, --- F.Foldable f, --- PointLike v Double p, --- Typeable v, --- R1 v, --- Fractional (v Double), -- needs fixing in diagrams-lib --- MonadState (Axis c) m) --- => f p -- ^ points to turn into trail --- -> m () -- ^ add plot to the 'Axis' --- smoothLinePlot' xs = smoothLinePlot xs (return ()) +smoothLinePlot' + :: (BaseSpace c ~ v, + F.Foldable f, + PointLike v n p, + Plotable (Path v n) b, + Fractional (v n), -- needs fixing in diagrams-lib + MonadState (Axis b c n) m) + => f p -- ^ points to turn into trail + -> m () -- ^ add plot to the 'Axis' +smoothLinePlot' xs = smoothLinePlot xs (return ()) ------------------------------------------------------------------------ -- Trail and path @@ -174,5 +173,5 @@ -- | Construct a localed trail from a fold over points. mkPathOf :: (PointLike v n p, OrderedField n) => Fold s t -> Fold t p -> s -> Path v n -mkPathOf f1 f2 as = Path . S.fromList $ map (mkTrailOf f2) (toListOf f1 as) +mkPathOf f1 f2 as = Path $ map (mkTrailOf f2) (toListOf f1 as) diff --git a/src/Plots/Types/Pie.hs b/src/Plots/Types/Pie.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Types/Pie.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE UndecidableInstances #-} + +{-# LANGUAGE StandaloneDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types.Line +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- A pie plot is a circular statistical graphic, which is divided into +-- slices to illustrate numerical proportion. +-- +-- <> +-- +-- (see 'piePlot' example for code to make this plot) +-- +---------------------------------------------------------------------------- + +module Plots.Types.Pie + ( -- * Pie plot + PieState + , piePlot + , piePlot' + , onWedges + , wedgeKeys + + -- * Wedges + , Wedge + , mkWedge + , HasWedge (..) + , wedgePlot + + ) where + +import Control.Monad.State.Lazy + +import Data.Typeable +import qualified Data.Foldable as F +import qualified Data.List as List + +import Diagrams.Coordinates.Isomorphic +import Diagrams.Coordinates.Polar +import Diagrams.Prelude hiding (r2) + +import Plots.Style +import Plots.Types +import Plots.Axis + +------------------------------------------------------------------------ +-- Pie wedge +------------------------------------------------------------------------ + +-- | Contains information to draw a single wedge of a pie. It is not +-- intended to be drawn directly. Instead use 'piePlot'. +data Wedge n = Wedge + { sEndR :: n + , sStartR :: n + , sOffset :: n + , sDir :: Direction V2 n + , sWidth :: Angle n + } deriving Typeable + +type instance V (Wedge n) = V2 +type instance N (Wedge n) = n + +instance RealFloat n => Enveloped (Wedge n) where + getEnvelope Wedge {..} = getEnvelope shape # translate off where + shape + | sStartR == 0 = wedge sEndR sDir sWidth :: Path V2 n + | otherwise = annularWedge sEndR sStartR sDir sWidth + off + | sOffset == 0 = zero + | otherwise = sOffset *^ fromDir (rotate (sWidth ^/ 2) sDir) + +instance (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (Wedge n) b where + renderPlotable s sty Wedge {..} = + shape + # applyAreaStyle sty + # translate off + # transform (s^.specTrans) + where + shape + | sStartR == 0 = wedge sEndR sDir sWidth + | otherwise = annularWedge sEndR sStartR sDir sWidth + off + | sOffset == 0 = zero + | otherwise = sOffset *^ fromDir (rotate (sWidth ^/ 2) sDir) + + defLegendPic sty Wedge {..} + = square 5 # applyAreaStyle sty + +-- | Create a pie wedge with unit radius, starting at direction @d@ with +-- width @theta@. +mkWedge + :: Num n + => Direction V2 n -- ^ starting direction + -> Angle n -- ^ width of wedge + -> Wedge n -- ^ resulting wedge +mkWedge d theta = Wedge + { sEndR = 1 + , sStartR = 0 + , sOffset = 0 + , sDir = d + , sWidth = theta + } + +class HasWedge f a where + -- | Description on how to draw a wedge. + pieWedge :: LensLike' f a (Wedge (N a)) + + -- | The outside radius of the wedge. Default is @1@. + wedgeOuterRadius :: Functor f => LensLike' f a (N a) + wedgeOuterRadius = pieWedge . lens sEndR (\p r -> p {sEndR = r}) + + -- | The inside radius of the wedge. Default is $0$. + wedgeInnerRadius :: Functor f => LensLike' f a (N a) + wedgeInnerRadius = pieWedge . lens sStartR (\p r -> p {sStartR = r}) + + -- | The offset of the wedge from the center. + wedgeOffset :: Functor f => LensLike' f a (N a) + wedgeOffset = pieWedge . lens sOffset (\p x -> p {sOffset = x}) + + -- | The width of the wedge, starting from the 'wedgeDirection'. + wedgeWidth :: Functor f => LensLike' f a (Angle (N a)) + wedgeWidth = pieWedge . lens sWidth (\p x -> p {sWidth = x}) + + -- | The inititial direction of the wedge. + wedgeDirection :: Functor f => LensLike' f a (Direction V2 (N a)) + wedgeDirection = pieWedge . lens sDir (\p x -> p {sDir = x}) + +instance HasWedge f (Wedge n) where + pieWedge = id + +instance (Functor f, HasWedge f a) => HasWedge f (Plot a b) where + pieWedge = rawPlot . pieWedge + +instance Applicative f => HasWedge f (PieState b n a) where + pieWedge = stateMods . traversed . _2 . pieWedge + +instance (Applicative f, Typeable b, v ~ V2, Typeable n) + => HasWedge f (DynamicPlot b v n) where + pieWedge = (dynamicPlot :: Traversal' (DynamicPlot b v n) (Plot (Wedge n) b)) + . pieWedge + +instance (v ~ V2, Applicative f, Typeable n) + => HasWedge f (StyledPlot b v n) where + pieWedge = (styledPlot :: Traversal' (StyledPlot b v n) (Wedge n)) + +instance (BaseSpace c ~ V2, Settable f, Typeable n) + => HasWedge f (Axis b c n) where + pieWedge = finalPlots . pieWedge + +------------------------------------------------------------------------ +-- Full pie +------------------------------------------------------------------------ + +-- | The state used to draw a part chart made of multiple pie wedges. +data PieState b n a = PieState + { psMods :: [(a, Plot (Wedge n) b)] -- non-empty list + } + +type instance V (PieState b n a) = V2 +type instance N (PieState b n a) = n + +-- internal lens +stateMods :: Lens' (PieState b n a) [(a, Plot (Wedge n) b)] +stateMods = lens psMods (\ps ms -> ps {psMods = ms}) + +-- -- | The direction for the first entry in the pie. Default is 'xDir'. +-- startingDirection :: Lens' (PieState b n a) (Direction V2 n) +-- startingDirection = lens psStart (\ps d -> ps {psStart = d}) + +-- -- | The ending direction of the final wedge. This can be used to make a +-- finalDirection :: + +-- | Modify the state for each wedge given the data entry. +-- +-- Some common lenses to use on the 'Wedge': +-- +-- * 'plotColour' - change the colour of the bars +-- +-- * 'areaStyle' - modify the style of the bars +-- +-- * 'key' - add a legend entry for that group of bars +-- +-- * 'wedgeOffset' - the offset of the wedge from the center +-- +onWedges :: (a -> State (Plot (Wedge n) b) ()) -> State (PieState b n a) () +onWedges f = stateMods %= map (\(a, p) -> (a, execState (f a) p)) + +-- | Add a legend entry for each item given a function that extracts the +-- item's name. +wedgeKeys :: Num n => (a -> String) -> State (PieState b n a) () +wedgeKeys f = onWedges $ \a -> key (f a) + +-- | Make a pie plot from a list of data by making a series of wedge +-- plots. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > pieData = [("red", 3), ("blue", 4), ("green", 2), ("purple", 5)] +-- > +-- > piePlotAxis :: Axis B Polar Double +-- > piePlotAxis = polarAxis &~ do +-- > piePlot pieData snd $ wedgeKeys fst +-- > hide (axes . traversed) +-- +-- > piePlotExample = renderAxis piePlotAxis +piePlot + :: (MonadState (Axis b Polar n) m, + Plotable (Wedge n) b, + F.Foldable f) + => f a -- ^ data for each wedge + -> (a -> n) -- ^ extract weight of each wedge + -> State (PieState b n a) () + -> m () +piePlot (F.toList -> as) f st = F.forM_ ps addPlot + where + -- calculate pie widths + ns = map f as + x = F.sum ns + wedges = snd $ List.mapAccumR wedgeAccum xDir as + wedgeAccum d a = (d', wdg) + where theta = (f a / x) @@ turn + d' = d # rotate theta + wdg = mkWedge d theta + + -- run pie state + ps = map snd . psMods $ execState st ps0 + ps0 = PieState { psMods = zip as (map mkPlot wedges) } + +-- | Make a pie plot from list of values without any changes. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > piePlotAxis' :: Axis B Polar Double +-- > piePlotAxis' = polarAxis &~ do +-- > piePlot' [1,3,5,2] +-- > wedgeInnerRadius .= 0.5 +-- > hide (axes . traversed) +-- +-- > pieExample' = renderAxis piePlotAxis' +piePlot' + :: (MonadState (Axis b Polar n) m, + Plotable (Wedge n) b, + F.Foldable f) + => f n -- ^ weight of each wedge + -> m () +piePlot' ns = piePlot ns id (return ()) + +------------------------------------------------------------------------ +-- Wedge +------------------------------------------------------------------------ + +-- $ pieplot +-- Pie plots display data as wedges and annular wedges. +-- Pie plots have the following lenses: +-- +-- @ +-- * 'strokeArc' :: 'Lens'' ('BoxPlot' v n) 'Bool' - False +-- @ + +-- | Add a single 'PiePlot' to the 'AxisState' from a data set. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > wedgePlotAxis :: Axis B Polar Double +-- > wedgePlotAxis = polarAxis &~ do +-- > wedgePlot xDir (38@@deg) $ key "wedge" +-- +-- > wedgeExample = renderAxis wedgePlotAxis +wedgePlot + :: (v ~ BaseSpace c, v ~ V2, + PointLike v n (Polar n), + MonadState (Axis b c n) m, + Plotable (Wedge n) b + ) + => Direction V2 n -> Angle n -> State (Plot (Wedge n) b) () -> m () +wedgePlot r theta = addPlotable (mkWedge r theta) + diff --git a/src/Plots/Types/Scatter.hs b/src/Plots/Types/Scatter.hs --- a/src/Plots/Types/Scatter.hs +++ b/src/Plots/Types/Scatter.hs @@ -80,8 +80,6 @@ import Plots.Style import Plots.Types -import Diagrams.Types (mkQD, Prim (..)) - -- config -- > import Plots @@ -91,30 +89,31 @@ -- | A general data type for scatter plots. Allows storing different -- types of data as well as allowing transforms depending on the data. -data ScatterPlot v where - ScatterPlot :: Typeable a => ScatterOptions v a -> ScatterPlot v +data ScatterPlot v n where + ScatterPlot :: Typeable a => ScatterOptions v n a -> ScatterPlot v n deriving Typeable -type instance V (ScatterPlot v) = v -type instance N (ScatterPlot v) = Double +type instance V (ScatterPlot v n) = v +type instance N (ScatterPlot v n) = n -- | A general data type for scatter plots. Allows storing different -- types of data as well as allowing transforms depending on the data. -data ScatterOptions v a = ScatterOptions +data ScatterOptions v n a = ScatterOptions { oData :: [a] - , oPos :: a -> Point v Double - , oTr :: a -> Transformation v Double - , oSty :: a -> Style v Double + , oPos :: a -> Point v n + , oTr :: a -> Transformation v n + , oSty :: a -> Style v n , oLine :: Bool } deriving Typeable -type instance V (ScatterOptions v a) = v -type instance N (ScatterOptions v a) = Double +type instance V (ScatterOptions v n a) = v +type instance N (ScatterOptions v n a) = n -instance Metric v => Enveloped (ScatterPlot v) where +instance (Metric v, OrderedField n) => Enveloped (ScatterPlot v n) where getEnvelope (ScatterPlot (ScatterOptions {..})) = getEnvelope (map oPos oData) -instance Plotable (ScatterPlot V2) where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (ScatterPlot V2 n) b where renderPlotable s sty (ScatterPlot (ScatterOptions {..})) = markers <> line where @@ -134,44 +133,21 @@ sty ^. plotMarker & applyMarkerStyle sty -strokeV3 :: Path V3 Double -> Diagram V3 -strokeV3 path = mkQD (Prim path) (getEnvelope path) mempty mempty - -instance Plotable (ScatterPlot V3) where - renderPlotable s sty (ScatterPlot (ScatterOptions {..})) = - markers <> line - where - markers = F.foldMap mk oData # applyMarkerStyle sty - -- - mk a = marker # transform (oTr a) - # applyStyle (oSty a) - # moveTo (specPoint s $ oPos a) - marker = sty ^. plotMarker - -- - line - | not oLine = mempty - | otherwise = strokeV3 (fromVertices points) # applyLineStyle sty - points = map (specPoint s . oPos) oData - - defLegendPic sty (ScatterPlot (ScatterOptions {..})) = - sty ^. plotMarker - & applyMarkerStyle sty - ------------------------------------------------------------------------ -- Generating scatter options ------------------------------------------------------------------------ -- | Low level construction of 'ScatterOptions'. mkScatterOptions - :: (PointLike v Double p, F.Foldable f) + :: (PointLike v n p, F.Foldable f, Fractional n) => f a -> (a -> p) - -> ScatterOptions v a + -> ScatterOptions v n a mkScatterOptions xs pf = ScatterOptions { oData = F.toList xs , oPos = view unpointLike . pf , oTr = mempty - , oSty = const mempty + , oSty = const (_Wrapped ## mempty) , oLine = False } @@ -187,100 +163,100 @@ -- 'lineStyle' from the 'PlotStyle'. connectingLine :: Functor f => LensLike' f a Bool -instance HasConnectingLine f (ScatterOptions v a) where +instance HasConnectingLine f (ScatterOptions v n a) where connectingLine = lens oLine (\o b -> o {oLine = b}) -instance HasConnectingLine f (ScatterPlot v) where +instance HasConnectingLine f (ScatterPlot v n) where connectingLine f (ScatterPlot o@(ScatterOptions {..})) = f oLine <&> \b -> ScatterPlot o {oLine = b} -instance HasConnectingLine f p => HasConnectingLine f (Plot p) where +instance HasConnectingLine f p => HasConnectingLine f (Plot p b) where connectingLine = rawPlot . connectingLine -instance (Applicative f, Typeable v) - => HasConnectingLine f (DynamicPlot v) where - connectingLine = (dynamicPlot :: Traversal' (DynamicPlot v) (Plot (ScatterPlot v))) +instance (Applicative f, Typeable b, Typeable v, Typeable n) + => HasConnectingLine f (DynamicPlot b v n) where + connectingLine = (dynamicPlot :: Traversal' (DynamicPlot b v n) (Plot (ScatterPlot v n) b)) . connectingLine -instance (Applicative f, Typeable v) - => HasConnectingLine f (StyledPlot v) where - connectingLine = (styledPlot :: Traversal' (StyledPlot v) (ScatterPlot v)) +instance (Applicative f, Typeable v, Typeable n) + => HasConnectingLine f (StyledPlot b v n) where + connectingLine = (styledPlot :: Traversal' (StyledPlot b v n) (ScatterPlot v n)) . connectingLine -instance (Settable f, Typeable (BaseSpace c)) - => HasConnectingLine f (Axis c) where +instance (Settable f, Typeable (BaseSpace c), Typeable n) + => HasConnectingLine f (Axis b c n) where connectingLine = finalPlots . connectingLine -- Options ------------------------------------------------------------- class HasScatterOptions f a d where -- | Lens onto the 'ScatterOptions' for a general scatter plot. - gscatterOptions :: LensLike' f a (ScatterOptions (V a) d) + gscatterOptions :: LensLike' f a (ScatterOptions (V a) (N a) d) -- | Apply a transform to the markers using the associated data. - scatterTransform :: Functor f => LensLike' f a (d -> Transformation (V a) Double) + scatterTransform :: Functor f => LensLike' f a (d -> Transformation (V a) (N a)) scatterTransform = gscatterOptions . lens oTr (\o tr -> o {oTr = tr}) -- | Apply a style to the markers using the associated data. - scatterStyle :: Functor f => LensLike' f a (d -> Style (V a) Double) + scatterStyle :: Functor f => LensLike' f a (d -> Style (V a) (N a)) scatterStyle = gscatterOptions . lens oSty (\o sty -> o {oSty = sty}) -- | Change the position of the markers depending on the data. - scatterPosition :: Functor f => LensLike' f a (d -> Point (V a) Double) + scatterPosition :: Functor f => LensLike' f a (d -> Point (V a) (N a)) scatterPosition = gscatterOptions . lens oPos (\o pos -> o {oPos = pos}) -instance d ~ d' => HasScatterOptions f (ScatterOptions v d) d' where +instance d ~ d' => HasScatterOptions f (ScatterOptions v n d) d' where gscatterOptions = id -instance (Applicative f, Typeable v, Typeable d) - => HasScatterOptions f (ScatterPlot v) d where +instance (Applicative f, Typeable v, Typeable n, Typeable d) + => HasScatterOptions f (ScatterPlot v n) d where gscatterOptions f s@(ScatterPlot p) = case eq p of Just Refl -> ScatterPlot <$> f p Nothing -> pure s where - eq :: Typeable a => a -> Maybe (a :~: ScatterOptions v d) + eq :: Typeable a => a -> Maybe (a :~: ScatterOptions v n d) eq _ = eqT -instance (Functor f, HasScatterOptions f p a) => HasScatterOptions f (Plot p) a where +instance (Functor f, HasScatterOptions f p a) => HasScatterOptions f (Plot p b) a where gscatterOptions = rawPlot . gscatterOptions -instance (Applicative f, Typeable v, Typeable a) - => HasScatterOptions f (DynamicPlot v) a where +instance (Applicative f, Typeable b, Typeable v, Typeable n, Typeable a) + => HasScatterOptions f (DynamicPlot b v n) a where gscatterOptions = dynamicPlot . rawPlot -instance (Applicative f, Typeable (BaseSpace c), Typeable a) - => HasScatterOptions f (Axis c) a where +instance (Applicative f, Typeable b, Typeable (BaseSpace c), Typeable n, Typeable a) + => HasScatterOptions f (Axis b c n) a where gscatterOptions = axisPlots . traverse . gscatterOptions -- Pure scatter lenses ------------------------------------------------- -- | Lens onto a scatter plot of points. -scatterOptions :: (InSpace v Double a, HasScatterOptions f a (Point v Double)) - => LensLike' f a (ScatterOptions v (Point v Double)) +scatterOptions :: (InSpace v n a, HasScatterOptions f a (Point v n)) + => LensLike' f a (ScatterOptions v n (Point v n)) scatterOptions = gscatterOptions -- -- | Lens onto a transform of a scatter plot of points. This is a -- -- specialised version of 'scatterTransform' for better type -- -- inference. -- _scatterTransform --- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) --- => LensLike' f a (p -> Transformation v) +-- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) +-- => LensLike' f a (p -> Transformation v n) -- _scatterTransform = scatterTransform . lmapping unpointLike -- -- | Lens onto a transform of a scatter plot of points. This is a -- -- specialised version of 'scatterPosition' for better type inference. -- _scatterPosition --- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) +-- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) -- => LensLike' f a (p -> p) -- _scatterPosition = scatterPos . dimapping unpointLike pointLike -- -- | Lens onto a style function of a scatter plot of points. This is a -- -- specialised version of 'scatterStyle' for better type inference. -- _scatterStyle --- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) --- => LensLike' f a (p -> Style v) +-- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) +-- => LensLike' f a (p -> Style v n) -- _scatterStyle = scatterStyle . lmapping unpointLike ------------------------------------------------------------------------ @@ -299,9 +275,9 @@ -- | Add a 'ScatterPlot' to the 'AxisState' from a data set. -- -- @ --- 'scatterPlot' :: [('Double', 'Double')] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () --- 'scatterPlot' :: ['V2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () --- 'scatterPlot' :: ['P2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () +-- 'scatterPlot' :: [('Double', 'Double')] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'scatterPlot' :: ['V2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'scatterPlot' :: ['P2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () -- @ -- -- === __Example__ @@ -313,7 +289,7 @@ -- > mydata2 = mydata1 & each . _1 *~ 0.5 -- > mydata3 = [V2 1.2 2.7, V2 2 5.1, V2 3.2 2.6, V2 3.5 5] -- --- > scatterAxis :: Axis V2 +-- > scatterAxis :: Axis B V2 Double -- > scatterAxis = r2Axis &~ do -- > scatterPlot mydata1 $ key "data 1" -- > scatterPlot mydata2 $ key "data 2" @@ -322,12 +298,13 @@ -- > scatterExample = renderAxis scatterAxis scatterPlot :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v), + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, F.Foldable f) => f p -- ^ points to plot - -> State (Plot (ScatterOptions v (Point v Double))) () + -> State (Plot (ScatterOptions v n (Point v n)) b) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' scatterPlot xs = gscatterPlot (xs ^.. folded . unpointLike) id @@ -359,9 +336,10 @@ -- > scatterExample' = renderAxis scatterAxis' scatterPlot' :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v), + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, F.Foldable f) => f p -- ^ points to plot -> m () -- ^ add plot to 'Axis' @@ -370,12 +348,13 @@ -- | Version of 'scatterPlot' that accepts a 'Fold' over the data. scatterPlotOf :: (BaseSpace c ~ v, - PointLike v Double p, - Plotable (ScatterPlot v), - MonadState (Axis c) m) + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b) => Fold s p -- ^ fold over points -> s -- ^ data to fold - -> State (Plot (ScatterOptions v (Point v Double))) () -- ^ changes to plot options + -> State (Plot (ScatterOptions v n (Point v n)) b) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' scatterPlotOf f s = scatterPlot (toListOf f s) @@ -383,9 +362,10 @@ -- without any changes to the 'ScatterOptions'. scatterPlotOf' :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v)) + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b) => Fold s p -- ^ fold over points -> s -- ^ data to fold -> m () -- ^ add plot to axis @@ -396,15 +376,15 @@ ------------------------------------------------------------------------ -- | A bubble plot is a scatter plot using point together with a scalar. -type BubbleOptions v = ScatterOptions v (Double, Point v Double) +type BubbleOptions v n = ScatterOptions v n (n, Point v n) -- | Scatter plots with extra numeric parameter. By default the extra -- parameter is the scale of the marker but this can be changed. -- -- @ --- 'bubblePlot' :: [('Double', ('Double', 'Double'))] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'bubblePlot' :: [('Double', 'V2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'bubblePlot' :: [('Double', 'P2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', ('Double', 'Double'))] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', 'V2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', 'P2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () -- @ -- -- === __Example__ @@ -426,12 +406,13 @@ -- > bubbleExample = renderAxis bubbleAxis bubblePlot :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v), + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Typeable n, F.Foldable f) - => f (Double, p) -- ^ fold over points with a size - -> State (Plot (BubbleOptions v)) () -- ^ changes to the options + => f (n, p) -- ^ fold over points with a size + -> State (Plot (BubbleOptions v n) b) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlot xs s = gscatterPlot (xs ^.. folded . mapping unpointLike) snd $ do @@ -447,23 +428,25 @@ -- bubblePlot' :: (v ~ BaseSpace c, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v), + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, F.Foldable f) - => f (Double, p) -- ^ fold over points with a size + => f (n, p) -- ^ fold over points with a size -> m () -- ^ add plot to 'Axis' bubblePlot' xs = bubblePlot xs (return ()) -- | Version of 'bubblePlot' using a 'Fold' over the data. bubblePlotOf :: (BaseSpace c ~ v, - PointLike v Double p, - Plotable (ScatterPlot v), - MonadState (Axis c) m) - => Fold s (Double,p) -- ^ fold over the data + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Typeable n) + => Fold s (n,p) -- ^ fold over the data -> s -- ^ data - -> State (Plot (BubbleOptions v)) () + -> State (Plot (BubbleOptions v n) b) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlotOf f s = bubblePlot (toListOf f s) @@ -472,12 +455,13 @@ -- changes to the 'BubbleOptions'. bubblePlotOf' :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, - Plotable (ScatterPlot v)) - => Fold s (Double,p) -- ^ fold over the data + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Typeable n) + => Fold s (n,p) -- ^ fold over the data -> s -- ^ data - -> State (Plot (BubbleOptions v)) () + -> State (Plot (BubbleOptions v n) b) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlotOf' f s = bubblePlot (toListOf f s) @@ -485,43 +469,43 @@ -- Bubble scatter lenses ----------------------------------------------- -- | LensLike onto into a 'ScatterOptions' made up of a scaler @n@, and --- a point, @'Point' v@ +-- a point, @'Point' v n@ -- -- @ --- 'bubbleOptions' :: 'Lens'' ('Plot' ('BubbleOptions' v) v) ('BubbleOptions' v) +-- 'bubbleOptions' :: 'Lens'' ('Plot' ('BubbleOptions' v n) v) ('BubbleOptions' v n) -- @ -bubbleOptions :: (InSpace v Double a, HasScatterOptions f a (Double, Point v Double)) - => LensLike' f a (BubbleOptions v) +bubbleOptions :: (InSpace v n a, HasScatterOptions f a (n, Point v n)) + => LensLike' f a (BubbleOptions v n) bubbleOptions = gscatterOptions -- | Setter over the transform function for a 'bubblePlot'. Default is 'scale'. -- -- @ --- 'bubbleOptions' :: 'Setter'' ('Plot' ('BubbleOptions' v) v) (n -> 'Transformation' v) +-- 'bubbleOptions' :: 'Setter'' ('Plot' ('BubbleOptions' v n) v) (n -> 'Transformation' v n) -- @ -- -- Note that this is the less general version of @'bubblePlot' . -- 'scatterTransform'@, which would give a 'LensLike' onto @(n, --- 'Point' v) -> 'Transformation' v@. +-- 'Point' v n) -> 'Transformation' v n@. -- bubbleTransform - :: (InSpace v Double a, HasScatterOptions f a (Double, Point v Double), Settable f) - => LensLike' f a (Double -> Transformation v Double) + :: (InSpace v n a, HasScatterOptions f a (n, Point v n), Settable f) + => LensLike' f a (n -> Transformation v n) bubbleTransform = bubbleOptions . scatterTransform . sets nOnly where nOnly f g (n,p) = f (\n' -> g (n', p)) n -- | Setter over the style function for a 'bubblePlot'. Default is 'mempty'. -- -- @ --- 'bubbleStyle' :: 'Setter'' ('Plot' ('BubbleOptions' v) v) (n -> 'Style' v) +-- 'bubbleStyle' :: 'Setter'' ('Plot' ('BubbleOptions' v n) v) (n -> 'Style' v n) -- @ -- -- Note that this is the less general version of @'bubblePlot' . -- 'scatterTransform'@, which would give a 'LensLike' onto @(n, --- 'Point' v) -> 'Style' v@. +-- 'Point' v n) -> 'Style' v n@. -- -bubbleStyle :: (InSpace v Double a, Settable f, HasScatterOptions f a (Double, Point v Double)) - => LensLike' f a (Double -> Style v Double) +bubbleStyle :: (InSpace v n a, Settable f, HasScatterOptions f a (n, Point v n)) + => LensLike' f a (n -> Style v n) bubbleStyle = bubbleOptions . scatterStyle . sets nOnly where nOnly f g (n,p) = f (\n' -> g (n', p)) n @@ -533,14 +517,14 @@ -- the 'scatterTransform' and 'scatterStyle'. gscatterPlot :: (BaseSpace c ~ v, - PointLike v Double p, - MonadState (Axis c) m, + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, Typeable d, - Plotable (ScatterPlot v), F.Foldable f) => f d -- ^ data -> (d -> p) -- ^ extract point from data - -> State (Plot (ScatterOptions v d)) () + -> State (Plot (ScatterOptions v n d) b) () -- ^ options for plot -> m () -- ^ add plot to 'Axis' gscatterPlot xs pf s = addPlot $ over rawPlot ScatterPlot p1 @@ -551,7 +535,7 @@ -- | Helper to traverse over a general scatter plot where the type of d -- is not infered. gscatterOptionsFor - :: (InSpace v Double a, HasScatterOptions f a d) - => proxy d -> LensLike' f a (ScatterOptions v d) + :: (InSpace v n a, HasScatterOptions f a d) + => proxy d -> LensLike' f a (ScatterOptions v n d) gscatterOptionsFor _ = gscatterOptions