diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright 2014: Christopher Chalmers + + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Yates nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +# plots + +[![Haddock](https://rawgit.com/cchalmers/plots/gh-pages/haddock.svg)](https://cchalmers.github.io/plots/) + +`plots` is a plotting library based on [diagrams](http://projects.haskell.org/diagrams). + +Some sample plots: + +#### Scatter plot +![scatter-plot](https://rawgit.com/cchalmers/plots/master/diagrams/src_Plots_Types_Scatter_scatterExample'.svg) + +#### Bar plot +![bar-plot](https://rawgit.com/cchalmers/plots/master/diagrams/src_Plots_Types_Bar_barExample'.svg) + +#### Heat map +![heat-map](https://rawgit.com/cchalmers/plots/master/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample'.svg) + +There are many more plots to be added. There are also plans to support +3D plots. Issues and pull requests welcome. + +## Examples + +There are several example plots in the `examples/` directory. To build +the examples, first ensure that you have `stack` installed, and that you +have a `stack.yaml` file in this directory that contains the lines: + +```yaml packages: +- '.' +- 'test' +``` + +(If you run the command `stack init`, stack will automatically generate +the `stack.yaml` file with the appropriate packages.) + +You can then build the examples using ```sh stack build stack exec +RunExamples ``` The `RunExamples` script will generate `png` files in +the `examples_output` directory. + +**Note:** The `RunExamples` script re-builds an example if the output +file (`examples_output/X.png`) does not exist, or if the source file +(`examples/X.hs`) has been modified since the last time the script was +run. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams/src_Plots_Axis_ColourBar_gradientColourBarExample.svg b/diagrams/src_Plots_Axis_ColourBar_gradientColourBarExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Axis_ColourBar_gradientColourBarExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Axis_ColourBar_pathColourBarExample.svg b/diagrams/src_Plots_Axis_ColourBar_pathColourBarExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Axis_ColourBar_pathColourBarExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_blackAndWhitePic.svg b/diagrams/src_Plots_Style_blackAndWhitePic.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_blackAndWhitePic.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_fadedColourPic.svg b/diagrams/src_Plots_Style_fadedColourPic.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_fadedColourPic.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_greysBar.svg b/diagrams/src_Plots_Style_greysBar.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_greysBar.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_infernoBar.svg b/diagrams/src_Plots_Style_infernoBar.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_infernoBar.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_magmaBar.svg b/diagrams/src_Plots_Style_magmaBar.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_magmaBar.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_plasmaBar.svg b/diagrams/src_Plots_Style_plasmaBar.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_plasmaBar.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_viridisBar.svg b/diagrams/src_Plots_Style_viridisBar.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_viridisBar.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Style_vividColourPic.svg b/diagrams/src_Plots_Style_vividColourPic.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Style_vividColourPic.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Types_Bar_barExample'.svg b/diagrams/src_Plots_Types_Bar_barExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_barExample'.svg @@ -0,0 +1,1 @@ +5.04.03.02.01.012.09.06.03.00.0 diff --git a/diagrams/src_Plots_Types_Bar_barExample.svg b/diagrams/src_Plots_Types_Bar_barExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_barExample.svg @@ -0,0 +1,1 @@ +12.09.06.03.00.05.04.03.02.01.0 diff --git a/diagrams/src_Plots_Types_Bar_groupedBarsExample'.svg b/diagrams/src_Plots_Types_Bar_groupedBarsExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_groupedBarsExample'.svg @@ -0,0 +1,1 @@ +6420breakfast itembeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_Bar_groupedBarsExample.svg b/diagrams/src_Plots_Types_Bar_groupedBarsExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_groupedBarsExample.svg @@ -0,0 +1,1 @@ +6420breakfast itembeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_Bar_multiBarExample.svg b/diagrams/src_Plots_Types_Bar_multiBarExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_multiBarExample.svg @@ -0,0 +1,1 @@ +6420breakfast itembeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_Bar_namedBarExample'.svg b/diagrams/src_Plots_Types_Bar_namedBarExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_namedBarExample'.svg @@ -0,0 +1,1 @@ +beanssausagebaconeggs12.510.07.55.02.50.0 diff --git a/diagrams/src_Plots_Types_Bar_namedBarExample.svg b/diagrams/src_Plots_Types_Bar_namedBarExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_namedBarExample.svg @@ -0,0 +1,1 @@ +12.510.07.55.02.50.0beanssausagebaconeggs diff --git a/diagrams/src_Plots_Types_Bar_runningBarsExample.svg b/diagrams/src_Plots_Types_Bar_runningBarsExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_runningBarsExample.svg @@ -0,0 +1,1 @@ +6420breakfast itembeanssausagebaconeggsbeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_Bar_stackedBarsExample.svg b/diagrams/src_Plots_Types_Bar_stackedBarsExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_stackedBarsExample.svg @@ -0,0 +1,1 @@ +12108520breakfast itembeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_Bar_stackedEqualBarsExample.svg b/diagrams/src_Plots_Types_Bar_stackedEqualBarsExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Bar_stackedEqualBarsExample.svg @@ -0,0 +1,1 @@ +1086420breakfast itembeanssausagebaconeggsboysgirls diff --git a/diagrams/src_Plots_Types_HeatMap_heatMapExample'.svg b/diagrams/src_Plots_Types_HeatMap_heatMapExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_heatMapExample'.svg @@ -0,0 +1,1 @@ +2.01.51.00.50.03.02.52.01.51.00.50.06.05.04.03.02.01.0 diff --git a/diagrams/src_Plots_Types_HeatMap_heatMapExample.svg b/diagrams/src_Plots_Types_HeatMap_heatMapExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_heatMapExample.svg @@ -0,0 +1,1 @@ +20.015.010.05.00.030.025.020.015.010.05.00.06.05.04.03.02.01.0 diff --git a/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample'.svg b/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample'.svg @@ -0,0 +1,1 @@ +3.02.52.01.51.00.50.03.02.52.01.51.00.50.04.03.02.01.00.0 diff --git a/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample.svg b/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_heatMapIndexedExample.svg @@ -0,0 +1,1 @@ +30.025.020.015.010.05.00.030.025.020.015.010.05.00.04.03.02.01.00.0 diff --git a/diagrams/src_Plots_Types_HeatMap_pathHeatRenderExample.svg b/diagrams/src_Plots_Types_HeatMap_pathHeatRenderExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_pathHeatRenderExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample'.svg b/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample'.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample.svg b/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_HeatMap_pixelHeatRenderExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Types_Histogram_cdfDia.svg b/diagrams/src_Plots_Types_Histogram_cdfDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_cdfDia.svg @@ -0,0 +1,1 @@ +1.00.80.60.40.20.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Histogram_countDensityDia.svg b/diagrams/src_Plots_Types_Histogram_countDensityDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_countDensityDia.svg @@ -0,0 +1,1 @@ +80.060.040.020.00.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Histogram_countDia.svg b/diagrams/src_Plots_Types_Histogram_countDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_countDia.svg @@ -0,0 +1,1 @@ +30.025.020.015.010.05.00.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Histogram_cumilativeDia.svg b/diagrams/src_Plots_Types_Histogram_cumilativeDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_cumilativeDia.svg @@ -0,0 +1,1 @@ +150.0120.090.060.030.00.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Histogram_pdfDia.svg b/diagrams/src_Plots_Types_Histogram_pdfDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_pdfDia.svg @@ -0,0 +1,1 @@ +0.50.40.30.20.10.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Histogram_probabilityDia.svg b/diagrams/src_Plots_Types_Histogram_probabilityDia.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Histogram_probabilityDia.svg @@ -0,0 +1,1 @@ +0.20.150.15.0e-20.08.07.06.05.04.0 diff --git a/diagrams/src_Plots_Types_Pie_pieExample'.svg b/diagrams/src_Plots_Types_Pie_pieExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Pie_pieExample'.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Plots_Types_Pie_piePlotExample.svg b/diagrams/src_Plots_Types_Pie_piePlotExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Pie_piePlotExample.svg @@ -0,0 +1,1 @@ +purplegreenbluered diff --git a/diagrams/src_Plots_Types_Pie_wedgeExample.svg b/diagrams/src_Plots_Types_Pie_wedgeExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Pie_wedgeExample.svg @@ -0,0 +1,1 @@ +6.05.04.03.02.01.00.01.00.750.50.250.0wedge diff --git a/diagrams/src_Plots_Types_Scatter_scatterExample'.svg b/diagrams/src_Plots_Types_Scatter_scatterExample'.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Scatter_scatterExample'.svg @@ -0,0 +1,1 @@ +6.05.04.03.03.53.02.52.01.51.00.5 diff --git a/diagrams/src_Plots_Types_Scatter_scatterExample.svg b/diagrams/src_Plots_Types_Scatter_scatterExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Plots_Types_Scatter_scatterExample.svg @@ -0,0 +1,1 @@ +6.05.04.03.03.53.02.52.01.51.00.5data 3data 2data 1 diff --git a/plots.cabal b/plots.cabal new file mode 100644 --- /dev/null +++ b/plots.cabal @@ -0,0 +1,81 @@ +name: plots +version: 0.1.0.0 +synopsis: Diagrams based plotting library. +homepage: http://github.com/cchalmers/plots +license: BSD3 +license-file: LICENSE +author: Christopher Chalmers +maintainer: c.chalmers@me.com +bug-reports: http://github.com/cchalmers/plots +stability: Experimental +category: Graphics +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md diagrams/*.svg +extra-doc-files: diagrams/*.svg +description: Diagrams based plotting library. + +source-repository head + type: git + location: http://github.com/cchalmers/plots + +library + exposed-modules: + Plots + Plots.Axis + Plots.Axis.ColourBar + Plots.Axis.Grid + Plots.Axis.Labels + Plots.Axis.Line + Plots.Axis.Render + Plots.Axis.Ticks + Plots.Axis.Title + Plots.Axis.Scale + Plots.Legend + Plots.Name + Plots.Style + Plots.Types + Plots.Types.Bar + Plots.Types.Histogram + Plots.Types.HeatMap + Plots.Types.Line + Plots.Types.Pie + Plots.Types.Scatter + Plots.Util + Diagrams.Coordinates.Isomorphic + Diagrams.Coordinates.Polar + hs-source-dirs: src + build-depends: + base >= 4.3 && < 5.0, + adjunctions, + colour, + containers >= 0.3 && < 0.6, + data-default >= 0.5 && < 0.8, + diagrams-core >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, + directory, + distributive, + transformers, + filepath, + fingertree, + hashable >= 1.1 && < 1.3, + lens >= 4.6 && < 5.0, + linear >= 1.2 && < 2.0, + monoid-extras >= 0.3 && < 0.6, + mtl >= 1.0 && < 3.2, + optparse-applicative, + statistics, + process, + semigroupoids, + semigroups, + split >= 0.1.2 && < 0.5, + time, + vector, + profunctors, + JuicyPixels, + intervals, + base-orphans + + ghc-options: -Wall + + default-language: Haskell2010 diff --git a/src/Diagrams/Coordinates/Isomorphic.hs b/src/Diagrams/Coordinates/Isomorphic.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Coordinates/Isomorphic.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Coordinates.Isomorphic +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines a class for coordinates that are (loosely) +-- isomorphic to the standard spaces ('V2' and 'V3'). This allows plots +-- to accept more data types for plot data. +-- +---------------------------------------------------------------------------- +module Diagrams.Coordinates.Isomorphic + ( -- * Type constraints + HasIndexedBasis, Euclidean + + -- * Vector like + , VectorLike (..) + , V2Like, V3Like + + -- * Point like + , PointLike (..) + , P2Like, P3Like + ) + where + +import Control.Lens +import Data.Complex +import Data.Typeable + +import Diagrams.Prelude + +type HasIndexedBasis v = (HasBasis v, TraversableWithIndex (E v) v) + +-- | Umbrella class giving everything needed for working in the space. This is +-- basically 'V2' or 'V3' from "linear". +type Euclidean v = (HasLinearMap v, HasIndexedBasis v, Metric v) + +-- vector like --------------------------------------------------------- + +-- | Provides an 'Iso'' between @a@ and @v n@. This is normally used to +-- convert between the data type you're already using, @a@, and diagram's +-- native form, @v n@. +class (Euclidean v, Typeable v) => VectorLike v n a | a -> v n where + -- | Isomorphism from @Point v n@ to something 'PointLike' @a@. + -- + -- >>> V2 3 5 ^. vectorLike :: (Int, Int) + -- (3,5) + vectorLike :: Iso' (v n) a + + -- | Isomorphism from something 'PointLike' @a@ to @Point v n@. + -- + -- >>> ((3, 5) :: (Int, Int)) ^. unvectorLike + -- V2 3 5 + unvectorLike :: Iso' a (v n) + unvectorLike = from vectorLike + {-# INLINE unvectorLike #-} + +instance VectorLike V2 n (V2 n) where + vectorLike = id + {-# INLINE vectorLike #-} + +type V2Like = VectorLike V2 + +instance n ~ m => VectorLike V2 n (n, m) where + vectorLike = iso unr2 r2 + {-# INLINE vectorLike #-} + +instance VectorLike V2 n (Complex n) where + vectorLike = iso (\(V2 x y) -> x :+ y) + (\(i :+ j) -> V2 i j) + {-# INLINE vectorLike #-} + +type V3Like = VectorLike V3 + +instance VectorLike V3 n (V3 n) where + vectorLike = id + {-# INLINE vectorLike #-} + +instance (n ~ m, m ~ o) => VectorLike V3 n (n, m, o) where + vectorLike = iso unr3 r3 + {-# INLINE vectorLike #-} + +-- point like ---------------------------------------------------------- + +-- | Provides an 'Iso'' between @a@ and @'Point' v n@. This is normally used to +-- convert between the data type you're already using, @a@, and diagram's +-- native form, @'Point' v n@. +class (Euclidean v, Typeable v) => PointLike v n a | a -> v n where + -- | Isomorphism from @'Point' v n@ to something 'PointLike' @a@. + -- + -- >>> mkP2 3 5 ^. pointLike :: (Int, Int) + -- (3,5) + pointLike :: Iso' (Point v n) a + + -- | Isomorphism from something 'PointLike' @a@ to @Point v n@. + -- + -- >>> ((3, 5) :: (Int, Int)) ^. unpointLike + -- P (V2 3 5) + unpointLike :: Iso' a (Point v n) + unpointLike = from pointLike + {-# INLINE unpointLike #-} + +-- | Things that are isomorphic to points in R2. +type P2Like = PointLike V2 + +instance (Euclidean v, Typeable v) => PointLike v n (Point v n) where + pointLike = id + +instance PointLike V2 n (V2 n) where + pointLike = _Point + {-# INLINE pointLike #-} + +instance n ~ m => PointLike V2 n (n, m) where + pointLike = iso unp2 p2 + {-# INLINE pointLike #-} + +instance PointLike V2 n (Complex n) where + pointLike = iso (\(unp2 -> (x,y)) -> x :+ y) + (\(i :+ j) -> p2 (i,j)) + {-# INLINE pointLike #-} + +type P3Like = PointLike V3 + +instance (n ~ m, m ~ o) => PointLike V3 n (n, m, o) where + pointLike = iso unp3 p3 + {-# INLINE pointLike #-} + diff --git a/src/Diagrams/Coordinates/Polar.hs b/src/Diagrams/Coordinates/Polar.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Coordinates/Polar.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Coordinates.Spherical +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines a polar coordinate data type. This type can be +-- used as an axis space for polar plots. +-- +---------------------------------------------------------------------------- +module Diagrams.Coordinates.Polar + ( -- * Polar type + Polar (..) + , mkPolar, polar, unpolar, polarIso, polarV2 + + -- * Polar functions + , interpPolar + + -- * Classes + , Radial (..), Circle (..) + , HasX (..), HasY (..), HasR (..) + + -- * Basis elements + , er, eθ, etheta, + + ) where + +import Control.Applicative +import qualified Data.Foldable as F + +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.TwoD.Types + +import Linear.Affine +import Linear.Metric +import Linear.V3 +import Linear.Vector + +import Diagrams.Coordinates.Isomorphic +import Prelude + + +newtype Polar a = Polar (V2 a) + deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, + Generic1, MonadZip, F.Foldable) + +makeWrapped ''Polar + +-- can't make reasonable Additive instance + +instance Distributive Polar where + distribute f = Polar $ V2 (fmap (\(Polar (V2 x _)) -> x) f) + (fmap (\(Polar (V2 _ y)) -> y) f) + +instance Representable Polar where + type Rep Polar = E Polar + tabulate f = Polar $ V2 (f er) (f eθ) + index xs (E l) = view l xs + +instance Circle Polar where + _azimuth = polarWrapper . _y . from rad + _polar = id + +instance HasR Polar where + _r = polarWrapper . _x + +-- | Construct a 'Polar' from a magnitude and an 'Angle'. +mkPolar :: n -> Angle n -> Polar n +mkPolar r θ = Polar $ V2 r (θ^.rad) + +-- | Construct a 'Polar' from a magnitude and 'Angle' tuple. +polar :: (n, Angle n) -> Polar n +polar = uncurry mkPolar + +-- | Turn a 'Polar' back into a magnitude and 'Angle' tuple. +unpolar :: Polar n -> (n, Angle n) +unpolar (Polar (V2 r θ)) = (r, θ @@ rad) + +-- | 'Iso'' between 'Polar' and its tuple form. +polarIso :: Iso' (Polar n) (n, Angle n) +polarIso = iso unpolar polar + +-- | Numerical 'Iso'' between 'Polar' and 'R2'. +polarV2 :: RealFloat n => Iso' (Polar n) (V2 n) +polarV2 = iso (\(Polar (V2 r θ)) -> V2 (r * cos θ) (r * sin θ)) + (\v@(V2 x y) -> Polar $ V2 (norm v) (atan2 y x)) + +-- internal iso for instances +polarWrapper :: Iso' (Polar a) (V2 a) +polarWrapper = iso (\(Polar v) -> v) Polar + +-- | Polar interpolation between two polar coordinates. +interpPolar :: Num n => n -> Polar n -> Polar n -> Polar n +interpPolar t (Polar a) (Polar b) = Polar (lerp t a b) + + +-- | Space which has a radial length basis. For Polar and Cylindrical this is +-- the radius of the circle in the xy-plane. For Spherical this is the +-- distance from the origin. +class Radial t where + _radial :: Lens' (t a) a + +instance Radial Polar where + _radial = polarWrapper . _x + +-- | Space which has a radial and angular basis. +class Radial t => Circle t where + _azimuth :: Lens' (t a) (Angle a) + _polar :: Lens' (t a) (Polar a) + +er :: Radial v => E v +er = E _radial + +eθ, etheta :: Circle v => E v +eθ = E (_polar . polarWrapper . _y) +etheta = eθ + +-- | Coordinate with at least one dimension where the x coordinate can be +-- retreived numerically. Note this differs slightly from 'R1' which requires +-- a lens for all values. This allows instances for different coordinates +-- such as 'Polar', where the x coordinate can only be retreived numerically. +class HasX t where + x_ :: RealFloat n => Lens' (t n) n + +instance HasX v => HasX (Point v) where + x_ = _Point . x_ + +instance HasX V2 where x_ = _x +instance HasX V3 where x_ = _x +instance HasX Polar where x_ = polarV2 . _x + +-- | Coordinate with at least two dimensions where the x and y coordinates can be +-- retreived numerically. +class HasX t => HasY t where + y_ :: RealFloat n => Lens' (t n) n + y_ = xy_ . _y + + xy_ :: RealFloat n => Lens' (t n) (V2 n) + +instance HasY v => HasY (Point v) where + xy_ = lensP . xy_ + +instance HasY V2 where xy_ = id +instance HasY V3 where xy_ = _xy +instance HasY Polar where xy_ = polarV2 + +-- | Does not satify lens laws. +instance RealFloat n => PointLike V2 n (Polar n) where + pointLike = _Point . from polarV2 + {-# INLINE pointLike #-} + diff --git a/src/Plots.hs b/src/Plots.hs new file mode 100644 --- /dev/null +++ b/src/Plots.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines types for axis labels and tick labels. +-- +---------------------------------------------------------------------------- +module Plots + ( + + -- | Axis definition (r2Axis and polarAxis), aspect ratio and scaling. + module Plots.Axis + + -- | 'AxisStyle's are used to provide default colours and shapes + -- for the plots of an axis. + , module Plots.Style + + -------------------------------------------------------------------- + -- * Plot Types + -------------------------------------------------------------------- + + -- ** Scatter plot + -- | Scatter plots display data as a collection of points. A scatter + -- plot can also be configured to have a different style / + -- transform depending on the data. + + -- | Scatter and bubble. Scatter and bubble plot api. + , module Plots.Types.Scatter + + -- | Bar plots, individual or grouped. + , module Plots.Types.Bar + + -- ** Line plot + + -- | Line, trail and path. Line plot, steps plot api & api for trail + -- and path. + , module Plots.Types.Line + + -- ** Heat map plot + + -- | 2D mapping from 'Double's to colours. + , module Plots.Types.HeatMap + + -- ** Histogram plot + + -- | Histogram. API for histogram. + , module Plots.Types.Histogram + + -- | Wedge and annular wedge. API for wedge, annular wegde and pie. + , module Plots.Types.Pie + + -------------------------------------------------------------------- + -- * Low level + -------------------------------------------------------------------- + + -- | Definitions of bounds, axis scale, orientation, legend, generic + -- plot ,plot spec and so on. + , module Plots.Types + + -- | Grid lines and styles. + , module Plots.Legend + + -- | Grid lines and styles. + , module Plots.Axis.Grid + + -- | Axis labels and tick labels . + , module Plots.Axis.Labels + + -- | Rendering system for polar and r2 axis. + , module Plots.Axis.Render + + -- | The scaling/size options for an axis. + , module Plots.Axis.Scale + + -- | Ticks properties and placement. + , module Plots.Axis.Ticks + + -- | The plot title. + , module Plots.Axis.Title + + -- | Colour bars. + , module Plots.Axis.ColourBar + + -- | Polar coordinates + , module Diagrams.Coordinates.Polar + + , (&=), (&~~) + + ) where + +import Diagrams.Coordinates.Polar + +import Plots.Axis +import Plots.Axis.ColourBar +import Plots.Axis.Grid +import Plots.Axis.Labels +import Plots.Axis.Render +import Plots.Axis.Scale +import Plots.Axis.Title +import Plots.Axis.Ticks + +import Plots.Legend +import Plots.Style +import Plots.Types +import Plots.Util + +import Plots.Types.Bar +import Plots.Types.HeatMap +import Plots.Types.Histogram +import Plots.Types.Line +import Plots.Types.Pie +import Plots.Types.Scatter + diff --git a/src/Plots/Axis.hs b/src/Plots/Axis.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- The 'Axis' is the main data type for "plots". It holds all the +-- nessesary infomation to be rendered into a 'Diagram'. +-- +---------------------------------------------------------------------------- +module Plots.Axis + ( -- * Axis type + Axis + , axes + , axisPlots + , currentPlots + , finalPlots + , plotModifier + , axisSize + , colourBarRange + + -- * Predefined axes + , r2Axis + , polarAxis + + -- ** Base space + , BaseSpace + + -- * Axis plots + , addPlot + , addPlotable + , addPlotable' + + -- * Single axis + , SingleAxis + + -- * Specific axes + -- ** x-axis + , xAxis + , xLabel + , xMin + , xMax + + -- ** y-axis + , yAxis + , yLabel + , yMin + , yMax + + -- ** r-axis + , rAxis + , rLabel + , rMax + + -- ** theta-axis + , thetaAxis + , thetaLabel + + -- ** z-axis + , zAxis + , zLabel + , zMin + , zMax + ) where + +import Control.Monad.State +import Data.Complex +import Data.Default +import Data.Typeable + +import Diagrams.Coordinates.Polar +import Diagrams.Prelude +import Diagrams.TwoD.Text + +import Plots.Axis.ColourBar +import Plots.Axis.Grid +import Plots.Axis.Labels +import Plots.Axis.Line +import Plots.Axis.Scale +import Plots.Axis.Title +import Plots.Axis.Ticks +import Plots.Legend +import Plots.Style +import Plots.Types + +import Linear + +------------------------------------------------------------------------ +-- Axis data type +------------------------------------------------------------------------ + +-- Single axis --------------------------------------------------------- + +-- | Render infomation for a single axis line. +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 b v n) = v +type instance N (SingleAxis b v n) = n + +instance (TypeableFloat n, Renderable (Text n) b) + => Default (SingleAxis b V2 n) where + def = SingleAxis + { saLabel = def + , saLine = def + , saTickLabel = def + , saGridLines = def + , saTicks = def + , saScaling = def + , saVisible = True + } + +instance Functor f => HasTicks f (SingleAxis b v n) where + bothTicks = lens saTicks (\sa ticks -> sa {saTicks = ticks}) + +instance Functor f => HasMajorTicks f (SingleAxis b v n) where + majorTicks = bothTicks . majorTicks + +instance Functor f => HasMinorTicks f (SingleAxis b v n) where + minorTicks = bothTicks . minorTicks + +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 b v n) b where + tickLabel = lens saTickLabel (\sa tl -> sa {saTickLabel = tl}) + +instance Functor f => HasAxisLine f (SingleAxis b v n) where + axisLine = lens saLine (\sa l -> sa {saLine = l}) + +instance Functor f => HasGridLines f (SingleAxis b v n) where + gridLines = lens saGridLines (\sa l -> sa {saGridLines = l}) + +instance Functor f => HasMajorGridLines f (SingleAxis b v n) where + majorGridLines = gridLines . majorGridLines + +instance Functor f => HasMinorGridLines f (SingleAxis b v n) where + minorGridLines = gridLines . minorGridLines + +instance Functor f => HasAxisScaling f (SingleAxis b v n) where + axisScaling = lens saScaling (\sa s -> sa {saScaling = s}) + +instance HasVisibility (SingleAxis b v n) where + visible = lens saVisible (\sa b -> sa {saVisible = b}) + +-- singleAxisScale :: Lens' (SingleAxis b v n) AxisScale +-- singleAxisScale = lens saScale (\sa s -> sa {saScale = s}) + +-- singleAxisBound :: Lens' (SingleAxis b v n) (Bound n) +-- singleAxisBound = lens saBounds (\sa b -> sa {saBounds = b}) + +------------------------------------------------------------------------ +-- Axis type +------------------------------------------------------------------------ + +-- Base space ---------------------------------------------------------- + +-- | This family is used so that we can say (Axis Polar) but use V2 for the +-- underlying diagram. +type family BaseSpace (c :: * -> *) :: * -> * + +type instance BaseSpace V2 = V2 +type instance BaseSpace Complex = V2 +type instance BaseSpace Polar = V2 +type instance BaseSpace V3 = V3 + +-- Axis data type ------------------------------------------------------ + +-- | Axis is the data type that holds all the nessessary information to render +-- a plot. Common 'LensLike's used for the axis (see haddock's +-- instances for a more comprehensive list): +-- +-- * 'axisStyle' - customise the 'AxisStyle' +-- * 'legend' - customise the 'Legend' +-- * 'colourBar' - customise the 'ColourBar' +-- * 'currentPlots' - current plots in the 'Axis' +-- * 'finalPlots' - changes to the plots just before rendering +-- * 'axes' - changes to each 'SingleAxis' +-- +-- * 'xAxis' - the x-axis +-- * 'yAxis' - the y-axis +-- * 'zAxis' - the z-axis +-- +-- The following 'LensLike's can be used on the on all the axes by +-- applying it the to 'Axis' or can be used on a 'SingleAxis' by using +-- it in combination with a specific axis (like 'xAxis'). +-- +-- * 'axisLabel' - customise the 'MinorTicks' +-- * 'tickLabel' - customise the 'TickLabels' +-- * 'minorTicks' - customise the 'MinorTicks' +-- * 'majorTicks' - customise the 'MajorTicks' +-- * 'gridLines' - customise the 'GridLines' +-- * 'axisLine' - customise the 'AxisLine' +-- * 'axisScaling' - customise the 'AxisScaling' +-- +-- Plots are usually added to the axis using specific functions for +-- that plots ('Plots.Types.Line.linePlot, 'Plots.Types.Bar.barPlot'). +-- These functions use 'addPlotable' to add the plot to the axis. +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 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 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' b c n) (c ('SingleAxis' b v n)) +-- @ +axes :: (v ~ BaseSpace c, v ~ BaseSpace c') + => 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 b c n) [DynamicPlot b v n] +axisPlots = lens _axisPlots (\a ps -> a {_axisPlots = ps}) + +-- | Traversal over the current plots in the axis. +-- +-- For example, to make all 'ScatterPlot's currently in the axis use a +-- 'connectingLine', you can write +-- +-- @ +-- 'finalPlots' . 'connectingLine' .= 'True' +-- @ +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. +-- +-- For example, to make all 'ScatterPlot's in the axis use a +-- 'connectingLine' (both currently in the axis and ones added later), +-- you can add +-- +-- @ +-- 'finalPlots' . 'connectingLine' .= 'True' +-- @ +-- +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 b c n) (Endo (StyledPlot b v n)) +plotModifier = lens _plotModifier (\a f -> a {_plotModifier = f}) + +-- Axis instances ------------------------------------------------------ + +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 b c n) where + bothTicks = axes . traverse . bothTicks + +instance (Applicative f, Traversable c) => HasMajorTicks f (Axis b c n) where + majorTicks = axes . traverse . majorTicks + +instance (Applicative f, Traversable c) => HasMinorTicks f (Axis b c n) where + minorTicks = axes . traverse . minorTicks + +instance (Applicative f, Traversable c) => HasGridLines f (Axis b c n) where + gridLines = axes . traverse . gridLines + +instance (Applicative f, Traversable c) => HasMajorGridLines f (Axis b c n) where + majorGridLines = axes . traverse . majorGridLines + +instance (Applicative f, Traversable c) => HasMinorGridLines f (Axis b c n) where + minorGridLines = axes . traverse . minorGridLines + +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 b c n) b where + tickLabel = axes . traverse . tickLabel + +instance (Applicative f, Traversable c) => HasAxisScaling f (Axis b c n) where + axisScaling = axes . traverse . axisScaling + +instance Settable f => HasPlotOptions f (Axis b c n) b where + plotOptions = finalPlots . plotOptions + +instance Settable f => HasPlotStyle f (Axis b c n) b where + plotStyle = finalPlots . plotStyle + +instance HasLegend (Axis b c n) b where + legend = lens _legend (\a l -> a {_legend = l}) + +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, 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 automaticlaly set +-- when using 'heatMap' or 'heatMap'' +colourBarRange :: Lens' (Axis b v n) (n,n) +colourBarRange = lens _colourBarR (\a r -> a {_colourBarR = r}) + +instance HasAxisStyle (Axis b v n) b where + axisStyle = lens _axisStyle (\a sty -> a {_axisStyle = sty}) + +instance HasColourBar (Axis b v n) b where + colourBar = lens _colourBar (\a cb -> a {_colourBar = cb}) + +-- Axis functions ------------------------------------------------------ + +-- $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 n a, 'Plotable' a b)@: +-- +-- @ +-- '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 +-- make adjustments to the plot. The @L@ suffix stands for \"legend\", +-- it is equivalent of using 'addLegendEntry' in the 'PlotState'. Since +-- legend entries are so common it has it's own suffix. The following +-- are equivalent: +-- +-- @ +-- myaxis = 'r2Axis' &~ do +-- 'addPlotable'' myplot $ do +-- 'addLegendEntry' "my plot" +-- @ +-- +-- Most of the time you won't use these functions directly. However, +-- other plotting functions follow this naming convention where instead +-- of @a@, it takes the data needed to make the plot. + +-- | Add a 'Plotable' 'Plot' to an 'Axis'. +addPlot + :: (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 statefull modification +-- of the 'Plot'. +addPlotable + :: (InSpace (BaseSpace c) n p, MonadState (Axis b c n) m, Plotable p b) + => p -- ^ the raw 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 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 ()) + +------------------------------------------------------------------------ +-- Predefined axes +------------------------------------------------------------------------ + +-- | The default axis for plots in the 'V2' coordinate system. +r2Axis + :: (TypeableFloat n, + Renderable (Text n) b, + Renderable (Path V2 n) b) + => Axis b V2 n +r2Axis = Axis + { _axisStyle = fadedColours + , _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 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 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 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 b c n) (Maybe n) +xMax = xAxis . boundMax + +-- The y-axis ---------------------------------------------------------- + +-- | Lens onto the y-axis of an 'Axis'. +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 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 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 b c n) (Maybe n) +yMax = yAxis . boundMax + +-- The z-axis ---------------------------------------------------------- + +-- | Lens onto the z-axis of an 'Axis'. +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 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 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 b c n) (Maybe n) +zMax = zAxis . boundMax + +-- The r-axis ---------------------------------------------------------- + +-- | Lens onto the radial axis of an 'Axis'. +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 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 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 b c n) (Maybe n) +rMax = rAxis . boundMax + +-- The theta-axis ------------------------------------------------------ + +-- | Lens onto the radial axis of an 'Axis'. +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 b c n) String +thetaLabel = thetaAxis . axisLabelText + + +-- R3 Axis + +-- instance (TypeableFloat n, Enum n, Renderable (Text n) b, Renderable (Path V2 n) b) +-- => Default (Axis b V3 n) where +-- def = Axis +-- { _axisTitle = Nothing +-- , _axisSize = mkWidth 300 +-- , _axisPlots = [] +-- , _axisLegend = def +-- , _axisTheme = coolTheme +-- , _axisLinearMap = isometricProjection +-- , _axisAxisBounds = Bounds $ pure def +-- , _axisGridLines = pure def +-- , _axisLabels = pure def +-- , _axisScaling = pure def +-- , _axisTickLabels = pure def +-- , _axisTicks = pure def +-- , _axisLines = pure def +-- } + +-- R3 Axis + +polarAxis + :: (TypeableFloat n, + Renderable (Text n) b, + Renderable (Path V2 n) b) + => Axis b Polar n +polarAxis = Axis + { _axisStyle = fadedColours + , _colourBar = defColourBar + , _colourBarR = (0,1) + , _axisTitle = def + + , _legend = def + , _axisPlots = [] + , _plotModifier = mempty + + , _axes = pure def + } + diff --git a/src/Plots/Axis/ColourBar.hs b/src/Plots/Axis/ColourBar.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/ColourBar.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.ColourBar +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Options for rendering a colour bar, either attached to an axis or +-- rendered separately. +-- +-- To change the colour map used for the colour bar see +-- 'Plots.Style.axisColourMap' from "Plots.Style". +-- +---------------------------------------------------------------------------- +module Plots.Axis.ColourBar + ( -- * The colour bar + ColourBar + , HasColourBar (..) + , defColourBar + + -- ** Rendering options + , gradientColourBar + , pathColourBar + + -- * Rendering colour bars + , renderColourBar + , addColourBar + ) where + +import Data.Bool (bool) +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 +import Plots.Axis.Ticks +import Plots.Style +import Plots.Types +import Plots.Util + +-- | 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 b n = ColourBar + { cbPlacement :: Placement + , cbVisible :: Bool + , cbTicks :: MajorTicks 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 b n) = V2 +type instance N (ColourBar b n) = n + +-- | The default colour bar. +defColourBar :: (Renderable (Text n) b, Renderable (Path V2 n) b, TypeableFloat n) + => ColourBar b n +defColourBar = ColourBar + { cbPlacement = rightMid + , cbVisible = False + , cbTicks = def + , cbGridLines = def + , cbTickLabels = def + , cbDraw = gradientColourBar + , cbWidth = 20 + , cbLengthFun = id + , cbGap = 20 + , cbStyle = mempty + } + +class HasColourBar a b | a -> b where + -- | Lens onto the '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 + -- in the middle of the left side. See 'gradientColourBar' and + -- 'pathColourBar'. + -- + -- The colour map this function recieves it given by + -- 'Plots.Style.axisColourMap' from "Plots.Style" + -- + -- Default is 'gradientColourBar'. + 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 (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 (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 (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 (N a)) + colourBarStyle = colourBar . lens cbStyle (\c a -> c {cbStyle = a}) + +instance HasColourBar (ColourBar b n) b where + colourBar = id + +instance HasGap (ColourBar b n) where + gap = colourBarGap + +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. +-- The Orientation depends on the 'Placement' of the colour bar. +-- +-- \ N / +-- W * E +-- / S \ +-- +-- if it's on the east or west it's vertical, north or south it's +-- horizontal. If it's on a border it uses whatever way the gap +-- direction points. If the direction is parallel to the direction it's +-- on, we arbitrary choose pointing NE or SE to be vertical, NW and SW +-- to be horizontal (just for completeness, having such gap directions +-- doesn't make much sense). +-- +-- 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 b n) where + orientation = lens getter setter where + + getter p + | north || south = Horizontal + | east || west = Vertical + | northEast = bool Horizontal Vertical (dx > dy) + | southEast = bool Horizontal Vertical (dx > -dy) + | southWest = bool Horizontal Vertical (dx < dy) + | northWest = bool Horizontal Vertical (dx < -dy) + | otherwise = error $ "internal error: get colourBar orientation: " + ++ show (p ^. placement) + where + V2 x y = p ^. placementAt + V2 dx dy = p ^. gapDirection . _Dir + north = x < y && x > (-y) + east = x > y && x > (-y) + south = x > y && x < (-y) + west = x < y && x < (-y) + northEast = x == y && x > 0 + southEast = x == (-y) && x > 0 + southWest = x == y && x < 0 + northWest = x == (-y) && x < 0 + + setter p o + | getter p == o = p + | otherwise = p & placementAt %~ flipX_Y + & placementAnchor %~ flipX_Y + & gapDirection ._Dir %~ flipX_Y + +instance Typeable n => HasStyle (ColourBar b n) where + applyStyle sty = colourBarStyle %~ applyStyle sty + +instance Functor f => HasMajorTicks f (ColourBar b n) where + majorTicks = lens cbTicks (\c a -> c {cbTicks = a}) + +instance Functor f => HasTickLabels f (ColourBar b n) b where + tickLabel = lens cbTickLabels (\c a -> c {cbTickLabels = a}) + +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 + :: (TypeableFloat n, Renderable (Path V2 n) b) + => BoundingBox V2 n -- ^ bounding box to place against + -> ColourBar b n -- + -> ColourMap + -> (n,n) + -> QDiagram b V2 n Any +addColourBar bb cbo@ColourBar {..} cm bnds + | cbVisible = placeAgainst bb cbPlacement cbGap cb + | otherwise = mempty + where + cb = renderColourBar cbo cm bnds l + -- the length used for the rendered colour bar + l = cbLengthFun bbl + -- the length of the side of the bounding box the colour bar will be + -- against + bbl = orient cbo bx by + V2 bx by = boxExtents bb + +-- | Render a colour bar by it's self at a given width. Note this +-- ignores 'colourBarGap' and 'colourBarLengthFunction'. +renderColourBar + :: (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) + + <> tLbs + | otherwise = mempty + + where + -- These functions deal with the different cases for the position of + -- the colour bar so that the ticks and labels are on the outside of + -- the axis and the bar horizontal/vertical depending on which side + -- the bar is on. + o, xy :: a -> a -> a + o = orient cb + xy a b = if let V2 x y = cb^.placementAt in x > y + then a else b + + w = cbWidth + -- move a value on the colour bar such that + -- f lb = -l/2 + -- f ub = l/2 + -- so it ligns up with the colour bar + f x = (x - (ub + lb)/2) / (ub - lb) * l + inRange x = x >= lb && x <= ub + + bar = outline <> tks <> gLines <> colours + + -- the outline + outline = rect l w # applyStyle (cbStyle & _fillTexture .~ _AC ## transparent) + + -- displaying the colour map + colours = cbDraw cm # centerXY # scaleX l # scaleY w + + -- the ticks + tickXs = view majorTicksFunction cbTicks bnds + tickXs' = filter inRange tickXs + tks + | cbTicks ^. hidden = mempty + | otherwise = foldMap (\x -> aTick # translate (V2 (f x) (-w/2))) tickXs' + aTick = someTick (cbTicks ^. majorTicksAlignment) (cbTicks ^. majorTicksLength) + + someTick tType d = case tType of + TickSpec (fromRational -> aa) (fromRational -> bb) + -> 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 = foldMap mkGridLine gridXs + # strokePath + # applyStyle (cbGridLines ^. majorGridLinesStyle) + mkGridLine x = mkP2 (f x) (-w/2) ~~ mkP2 (f x) (w/2) + + -- tick labels + tickLabelXs = view tickLabelFunction cbTickLabels tickXs' bnds + tLbs + | cbTickLabels ^. hidden = mempty + | otherwise = foldMap drawTickLabel tickLabelXs + drawTickLabel (x,label) = + view tickLabelTextFunction cbTickLabels tAlign label + # translate v + # applyStyle (cbTickLabels ^. tickLabelStyle) + where v = V2 (f x) (- w/2 - view tickLabelGap cbTickLabels) + # xy id (_y %~ negate) + # o id ((_y %~ negate) . flipX_Y) + + tAlign = o (xy (BoxAlignedText 0.5 1) (BoxAlignedText 0.5 0)) + (xy (BoxAlignedText 0 0.5) (BoxAlignedText 1 0.5)) + +-- > import Plots +-- > gradientColourBarExample = gradientColourBar viridis # scaleX 20 +-- > pathColourBarExample = pathColourBar 10 viridis # scaleX 20 + +-- | The colour bar generated by a gradient texture. The final diagram +-- is 1 by 1, with origin at the middle of the left side. This can be +-- used as the 'colourBarDraw' function. +-- +-- This may not be supported by all backends. +-- +-- <> +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) -> 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 :: (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 + # alignR + # fcA (cm ^. ixColour (x - 1/(2*fromIntegral n))) + # translateX (fromRational x) + # lw none + where + -- Some vector viewers don't render touching blocks of colour + -- correctly. To solve this we overlap by half a bar length for + -- all except the first bar (which is the one on top). + d' | i == 0 = d + | otherwise = d*1.5 + + xs = tail (enumFromToN 0 1 n) + d = 1 / fromIntegral n + +flipX_Y :: Num n => V2 n -> V2 n +flipX_Y (V2 x y) = V2 (-y) (-x) + +_reflectionX_Y :: (Additive v, R2 v, Num n) => Transformation v n +_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 new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Grid.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Grid +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Lines that go along the axis. Supports major and minor gird lines +-- separately for each axis. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Grid + ( -- * Grid lines + GridLines + , HasGridLines (..) + + , MajorGridLines + , HasMajorGridLines (..) + , MinorGridLines + , HasMinorGridLines (..) + + -- * Extra traversals + , gridLinesStyle + , gridLinesVisible + + , hideGridLines + , showGridLines + + -- * Grid line functions + , GridLineFunction + , onTicksGridLineFunction + , emptyGridLineFunction + + ) where + +import Control.Lens hiding (( # )) +import Data.Data +import Data.Default +import Control.Monad.State + +import Diagrams.Prelude +import Plots.Types + +-- | A grid line function takes the positions of the respective ticks +-- (minor ticks for minor grid lines, major ticks for major grid +-- lines) and the bounds of the axis and returns the positions of the +-- grid lines. +-- +-- These functions are used in conjuction with 'majorGridLineFunction' +-- and 'minorGridLineFunction' to control how the lines are drawn. +type GridLineFunction n = [n] -> (n, n) -> [n] + +------------------------------------------------------------------------ +-- Major grid lines +------------------------------------------------------------------------ + +data MajorGridLines v n = MajorGridLines + { magFun :: GridLineFunction n + , magStyle :: Style v n + , magVisible :: Bool + } deriving Typeable + +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 + -- various levels of the axis: + -- + -- @ + -- 'majorGridLines' :: 'Traversal'' ('Axis' b c n) ('GridLines' ('BaseSpace' c) n) + -- 'majorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) + -- 'majorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) + -- @ + 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 (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) (N a)) + majorGridLinesStyle = majorGridLines . lens magStyle (\gl sty -> gl {magStyle = sty}) + +instance HasMajorGridLines f (MajorGridLines v n) where + majorGridLines = id + +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 n) where + visible = lens magVisible (\gl b -> gl {magVisible = b}) + +instance Typeable n => HasStyle (MajorGridLines v n) where + applyStyle s = majorGridLinesStyle %~ applyStyle s + +------------------------------------------------------------------------ +-- Minor grid lines +------------------------------------------------------------------------ + +data MinorGridLines v n = MinorGridLines + { migFun :: GridLineFunction n + , migStyle :: Style v n + , migVisible :: Bool + } deriving Typeable + +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 + -- various levels of the axis: + -- + -- @ + -- 'minorGridLines' :: 'Traversal'' ('Axis' b c n) ('GridLines' ('BaseSpace' c) n) + -- 'minorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) + -- 'minorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) + -- @ + 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 (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) (N a)) + minorGridLinesStyle = minorGridLines . lens migStyle (\gl sty -> gl {migStyle = sty}) + +instance HasMinorGridLines f (MinorGridLines v n) where + minorGridLines = id + +instance (Typeable n, Floating n) => Default (MinorGridLines v n) where + def = MinorGridLines + { migFun = onTicksGridLineFunction + , migStyle = mempty # lwO 0.5 + , migVisible = False + } + +-- | Hidden by default. +instance HasVisibility (MinorGridLines v n) where + visible = lens migVisible (\gl b -> gl {migVisible = b}) + +instance Typeable n => HasStyle (MinorGridLines v n) where + applyStyle s = minorGridLinesStyle %~ applyStyle s + +------------------------------------------------------------------------ +-- Grid lines helpers +------------------------------------------------------------------------ + +-- | Place grid lines at the same position as the respective ticks. This +-- is the 'Default'. +onTicksGridLineFunction :: GridLineFunction n +onTicksGridLineFunction = const + +-- | The 'GridLineFunction' such that no grid lines appear. +-- +-- See 'hideGridLines', 'majorGridLineVisible' or +-- 'minorGridLineVisible' if you just want to hide the grid lines. +emptyGridLineFunction :: GridLineFunction n +emptyGridLineFunction _ _ = [] + +-- | Traversal over both the major and minor grid styles. +-- +-- @ +-- 'gridLinesVisible' :: 'Traversal'' ('Axis' b c n) 'Bool' +-- 'gridLinesVisible' :: 'Traversal'' ('SingleAxis' b v n) 'Bool' +-- 'gridLinesVisible' :: 'Traversal'' ('GridLines' v n) 'Bool' +-- @ +gridLinesVisible :: (HasGridLines f a, Applicative f) => LensLike' f a Bool +gridLinesVisible = gridLines . vis where + 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) + +------------------------------------------------------------------------ +-- Both grid lines +------------------------------------------------------------------------ + +-- | Type holding infomation about both major and minor grid lines. +data GridLines v n = GridLines + { majGrid :: MajorGridLines v n + , minGrid :: MinorGridLines v n + } deriving Typeable + +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) (N a)) + +instance Functor f => HasGridLines f (GridLines v n) where + gridLines = id + +instance (Typeable n, Floating n) => Default (GridLines v n) where + def = GridLines + { majGrid = def + , minGrid = def + } + +instance Functor f => HasMajorGridLines f (GridLines v n) where + majorGridLines = lens majGrid (\g a -> g {majGrid = a}) + +instance Functor f => HasMinorGridLines f (GridLines v n) where + minorGridLines = lens minGrid (\g a -> g {minGrid = a}) + +instance Typeable n => HasStyle (GridLines v n) where + applyStyle s = (majorGridLines %~ applyStyle s) . (minorGridLines %~ applyStyle s) + +-- | Hide both major and minor grid lines. +-- +-- @ +-- 'hideGridLines' :: 'Axis' b c n -> 'Axis' b c n +-- 'hideGridLines' :: 'SingleAxis' b c n -> 'SingleAxis' b c n +-- 'hideGridLines' :: 'GridLines' b c n -> 'GirdLines' b c n +-- @ +hideGridLines :: (HasGridLines Identity a, MonadState a m) => m () +hideGridLines = do + minorGridLines . visible .= False + majorGridLines . visible .= False + +-- | Show both major and minor grid lines. +-- +-- @ +-- 'showGridLines' :: 'Axis' b c n -> 'Axis' b c n +-- 'showGridLines' :: 'SingleAxis' b c n -> 'SingleAxis' b c n +-- 'showGridLines' :: 'GridLines' b c n -> 'GirdLines' b c n +-- @ +showGridLines :: (HasGridLines Identity a, MonadState a m) => m () +showGridLines = do + minorGridLines . visible .= True + majorGridLines . visible .= True + +-- | Traversal over both the major and minor grid styles. This can be used at seversal levels in the Axis: +gridLinesStyle :: (HasGridLines f a, Applicative f) => LensLike' f a (Style (V a) (N a)) +gridLinesStyle = gridLines . styles where + 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 new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Labels.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Labels +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Low level module defining types for axis labels and tick labels. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Labels + ( -- * Axis line labels + HasAxisLabel (..) + , AxisLabel + , AxisLabelPosition (..) + , AxisLabelPlacement (..) + + -- * Axis tick labels + , TickLabels + , HasTickLabels (..) + , tickLabelPositions + , atMajorTicks + + -- * Misc + , TextFunction + ) where + +import Control.Lens hiding (( # )) +import Data.Data +import Data.Default + +import Diagrams.Prelude hiding (view) +import Diagrams.TwoD.Text +import Plots.Types + +-- | 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 b v n = TextAlignment n -> String -> QDiagram b v n Any + +------------------------------------------------------------------------ +-- Axis labels +------------------------------------------------------------------------ + +-- | The position of the 'AxisLabel' along the axis. +data AxisLabelPosition + = MiddleAxisLabel + | LowerAxisLabel + | UpperAxisLabel + +-- | Whether the 'AxisLabel' should be inside or ouside the axis. +data AxisLabelPlacement + = InsideAxisLabel + | OutsideAxisLabel + +data AxisLabel b v n = AxisLabel + { alFun :: TextFunction b v n + , alText :: String + , alStyle :: Style v n + , alGap :: n + , alPos :: AxisLabelPosition + , alPlacement :: AxisLabelPlacement + , alVisible :: Bool + } + +type instance V (AxisLabel b v n) = v +type instance N (AxisLabel b v n) = n + +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' b v n) ('AxisLabel' v n) + -- 'axisLabel' :: 'Lens'' ('AxisLabel' v n) ('AxisLabel' v n) + -- @ + 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 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 (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) (N a)) + axisLabelStyle = axisLabel . lens alStyle (\al sty -> al {alStyle = sty}) + + -- | The position the label will be placed parallel the axis. + axisLabelPosition :: Functor f => LensLike' f a AxisLabelPosition + axisLabelPosition = axisLabel . lens alPos (\al sty -> al {alPos = sty}) + + -- | Whether the axis label should be placed inside or outside the + -- axis. + axisLabelPlacement :: Functor f => LensLike' f a AxisLabelPosition + axisLabelPlacement = axisLabel . lens alPos (\al sty -> al {alPos = sty}) + +instance HasAxisLabel f (AxisLabel b v n) b where + axisLabel = id + +instance Typeable n => HasStyle (AxisLabel b v n) where + applyStyle = over axisLabelStyle . applyStyle + +instance HasVisibility (AxisLabel b v n) where + visible = lens alVisible (\al b -> al {alVisible = b}) + +instance HasGap (AxisLabel b v n) where + gap = axisLabelGap + +instance (TypeableFloat n, Renderable (Text n) b) + => Default (AxisLabel b V2 n) where + def = AxisLabel + { alFun = mkText + , alText = "" + , alStyle = mempty & fontSize (output 11) + & recommendFillColor black + , alGap = 30 + , alPos = MiddleAxisLabel + , alPlacement = OutsideAxisLabel + , alVisible = True + } + +------------------------------------------------------------------------ +-- Tick labels +------------------------------------------------------------------------ + +-- Labels that are placed next to the ticks of an axis. + +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 b v n) = v +type instance N (TickLabels b v n) = n + +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' 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 b (V a) (N a)) + + -- | The 'TextFunction' to render the text. + -- + -- 'Default' is 'mkText'. + 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 has + -- access to the major ticks and the current bounds. Returns the + -- position of the tick and label to use at that position. + -- + -- 'Default' is @'atMajorTicks' 'floatShow'@ + 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) (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 (N a) + tickLabelGap = tickLabel . lens tlGap (\tl n -> tl {tlGap = n}) + +instance HasTickLabels f (TickLabels b v n) b where + tickLabel = id + +instance HasGap (TickLabels b v n) where + gap = tickLabelGap + +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) + & recommendFillColor black + , tlGap = 12 + , tlVisible = True + } + +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 +-- general as 'minorTicksFunction' because you don't have access to +-- the bounds but it can be useful when you know exactly what ticks +-- you want to add or modify existing tick positions. +tickLabelPositions + :: (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 +-- 1.30000000008. (This is not an ideal solution.) +floatShow :: Real n => n -> String +floatShow = show . (realToFrac :: Real n => n -> Float) + +-- | Make a 'TickLabelFunction' by specifying how to draw a single label +-- from a position on the axis. +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 +-- -- and going to 2, 3, 4 ... . +-- stringLabels :: Num n => [(n, String)] -> TickLabelFunction n +-- stringLabels nms _ _ = iover (each . itraversed) (\i l -> (fromIntegral (i + 1), l)) nms + diff --git a/src/Plots/Axis/Line.hs b/src/Plots/Axis/Line.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Line.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Line +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- The lines that make up an axis. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Line + ( -- * Grid lines + AxisLine + , HasAxisLine (..) + + -- * Axis line types + , AxisLineType (..) + + ) where + +import Control.Lens hiding (( # )) +import Data.Data +import Data.Default + +import Diagrams.Prelude +import Plots.Types + +-- | Where axis line for coordinate should be drawn. The 'Default' is +-- 'BoxAxisLine'. +data AxisLineType + = BoxAxisLine + | LeftAxisLine + | MiddleAxisLine + | RightAxisLine + | NoAxisLine + deriving (Show, Eq, Typeable) + +instance Default AxisLineType where + def = BoxAxisLine + +-- | Information about position and style of axis lines. +data AxisLine v n = AxisLine + { alType :: AxisLineType + , alArrowOpts :: Maybe (ArrowOpts n) + , alVisible :: Bool + , alStyle :: Style v n + } deriving Typeable + +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) (N a)) + + -- | The position of the axis line around the axis. + -- + -- 'Default' is 'BoxAxisLine'. + axisLineType :: Functor f => LensLike' f a AxisLineType + axisLineType = axisLine . lens alType (\al sty -> al {alType = sty}) + + -- | The options for if you want the axis line to have arrows at the + -- end. + -- + -- '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}) + + -- | The 'Style' applied to the axis line + 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 n) where + axisLine = id + +-- 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 n) where + visible = lens alVisible (\al b -> al {alVisible = b}) + +instance Typeable n => Default (AxisLine v n) where + def = AxisLine + { alType = def + , alArrowOpts = def + , alVisible = True + , alStyle = mempty + } + diff --git a/src/Plots/Axis/Render.hs b/src/Plots/Axis/Render.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Render.hs @@ -0,0 +1,671 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- Orphan Mainable Axis instance. +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Render +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Low level module containing functions for rendering different types +-- of axis. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Render + ( -- * Rendering axes + RenderAxis (..) + , r2AxisMain + + -- * Low level + , buildPlots + )where + +import Data.Foldable +import Data.Typeable +import Data.Bool +import Data.List (sort) + +import Diagrams.BoundingBox +import Diagrams.Prelude +import Diagrams.TwoD.Text +import Linear hiding (translation, rotate) + +import Diagrams.Backend.CmdLine +import Diagrams.Coordinates.Polar + +import Plots.Axis +import Plots.Axis.ColourBar +import Plots.Axis.Grid +import Plots.Axis.Labels +import Plots.Axis.Line +import Plots.Axis.Scale +import Plots.Axis.Title +import Plots.Axis.Ticks +import Plots.Legend +import Plots.Style +import Plots.Types +import Plots.Util + +import Prelude + +------------------------------------------------------------------------ +-- Mainable instances +------------------------------------------------------------------------ + +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 + +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 + +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 + +-- | 'mainWith' specialised to a 2D Axis. +r2AxisMain + :: (Parseable (MainOpts (QDiagram b V2 Double Any)), + Mainable (Axis b V2 Double)) + => Axis b V2 Double + -> IO () +r2AxisMain = mainWith + +------------------------------------------------------------------------ +-- Low level functions +------------------------------------------------------------------------ + +-- | Build a list of styled plots from the axis, ready to be rendered. +-- This takes into account any 'AxisStyle' changes and applies the +-- 'finalPlots' modifications. +-- +-- The 'StyledPlots' can be rendered with 'renderStyledPlot' and the +-- 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 b c n -> [StyledPlot b v n] +buildPlots a = map (appEndo $ a ^. plotModifier) + $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) + -- TODO: correct order + +------------------------------------------------------------------------ +-- Render axis +------------------------------------------------------------------------ + +-- | Renderable axes. +class RenderAxis b v n where + -- | Render an axis to a diagram. The size of the diagram is + -- determined by the 'axisSize'. + 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 (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 :: (TypeableFloat n, Renderable (Path V2 n) b) + => Axis b V2 n -> QDiagram b V2 n Any +renderR2Axis a = frame 40 + $ leg + <> ttl + <> cBar + <> plots + <> drawAxis ex ey LowerLabels + <> drawAxis ey ex LeftLabels + 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 + | LowerLabels + | LeftLabels + | RightLabels + | UpperLabels + deriving (Show, Eq, Typeable) + +axisOnBasis + :: 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 + -> 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? + -> 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 = stroke . transform t + + -- axis labels (x,y etc.) + axLabels + | null txt || lp == NoLabels || a ^. axisLabel . hidden + = mempty + | otherwise = (a ^. axisLabelTextFunction) txtAlign txt + # moveTo p' + # applyStyle (a ^. axisLabelStyle) + where + p' = p & ep e .~ x + & ep eO .~ y0 + -- & logPoint ls + & coscale + & papply t + & ep eO +~ negate' labelGap + labelGap = a ^. axisLabelGap + txt = a ^. axisLabelText + x = case a ^. axisLabelPosition of + MiddleAxisLabel -> (x0 + x1) / 2 + LowerAxisLabel -> x0 + UpperAxisLabel -> x1 + -- axLabelD = a ^. axisLabels . el e + + -- tick labels + tickLabels + | lp == NoLabels || a ^. tickLabel . hidden = mempty + | otherwise = foldMap drawLabels (map snd $ take 1 ys) + # applyStyle (a ^. tickLabelStyle) + where + -- tickLabelsD = a ^. axisTickLabels . el e + labelFun = a ^. tickLabelFunction + drawLabels y = foldMap f (labelFun (filter inRange majorTickXs) b) + where + f (x, l) = place dia p' + where + dia = view tickLabelTextFunction a txtAlign l + p' = p & ep e .~ x + & ep eO .~ y + -- & logPoint ls + & coscale + & papply t + & ep eO +~ negate' (a ^. tickLabelGap) + + -- the grid + + grid = majorLines <> minorLines + where + majorLines + | a ^. majorGridLines . hidden = mempty + | otherwise = foldMap mkGridLine majorGridXs' + # tStroke + # applyStyle (a ^. majorGridLinesStyle) + majorGridXs = view majorGridLinesFunction a majorTickXs b + majorGridXs' = map coscaleNum (filter inRange majorGridXs) + -- + minorLines + | a ^. minorGridLines . hidden = mempty + | otherwise = foldMap mkGridLine minorGridXs' + # tStroke + # applyStyle (a ^. minorGridLinesStyle) + minorGridXs = view minorGridLinesFunction a minorTickXs b + minorGridXs' = map coscaleNum (filter inRange minorGridXs) + -- -- + mkGridLine x = pathFromVertices [f y0, f y1] + where f y = over lensP ((el e .~ x) . (el eO .~ y)) p + -- + -- gridD = a ^. axisGridLines ^. el e -- :: GridLines N + + -- the ticks + + ticks = foldMap drawTicks ys + + drawTicks (pos,y) = maTicks <> miTicks + where + maTicks + | a ^. majorTicks . hidden = mempty + | otherwise = foldMap (positionTick majorTick) majorTickXs' + # stroke + # applyStyle (a ^. majorTicksStyle) + -- + miTicks + | a ^. minorTicks . hidden = mempty + | otherwise = foldMap (positionTick minorTick) minorTickXs' + # stroke + # applyStyle (a ^. minorTicksStyle) + -- + minorTick = someTick (a ^. minorTicksAlignment) (a ^. minorTicksLength) + majorTick = someTick (a ^. majorTicksAlignment) (a ^. majorTicksLength) + -- + someTick tType d = pathFromVertices $ + case tType of + AutoTick -> + case pos of + LowerAxis -> [origin & ep eO -~ d, origin] + MiddleAxis -> [origin & ep eO -~ d, origin & ep eO +~ d] + UpperAxis -> [origin, origin & ep eO +~ d] + TickSpec (fromRational -> aa) (fromRational -> bb) -> + case pos of + UpperAxis -> [origin & ep eO -~ d*bb, origin & ep eO +~ d*aa] + _ -> [origin & ep eO -~ d*aa, origin & ep eO +~ d*bb] + -- NoTick -> [] + -- middleTick d = + -- pathFromVertices + positionTick tick x = place tick p' + where + p' = over lensP ((el e .~ x) . (el eO .~ y)) p + # transform t + + -- axis lines + + line + | a ^. axisLine . hidden = mempty + | otherwise = foldMap mkline (map snd ys) -- merge with ticks? + # transform t + # stroke + -- # applyStyle (a ^. axisLine e . axisArrowOpts . _Just . shaftStyle) + # lineCap LineCapSquare + where + -- TODO: Arrow for R3 + mkline y = pathFromVertices + $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v n + + -- measurements + 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 + then swapped + else id + inRange x = x >= x0 && x <= x1 + -- + majorTickXs = sort $ view majorTicksFunction a b + majorTickXs' = map coscaleNum (filter inRange majorTickXs) + minorTickXs = sort $ view minorTicksFunction a majorTickXs b + minorTickXs' = map coscaleNum (filter inRange minorTickXs) + -- + ys = getAxisLinePos yb lineType + lineType = a ^. axisLineType + txtAlign = + case lp of + LowerLabels -> BoxAlignedText 0.5 1 + LeftLabels -> BoxAlignedText 1 0.5 + RightLabels -> BoxAlignedText 0 0.5 + UpperLabels -> BoxAlignedText 1 0 + _ -> error "No labels" -- XXX Temporary + -- t2 = scaling 4 + -- + negate' = if lp == UpperLabels || lp == RightLabels + then id + else negate + +-- utilities + +getAxisLinePos :: (Num n, Ord n) => (n, n) -> AxisLineType -> [(AxisPos, n)] +getAxisLinePos (a,b) aType = case aType of + BoxAxisLine -> [(LowerAxis, a), (UpperAxis, b)] + LeftAxisLine -> [(LowerAxis, a)] + MiddleAxisLine -> [(,) MiddleAxis $ + if | a > 0 -> a + | b < 0 -> b + | otherwise -> 0] + RightAxisLine -> [(UpperAxis, b)] + NoAxisLine -> [] + +data AxisPos = LowerAxis | MiddleAxis | UpperAxis + +------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------ + +ep :: E v -> Lens' (Point v x) x +ep (E l) = lensP . l +{-# INLINE ep #-} + +------------------------------------------------------------------------ +-- Polar +------------------------------------------------------------------------ + +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 +-- calculations. The more calculations used, the smaller the range of +-- the bound. +boundingRadiusR :: (InSpace V2 n a, Enveloped a) => Int -> a -> (n, n) +boundingRadiusR (max 3 -> n) e = + case appEnvelope (getEnvelope e) of + Nothing -> (0,0) + Just f -> + let thetas = map (@@rad) $ enumFromToN 0 tau n + 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 = 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. + -- We can calculate the distance to this intersecion using simple + -- trigonometry. + -- (Note, this is why we need at least three envelope calculations, + -- otherwise there wouldn't be any intersection between the bounding + -- planes) + upperBound = lowerBound / cos (pi / fromIntegral n) + + in (lowerBound, upperBound) + +renderPolarAxis + :: (TypeableFloat n, Renderable (Path V2 n) b) + => Axis b Polar n -> QDiagram b V2 n Any +renderPolarAxis a = frame 15 + $ leg + -- <> colourBar + -- <> circles + <> plots + <> theAxis + where + r = snd $ boundingRadiusR 30 styledPlots + spec = AxisSpec xs t (pure LinearAxis) (a ^. axisColourMap) + plots = foldMap (renderStyledPlot spec) styledPlots + + dataBB = fromCorners (mkP2 (-r) (-r)) (mkP2 r r) + (xs, tv, t') = calculateScaling (view _Wrapped $ a^.axes.column axisScaling) dataBB + t = tv <> t' + -- + theAxis = drawPolarAxis spec (a ^. axes) + -- + bb = fromCorners (P . apply t $ fmap fst xs) (P . apply t $ fmap snd xs) + leg = drawLegend bb (styledPlotLegends styledPlots) (a ^. legend) + -- + styledPlots = map (appEndo $ a ^. plotModifier) + $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) + +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) + r = spec ^. specBounds . _x . _2 + t = spec ^. specTrans + s = avgScale t + + rInRange x = x >= 0 && x <= r*1.000001 + thetaInRange x = x >= 0 && x < tau + + ---------------------------------------------------------------------- + -- Radial axis + ---------------------------------------------------------------------- + + -- The radial axis consists of an axis line from the centre to the + -- edge. The ticks and tickLabels are along this line. The grid lines + -- are made up of circles that pass through the line, centered at the + -- center of the plot. + rAx + | rA ^. hidden = mempty + | otherwise = rAxLine <> rAxLabel <> rAxTicks <> rAxTickLabels <> rAxGridLines + + rAxLine = line # whenever (rA ^. axisLine . hidden) phantom + where + -- XXX for now the radial axis is on the theta=0 line. Need some + -- way to change this + line = (origin ~~ mkP2 r 0) # applyStyle (rA^.axisLineStyle) + # transform t + + -- Radial axis label ------------------------------------------------- + + rAxLabel + | null rTxt || rA ^. axisLabel . hidden = mempty + | otherwise = view axisLabelTextFunction rA rLabelAlign rTxt + # translate rLabelPos + # applyStyle (rA ^. axisLabelStyle) + # fc black + + rLabelPos = V2 (s*x) (- view axisLabelGap rA) where + x = case rA ^. axisLabelPosition of + MiddleAxisLabel -> r/2 + LowerAxisLabel -> 0 + UpperAxisLabel -> r + rTxt = rA ^. axisLabelText + rLabelAlign = BaselineText + + -- Radial ticks ------------------------------------------------------ + + -- The positions of major and minor ticks along the radial axis + majorTickRs = view majorTicksFunction rA (0,r) + majorTickRs' = map (*s) $ filter rInRange majorTickRs + minorTickRs = view minorTicksFunction rA majorTickRs (0,r) + minorTickRs' = map (*s) $ filter rInRange minorTickRs + + -- Major and minor ticks are placed along the line at the calculated + -- positions majorTickRs + rAxTicks = rAxMajorTicks <> rAxMinorTicks + rAxMajorTicks + | rA ^. majorTicks . hidden = mempty + | otherwise = foldMap (\x -> rAxMajorTick # translateX x) majorTickRs' + # applyStyle (rA ^. majorTicksStyle) + rAxMinorTicks + | rA ^. minorTicks . hidden = mempty + | otherwise = foldMap (\x -> rAxMinorTick # translateX x) minorTickRs' + # applyStyle (rA ^. minorTicksStyle) + + -- The paths used for individual major and minor ticks + rAxMajorTick = someTick (rA ^. majorTicksAlignment) (rA ^. majorTicksLength) + rAxMinorTick = someTick (rA ^. minorTicksAlignment) (rA ^. minorTicksLength) + + someTick tType d = case tType of + TickSpec (fromRational -> aa) (fromRational -> bb) + -> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa) + AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d + + -- Radial grid lines ------------------------------------------------- + + rAxGridLines + -- - | rA ^. gridLines . hidden = mempty + | otherwise = rMajorGridLines <> rMinorGridLines + + majorGridRs = view majorGridLinesFunction rA majorTickRs (0,r) + majorGridRs' = map (*s) $ filter rInRange majorGridRs + + rMajorGridLines :: QDiagram b V2 n Any + rMajorGridLines + | rA ^. majorGridLines . hidden = mempty + | otherwise = foldMap circle (filter (>0) majorGridRs') + # applyStyle (rA ^. majorGridLinesStyle) + + minorGridRs = view minorGridLinesFunction rA minorTickRs (0,r) + minorGridRs' = map (*s) $ filter rInRange minorGridRs + rMinorGridLines :: QDiagram b V2 n Any + rMinorGridLines + | rA ^. minorGridLines . hidden = mempty + | otherwise = foldMap circle (filter (>0) minorGridRs') + # applyStyle (rA ^. minorGridLinesStyle) + + -- Radial tick labels ------------------------------------------------ + + rAxTickLabels :: QDiagram b V2 n Any + rAxTickLabels + | rA ^. tickLabel . hidden = mempty + | otherwise = foldMap rDrawTickLabel tickLabelRs + + -- The positions of the tick labels. + 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 :: (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)) + # applyStyle (rA ^. tickLabelStyle) + # fc black + + ---------------------------------------------------------------------- + -- Angular axis + ---------------------------------------------------------------------- + + -- The angular axis is a circular line around the perimieter of the + -- polar plot. The Ticks and tick labels are placed around this + -- perimeter. The Grid lines go from the perimeter to the center. + thetaAx + | thetaA ^. hidden = mempty + | otherwise = thetaAxLine <> thetaAxLabel + <> thetaAxTicks <> thetaAxTickLabels <> thetaAxGridLines + + theta = 2*pi + thetaAxLine = line # whenever (thetaA ^. axisLine . hidden) phantom + where + -- XXX for now the radial axis is on the theta=0 line. Need some + -- way to change this + line = circle (s*r) # applyStyle (thetaA^.axisLineStyle) + + -- Angular axis label ------------------------------------------------ + + -- Where should the label go? + thetaAxLabel + | null thetaTxt || thetaA ^. axisLabel . hidden = mempty + | otherwise = view axisLabelTextFunction thetaA thetaLabelAlign thetaTxt + # translate thetaLabelPos + # applyStyle (thetaA ^. axisLabelStyle) + # fc black + + -- thetaLabelPos = V2 (s*x) (- view axisLabelGap thetaA) where + thetaLabelPos = view xy_ (mkPolar (s*r + view axisLabelGap thetaA) x) where + -- The angle on the axis the label is placed, doesn't make much + -- sense right now. + x = case thetaA ^. axisLabelPosition of + MiddleAxisLabel -> quarterTurn + LowerAxisLabel -> zero + UpperAxisLabel -> halfTurn + thetaTxt = thetaA ^. axisLabelText + thetaLabelAlign = BaselineText + + -- Angular axis ticks ------------------------------------------------ + + -- The positions of major and minor ticks along the angular axis + majorTickThetas = view majorTicksFunction thetaA (0,theta) + majorTickThetas' = filter thetaInRange majorTickThetas + minorTickThetas = view minorTicksFunction thetaA majorTickThetas (0,theta) + minorTickThetas' = filter thetaInRange minorTickThetas + + -- Major and minor ticks are placed along perimeter, facing the center + -- of the axis. Ticks start of horizonal and are rotated to the + -- correct position on the axis. + thetaAxTicks = thetaAxMajorTicks <> thetaAxMinorTicks + thetaAxMajorTicks + | thetaA ^. majorTicks . hidden = mempty + | otherwise = foldMap (\phi -> thetaAxMajorTick # translateX (s*r) # rotate (phi@@rad)) majorTickThetas' + # applyStyle (thetaA ^. majorTicksStyle) + thetaAxMinorTicks + | thetaA ^. minorTicks . hidden = mempty + | otherwise = foldMap (\phi -> thetaAxMinorTick # translateX (s*r) # rotate (phi@@rad)) minorTickThetas' + # applyStyle (thetaA ^. minorTicksStyle) + + -- The paths used for individual major and minor ticks + thetaAxMajorTick = someThetaTick (thetaA ^. majorTicksAlignment) (thetaA ^. majorTicksLength) + thetaAxMinorTick = someThetaTick (thetaA ^. minorTicksAlignment) (thetaA ^. minorTicksLength) + + someThetaTick tType d = case tType of + TickSpec (fromRational -> aa) (fromRational -> bb) + -> mkP2 (-d*bb) 0 ~~ mkP2 (d*aa) 0 + AutoTick -> mkP2 (-d) 0 ~~ mkP2 d 0 + + -- Angular grid lines ------------------------------------------------ + + -- grid lines go from the centre of the axis to the perimeter + thetaAxGridLines + -- - | thetaA ^. girdLines . hidden = mempty + | otherwise = thetaMajorGridLines <> thetaMinorGridLines + + majorGridThetas = view majorGridLinesFunction thetaA majorTickThetas (0,theta) + majorGridThetas' = filter thetaInRange majorGridThetas + + thetaMajorGridLines :: QDiagram b V2 n Any + thetaMajorGridLines + | thetaA ^. majorGridLines . hidden = mempty + | otherwise = 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 :: QDiagram b V2 n Any + thetaMinorGridLines + | thetaA ^. minorGridLines . hidden = mempty + | otherwise = foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) minorGridThetas' + # transform t + # applyStyle (thetaA ^. minorGridLinesStyle) + + -- Angular tick labels ----------------------------------------------- + + thetaAxTickLabels :: QDiagram b V2 n Any + thetaAxTickLabels + | thetaA ^. tickLabel . hidden = mempty + | otherwise = foldMap thetaDrawTickLabel tickLabelThetas + + -- The positions of the tick labels. + tickLabelThetas :: [(n, String)] + tickLabelThetas = view tickLabelFunction thetaA majorTickThetas' (0,theta) + + -- Draw a single tick label given the position and the string to use + thetaDrawTickLabel :: (n, String) -> QDiagram b V2 n Any + thetaDrawTickLabel (x,label) = + view tickLabelTextFunction thetaA a label + # translate v + # applyStyle (thetaA ^. tickLabelStyle) + # fc black + where v = mkPolar (s*r + view axisLabelGap thetaA) (x@@rad) ^. xy_ + -- a = BoxAlignedText (0.5-cos x/2) (0.5-sin x/2) + a = BoxAlignedText 0.5 0.5 + + -- line + -- | a ^. axisLine . hidden = mempty + -- | otherwise = foldMap mkline (map snd ys) -- merge with ticks? + -- # transform t + -- # stroke + -- -- # applyStyle (a ^. axisLine e . axisArrowOpts . _Just . shaftStyle) + -- # lineCap LineCapSquare + -- where + -- -- TODO: Arrow for R3 + -- mkline y = pathFromVertices + -- $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v n diff --git a/src/Plots/Axis/Scale.hs b/src/Plots/Axis/Scale.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Scale.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Scale +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Determine how to scale an axis. +-- +---------------------------------------------------------------------------- + +module Plots.Axis.Scale + ( -- * Axis scale + AxisScaling + , ScaleMode (..) + , UniformScaleStrategy (..) + , Extending (..) + , noExtend + , HasAxisScaling (..) + + -- ** Log scales + , LogScale (..) + , logNumber + , logPoint + , logDeform + + -- * Low level calculations + -- | These functions are used by "Plots.Axis.Render". + , calculateBounds + , calculateScaling + + ) where + +import Control.Applicative +import Control.Lens +import Data.Bool +import Data.Default +import Data.Distributive +import Data.Maybe + +import Diagrams +import Linear + +------------------------------------------------------------------------ +-- Axis scale +------------------------------------------------------------------------ + +-- | How the axis should be scaled when not all dimensions are set. +data ScaleMode + = AutoScale + | NoScale + | Stretch + | UniformScale UniformScaleStrategy + deriving (Show, Read) + +-- | ? +data UniformScaleStrategy + = AutoUniformScale + | UnitOnly + | ChangeVerticalLimits + | ChangeHorizontalLimits + deriving (Show, Read) + +-- | Data type used that concerns everything to do with the size or +-- scale of the axis. +data AxisScaling n = Scaling + { asRatio :: Maybe n + , asMode :: ScaleMode + , 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 :: n + , asBackupBoundMin :: n + } + +type instance N (AxisScaling n) = n + +instance Fractional n => Default (AxisScaling n) where + def = Scaling + { asRatio = Nothing + , asMode = AutoScale + , asEnlarge = RelativeExtend 0.1 + , asBoundMin = Nothing + , asBoundMax = Nothing + , asLogScale = def + , asSize = Just 400 + , asBackupBoundMax = 5 + , asBackupBoundMin = -5 + } + +-- | How much to extend the bounds beyond any inferred bounds. +data Extending n + = AbsoluteExtend n + | RelativeExtend n + deriving (Show, Ord, Eq, Functor) + +-- | Do not extend the axis beyond the inferred bounds. +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 (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 (N a)) + scaleAspectRatio = axisScaling . lens asRatio (\as r -> as {asRatio = r}) + + -- | The mode to determine how to scale the bounds in a direction. + -- Choose between 'AutoScale', 'NoScale', 'Stretch' or + -- 'UniformScale'. + -- + -- 'Default' is 'AutoScale'. + scaleMode :: Functor f => LensLike' f a ScaleMode + scaleMode = axisScaling . lens asMode (\as r -> as {asMode = r}) + + -- | Whether the axis uses 'LogAxis' or 'LinearAxis'. + -- + -- 'Default' is 'LinearAxis'. + logScale :: Functor f => LensLike' f a LogScale + logScale = axisScaling . lens asLogScale (\as r -> as {asLogScale = r}) + + -- | 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 (N a)) + axisExtend = axisScaling . lens asEnlarge (\as r -> as {asEnlarge = r}) + + -- | The maximum bound the axis. There are helper functions for + -- setting a minimum bound for a specific axis. + -- + -- @ + -- 'Plots.Axis.xMin' :: 'Lens'' ('Axis' b 'V2' 'Double') ('Maybe' 'Double') + -- 'Plots.Axis.yMin' :: 'Lens'' ('Axis' b 'V2' 'Double') ('Maybe' 'Double') + -- @ + -- + -- Default is 'Nothing'. + 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 + -- setting a maximum bound specific axis. + -- + -- @ + -- 'Plots.Axis.xMax' :: 'Lens'' ('Axis' b 'V2' 'Double') ('Maybe' 'Double') + -- 'Plots.Axis.yMax' :: 'Lens'' ('Axis' b 'V2' 'Double') ('Maybe' 'Double') + -- 'Plots.Axis.rMax' :: 'Lens'' ('Axis' b 'Polar 'Double') ('Maybe' 'Double') + -- @ + -- + -- Default is 'Nothing'. + 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 (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, Num n, Ord n) => Lens' (v (AxisScaling n)) (SizeSpec v n) +asSizeSpec = column renderSize . iso mkSizeSpec getSpec + +instance HasAxisScaling f (AxisScaling n) where + axisScaling = id + +-- calculating bounds -------------------------------------------------- + +-- | Calculating the bounds for an axis. +calculateBounds + :: 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) + & whenever (asLogScale == LogAxis) (max 1e-6) + u' = u & whenever (isNothing asBoundMax) (+ x) + + -- amount to enlarge axis by + x = case asEnlarge of + AbsoluteExtend a -> a + RelativeExtend a -> (u - l) * a + + -- pre-enlarged bounds are looked at in the following order: + -- - concrete bounds from max/boundMin + -- - inferred bounds from plot envelopes + -- - backup bounds + l = fromMaybe asBackupBoundMin $ asBoundMin <|> lI + u = fromMaybe asBackupBoundMax $ asBoundMax <|> uI + lI = preview (folded . _1) mInferred + uI = preview (folded . _2) mInferred + +-- | Calculate the scaling for the axis. +-- +-- The result returns: +-- +-- - The final bounds for the axis +-- - scale to match desired 'scaleAspectRatio' +-- - scale to match desired 'asSizeSpec' +calculateScaling + :: (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 + bounds = calculateBounds <$> aScaling <*> distribute inferred + inferred = view _Point . uncurry (liftA2 (,)) <$> getCorners bb + + -- the scaling used to meet the desired aspect ratio + aspectScaling + -- If any of the aspect ratios are committed we use the aspect ratio from + -- aScaling. Otherwise no ratios are set, ignore them and scale + -- such that each axis is the same length + | anyOf (folded . scaleAspectRatio) isJust aScaling + = vectorScaling $ view (scaleAspectRatio . non 1) <$> aScaling + | otherwise = inv $ vectorScaling v + + -- scaling used so the axis fits in the size spec + sizeScaling = requiredScaling szSpec v' + -- the vector that points from the lower bound to the upper bound of the + -- axis + v = uncurry (flip (-)) <$> bounds + 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 + +-- Logarithmic scaling ------------------------------------------------- + +-- Logarithmic scales are achieved by having 'LinearAxis' or 'LogAxis' +-- for each of the axes. When rendering the plots, they have axes the +-- log scheme. Some plots (like scatter) can easily do this whereas +-- others (like diagram plot) it's nearly impossible for, so they don't +-- bother. +-- +-- Support for Log axis still needs a lot of work and debugging. + +-- | Should the axis be on a logarithmic scale. The 'Default' is +-- 'LinearAxis'. +data LogScale = LinearAxis | LogAxis + deriving (Show, Eq) + +instance Default LogScale where + def = LinearAxis + +-- | Log the number for 'LogAxis', do nothing for 'LinearAxis'. +logNumber :: Floating a => LogScale -> a -> a +logNumber LinearAxis = id +logNumber LogAxis = log +{-# INLINE logNumber #-} + +-- | Transform a point according to the axis scale. Does nothing for +-- linear scales. +logPoint :: (Additive v, Floating n) => v LogScale -> Point v n -> Point v n +logPoint v = _Point %~ liftI2 logNumber v +{-# INLINE logPoint #-} + +-- | Deform an object according to the axis scale. Does nothing for +-- linear scales. +logDeform :: (InSpace v n a, 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 new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Ticks.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Ticks +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- Ticks for being placed on an axis or a 'ColourBar'. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Ticks + ( -- * Major ticks + MajorTicks + , HasMajorTicks (..) + , majorTicksHelper + , logMajorTicks + + -- * Minor ticks + , MinorTicks + , HasMinorTicks (..) + , minorTicksHelper + + -- * Both major and minor ticks + , Ticks + , HasTicks (..) + , ticksAlign + , ticksStyle + , ticksVisible + + -- * Tick alignment + , TicksAlignment (..) + , autoTicks + , centreTicks + , centerTicks + , insideTicks + , outsideTicks + + -- * Helper functions + , hideTicks + , majorTickPositions + , minorTickPositions + , linearMajorTicks + ) where + +import Control.Lens hiding (transform, ( # )) +import Data.Data +import Data.Default +import Data.Foldable as F +import Data.Ord +import Plots.Types +import Plots.Util + +import Diagrams.Prelude + +------------------------------------------------------------------------ +-- Types +------------------------------------------------------------------------ + +-- Tick alignment ------------------------------------------------------ + +-- | Set the portion of the tick above and below the axis. +data TicksAlignment + = TickSpec !Rational !Rational + | AutoTick -- center tick for middle axis, outside tick otherwise + deriving (Show, Eq) + +-- | Set the tick type depending on the axis line position. 'centreTick' +-- for 'middleAxis', 'insideTick' for everything else. +autoTicks :: TicksAlignment +autoTicks = AutoTick + +-- | Set the tick to be in the centre of the axis with total length of +-- the corresponding tick length. +centreTicks :: TicksAlignment +centreTicks = TickSpec 0.5 0.5 + +-- | Synonym for 'centreTicks'. +centerTicks :: TicksAlignment +centerTicks = centreTicks + +-- | Align the ticks to be inside a box axis. +insideTicks :: TicksAlignment +insideTicks = TickSpec 0 1 + +-- | Align the ticks to be outside a box axis. +outsideTicks :: TicksAlignment +outsideTicks = TickSpec 1 0 + +-- -- | Do not show any ticks. +-- noTicks :: TicksAlignment +-- noTicks = NoTick + +------------------------------------------------------------------------ +-- Minor ticks +------------------------------------------------------------------------ + +-- | The big ticks on the axis line. +data MajorTicks v n = MajorTicks + { matFunction :: (n,n) -> [n] + , matAlign :: TicksAlignment + , matLength :: n + , matStyle :: Style v n + , matVisible :: Bool + } + +instance TypeableFloat n => Default (MajorTicks v n) where + def = MajorTicks + { matFunction = linearMajorTicks 5 + , matAlign = autoTicks + , matLength = 5 + , matStyle = mempty # lwO 0.4 + , matVisible = True + } + +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) (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 ((N a, N a) -> [N a]) + majorTicksFunction = majorTicks . lens matFunction (\mat a -> mat {matFunction = a}) + + -- | Alignment of the major ticks. Choose between 'autoTicks' + -- (default), 'centreTicks', 'insideTicks' or 'outsideTicks'. + majorTicksAlignment :: Functor f => LensLike' f a TicksAlignment + majorTicksAlignment = majorTicks . lens matAlign (\mat a -> mat {matAlign = a}) + + -- | The total length the major ticks. + -- + -- Default is @7@. + 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) (N a)) + majorTicksStyle = majorTicks . lens matStyle (\mat sty -> mat {matStyle = sty}) + +instance HasMajorTicks f (MajorTicks v n) where + majorTicks = id + +instance HasVisibility (MajorTicks v n) where + visible = lens matVisible (\mat b -> mat {matVisible = b}) + +------------------------------------------------------------------------ +-- Minor ticks +------------------------------------------------------------------------ + +-- | The small ticks on the axis line. +data MinorTicks v n = MinorTicks + { mitFunction :: [n] -> (n,n) -> [n] + , mitAlign :: TicksAlignment + , mitLength :: n + , mitStyle :: Style v n + , mitVisible :: Bool + } + +type instance V (MinorTicks v n) = v +type instance N (MinorTicks v n) = n + +instance TypeableFloat n => Default (MinorTicks v n) where + def = MinorTicks + { mitFunction = minorTicksHelper 4 + , mitAlign = autoTicks + , mitLength = 3 + , mitStyle = mempty # lwO 0.4 + , mitVisible = True + } + +-- | 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) (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 ([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' + -- (default), 'centreTicks', 'insideTicks' or 'outsideTicks'. + minorTicksAlignment :: Functor f => LensLike' f a TicksAlignment + minorTicksAlignment = minorTicks . lens mitAlign (\mit a -> mit {mitAlign = a}) + + -- | The total length the minor ticks. + -- + -- Default is @3@. + 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) (N a)) + minorTicksStyle = minorTicks . lens mitStyle (\mit sty -> mit {mitStyle = sty}) + +instance HasMinorTicks f (MinorTicks v n) where + minorTicks = id + +instance HasVisibility (MinorTicks v n) where + visible = lens mitVisible (\mit sty -> mit {mitVisible = sty}) + +------------------------------------------------------------------------ +-- Both ticks +------------------------------------------------------------------------ + +-- | Both 'MajorTicks' and 'MinorTicks' together. +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 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) (N a)) + +instance Functor f => HasTicks f (Ticks v n) where + bothTicks = id + +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 n) where + minorTicks f (Ticks ma mi) = f mi <&> \mi' -> Ticks ma mi' + +instance TypeableFloat n => Default (Ticks v n) where + def = Ticks def def + +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 +ticksAlign = bothTicks . aligns + where + aligns f a = (\m mn -> a & majorTicksAlignment .~ m & minorTicksAlignment .~ mn) + <$> 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) (N a)) +ticksStyle = bothTicks . styles + where + styles f a = (\m mn -> a & majorTicksStyle .~ m & minorTicksStyle .~ mn) + <$> f (a ^. majorTicksStyle) <*> f (a ^. minorTicksStyle) + +-- | Traversal over the visibility of both major and minor ticks. +ticksVisible :: (HasTicks f a, Applicative f) => LensLike' f a Bool +ticksVisible = bothTicks . visibles + where + visibles f a = (\m mn -> a & majorTicks . visible .~ m & minorTicks. visible .~ mn) + <$> f (a ^. majorTicks . visible) <*> f (a ^. minorTicks . visible) + +-- | Hides the 'Minor' ticks when trying to render something. This can +-- be used on multiple types: +-- +-- @ +-- 'hideTicks' :: 'Axis' b c n -> 'Axis' b c n +-- 'hideTicks' :: 'SingleAxis' b v n -> 'SingleAxis' b v n +-- 'hideTicks' :: 'Ticks' v n -> 'Ticks' v n +-- 'hideTicks' :: 'MinorTicks' v n -> 'MinorTicks' v n +-- @ +hideTicks :: HasTicks Identity a => a -> a +hideTicks = ticksVisible .~ False + +-- | Setter over the final positions the major ticks. This is not as +-- general as 'majorTicksFunction' because you don't have access to +-- the bounds but it can be useful when you know exactly what ticks +-- you want to add or modify existing tick positions. +majorTickPositions + :: (HasMajorTicks f a, Settable f) + => LensLike' f a [N a] +majorTickPositions = majorTicksFunction . mapped + +-- | Setter over the final positions the major ticks. This is not as +-- general as 'minorTicksFunction' because you don't have access to +-- the bounds but it can be useful when you know exactly what ticks +-- you want to add or modify existing tick positions. +minorTickPositions + :: (HasMinorTicks f a, Settable f) + => LensLike' f a [N a] +minorTickPositions = minorTicksFunction . mapped . mapped + +------------------------------------------------------------------------ +-- Calculating ticks +------------------------------------------------------------------------ + +-- Linear ticks -------------------------------------------------------- + +-- | Ticks whose value ends in 1, 0.5, 0.25, 0.2 (*10^n). +linearMajorTicks :: (RealFrac n, Floating n) => n -> (n, n) -> [n] +linearMajorTicks = majorTicksHelper [1, 0.5, 0.25, 0.2, 0.3] + +-- Logarithmic ticks --------------------------------------------------- + +-- | Place n ticks at powers of 10 on the axis. +logMajorTicks :: (RealFrac n, Floating n) => n -> (n, n) -> [n] +logMajorTicks n (a,b) = + -- Logarithmic ticks are just like linear ticks but in a different domain. + map (10**) $ majorTicksHelper ts n (log10 (max 2 a), log10 b) + where ts = [1,2,3,4,5,6,7,8,9] + +-- Ticks helpers ------------------------------------------------------- + +-- | Place n linear spaced ticks between each major tick. +minorTicksHelper + :: Fractional n + => Int -- ^ Number of minor ticks between each major tick + -> [n] -- ^ Positions of major ticks + -> (n, n) -- ^ Bounds + -> [n] -- ^ Minor tick positions +minorTicksHelper n ts _ = F.concat $ go ts where + -- we won't want x1 and x2 to be minor ticks too we init/tail them. + go (x1:x2:xs) = (init . tail) (enumFromToN x1 x2 (n+2)) : go (x2:xs) + go _ = [] + +-- | Choose ticks whose step size is a multiple of 10 of the allowed +-- numbers and tries to match the number of desired ticks. +-- +-- Note that the resulting tick positions may go out of the range of +-- the bounds. This is so the minor ticks can be chosen correctly if a +-- tick doesn't end exactly on a bound. When we render, we ignore all +-- ticks outside the bounds. +majorTicksHelper + :: (RealFrac n, Floating n) + => [n] -- ^ Allowed numbers (up to powers of 10) + -> n -- ^ desired number of ticks + -> (n, n) -- ^ bounds + -> [n] -- ^ tick positions +majorTicksHelper ts0 n (a,b) = iterateN n' (+h) a' + where + i = fromIntegral (floor ( a / h ) :: Int) + + a' = i*h + n' = ceiling ((b - a')/h) + 1 + + -- Find the a value from our potential ticks that's closest to our + -- ideal height. + h = minimumBy (comparing $ abs . (h' -)) ts' + + -- Ideal height for the desired number of ticks. + h' = d / n + + -- Potential step heights that look nice and are in a suitable range + -- for the axis bounds. + ts' = map (* 10 ^^ (floor $ log10 d :: Int)) (ts0 ++ map (*10) ts0) + d = abs $ b - a + +-- logged :: Floating a => Iso' a a +-- logged = iso log10 (10**) + +log10 :: Floating a => a -> a +log10 = logBase 10 diff --git a/src/Plots/Axis/Title.hs b/src/Plots/Axis/Title.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Axis/Title.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Axis.Title +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- The title used for a plot. +-- +---------------------------------------------------------------------------- +module Plots.Axis.Title + ( Title + , HasTitle (..) + , drawTitle + ) where + +import Data.Default +import Data.Typeable + +import Diagrams.Prelude +import Diagrams.TwoD.Text +import Plots.Types + +data Title b v n = Title + { tVisible :: Bool + , tTxt :: String + , tTxtFun :: TextAlignment n -> String -> QDiagram b v n Any + , tStyle :: Style v n + , tPlacement :: Placement + , tGap :: n + } deriving Typeable + +instance (Renderable (Text n) b, TypeableFloat n) + => Default (Title b V2 n) where + def = Title + { tVisible = True + , tTxt = "" + , tTxtFun = mkText + , tStyle = mempty # fontSize (output 11) + , tPlacement = midAbove + , tGap = 20 + } + +type instance V (Title b v n) = v +type instance N (Title b v n) = n + +instance HasVisibility (Title b v n) where + visible = lens tVisible (\t b -> t {tVisible = b}) + +instance HasGap (Title b v n) where + gap = lens tGap (\t g -> t {tGap = g}) + +instance HasPlacement (Title b v n) where + placement = titlePlacement + +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. + -- + -- Default is @""@ + titleText :: Lens' a String + titleText = title . lens tTxt (\t s -> t {tTxt = s}) + + -- | The style applied to the title. + -- + -- Default is 'mempty'. + 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. + -- + -- Default is 'mempty'. + titlePlacement :: Lens' a Placement + titlePlacement = title . lens tPlacement (\t s -> t {tPlacement = s}) + + -- | The gap between the axis and the title. + -- + -- Default is 'mempty'. + titleGap :: Lens' a (N a) + titleGap = title . lens tGap (\t s -> t {tGap = s}) + +instance HasTitle (Title b v n) b where + title = id + +-- | Render the title and place it around the bounding box. +drawTitle + :: 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 + bb + (t ^. titlePlacement) + (t ^. titleGap) + tDia + where + tDia = tTxtFun t (BoxAlignedText 0.5 0) (tTxt t) + # applyStyle (tStyle t) + diff --git a/src/Plots/Legend.hs b/src/Plots/Legend.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Legend.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Plots.Legend + ( + -- * Legend + Legend + , HasLegend (..) + + -- * Drawing a legend + , drawLegend + + ) where + +import Control.Lens hiding (none, ( # )) +import Data.Default +import Data.Typeable +import Diagrams.TwoD.Text + +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 b n = Legend + { lPlacement :: Placement + , 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 b n) = V2 +type instance N (Legend b n) = n + +class HasLegend a b | a -> b where + -- | Lens onto the 'Legend' of something. + 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 (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 (N a)) + legendStyle = legend . lens lStyle (\l a -> l {lStyle = a}) + + -- | The spacing between entries in the legend. + 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 (N a) + legendTextWidth = legend . lens lTextWidth (\l a -> l {lTextWidth = a}) + + -- | The function to generate the legend text. + 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 (N a)) + legendTextStyle = legend . lens lTextStyle (\l a -> l {lTextStyle = a}) + + -- | The way the legend entries are listed. (This will likely be + -- replaced by a grid-like system) + legendOrientation :: Lens' a Orientation + legendOrientation = legend . lens lOrientation (\l a -> l {lOrientation = a}) + +instance HasLegend (Legend b n) b where + legend = id + +instance HasGap (Legend b n) where + gap = legendGap + +instance HasPlacement (Legend b n) where + placement = legendPlacement + +instance (TypeableFloat n, Renderable (Text n) b) => Default (Legend b n) where + def = Legend + { lPlacement = rightTop + , lGap = 20 + , lSpacing = 20 + , lTextWidth = 60 + , lStyle = mempty + , lTextF = mkText (BoxAlignedText 0 0.5) + , lTextStyle = mempty & fontSize (output 11) + , lOrientation = Vertical + , lVisible = True + } + +instance HasVisibility (Legend b n) where + visible = lens lVisible (\l a -> l {lVisible = a}) + +instance TypeableFloat n => HasStyle (Legend b n) where + applyStyle sty = over legendStyle (applyStyle sty) + +instance HasOrientation (Legend b n) where + orientation = legendOrientation + +-- | Draw a legend to the bounding box using the legend entries and +-- legend options. +drawLegend + :: (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 + bb + (l ^. legendPlacement) + (l ^. legendGap) + (ledge <> back) + where + w = l ^. legendTextWidth + h = l ^. legendSpacing + -- + ledge = map mkLabels entries + # orient (l ^. legendOrientation) hcat vcat + # alignTL + + back = rect (w + h + 5) (h * fromIntegral (length entries)) + # fcA transparent + # applyStyle (l ^. legendStyle) + # alignTL + # translate (V2 (-5) 0) -- (-3)) + + -- mkLabels :: (QDiagram b V2 n Any, String) -> QDiagram b V2 n Any + mkLabels (pic, txt) = pic' ||| strutX 5 ||| label where + pic' = pic # withEnvelope (fromCorners (pure (-h/2)) (pure (h/2))) + label = view legendTextFunction l txt + # applyStyle (l ^. legendTextStyle) + # withEnvelope (fromCorners origin (mkP2 w h) # moveTo (mkP2 0 (-h/2))) + +-- wrapPic :: RealFloat n => V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +-- wrapPic ((^/ 2) -> v) d +-- = d # sizedAs (fromCorners (origin .-^ v) (origin .+^ v)) diff --git a/src/Plots/Name.hs b/src/Plots/Name.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Name.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Plots.Name where + +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 n = PlotName + { _plotName :: String + , _namedSize2D :: SizeSpec V2 n + , _namedT2 :: T2 n + } deriving Typeable + +makeLenses ''PlotName + +instance Show (PlotName n) where + show pn = "Plot: " ++ view plotName pn + +-- equating :: Eq b => (a -> b) -> a -> a -> Bool +-- equating = on (==) + +instance Eq (PlotName n) where + (==) = on (==) (view plotName) + +instance Ord (PlotName n) where + compare = comparing (view plotName) + +instance Typeable n => IsName (PlotName n) + +-- _AName :: IsName a => Prism' AName a +-- _AName = prism' AName (\(AName a) -> cast a) + +-- _Names :: IsName a => Traversal' Name a +-- _Names = _Wrapped' . traverse . _AName + +-- _NamedString :: Traversal' Name String +-- _NamedString = _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') + diff --git a/src/Plots/Style.hs b/src/Plots/Style.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Style.hs @@ -0,0 +1,1104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Style +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines the 'AxisStyle' type along with different colour +-- schemes. 'AxisStyle's are used to provide default colours and shapes +-- for the plots of an axis. +-- +---------------------------------------------------------------------------- + +module Plots.Style + ( -- * The axis style + AxisStyle + , HasAxisStyle (..) + -- , axisStyles + + -- ** Predefined styles + , fadedColours + , vividColours + , blackAndWhite + + -- * Plot Style + , PlotStyle + , HasPlotStyle (..) + + -- ** Applying Plot styles + , applyLineStyle + , applyMarkerStyle + , applyAreaStyle + , applyTextStyle + + -- * Colour schemes + , colours1 + , colours2 + + -- * Marker shapes + , asterisk + , diamond + , crossShape + , star' + , plus + , lineMarkers + + -- * Colour maps + , ColourMap + , ixColour + , cmTraverse + , colourMap + , alphaColourMap + , colourList + , toStops + + -- ** Sample maps + , viridis + , magma + , inferno + , plasma + , greys + + ) where + +-- import Control.Lens hiding (transform, ( # ), at, none) +import qualified Control.Lens as Lens +import Data.Colour.SRGB +import qualified Data.Map as M +import Data.Typeable +import Diagrams.Prelude hiding (magma) +import Linear + +-- | 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. +-- +-- You can either change the list of plot styles used with +-- 'axisStyle': +-- +-- @ +-- stylishAxis = r2Axis &~ do +-- axisStyle .= vividColours +-- linePlot [(1,2) (3,4)] $ key "line 1" +-- linePlot [(1,1) (4,2)] $ key "line 2" +-- @ +-- +-- change the style for individual plots when changing the plot state. +-- +-- @ +-- stylishAxis2 = r2Axis &~ do +-- linePlot [(1,2) (3,4)] $ do +-- key "line 1" +-- plotColour .= green +-- linePlot [(1,1) (4,2)] $ do +-- key "line 2" +-- plotColour .= orange +-- @ +-- +-- A plot style is made up of separate styles ('lineStyle', +-- 'markerStyle', 'areaStyle' and 'textStyle') a 'plotColour' and a +-- 'plotMarker'. When rendering a plot, the 'PlotStyle's in an +-- 'AxisStyle' are used to style each plot. The lenses can be used to +-- customise each style when adding the plot. +-- +-- * 'plotColour' - the underlying colour of the plot +-- * 'lineStyle' - style used for lines ('linePlot', 'connectingLine' +-- in a 'scatterPlot') +-- * 'areaStyle' - style used for any area ('barPlot', 'piePlot', +-- 'histogramPlot') +-- * 'markerStyle' - style used for markers in 'scatterPlot' +-- * 'plotMarker' - marker used in 'scatterPlot' +data PlotStyle b v n = PlotStyle + { _plotColour :: Colour Double + , _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 b v n) = v +type instance N (PlotStyle b v n) = n + +-- | Class for objects that contain a 'PlotStyle'. +class HasPlotStyle f a b | a -> b where + -- | Lens onto the 'PlotStyle'. + 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 + -- overall colour for the plot. + plotColour :: Functor f => LensLike' f a (Colour Double) + plotColour = plotStyle . lens _plotColour (\p f -> p {_plotColour = f}) + + -- | Alias for 'plotColour'. + plotColor :: Functor f => LensLike' f a (Colour Double) + plotColor = plotColour + + -- | 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) (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) (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) (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) (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) (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) (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) (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) (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 (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) (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) (N a)) + plotStyleFunctions = plotStyle . t + where + t f PlotStyle {..} = PlotStyle + <$> pure _plotColour + <*> f _lineStyle + <*> f _markerStyle + <*> f _areaStyle + <*> f _textStyle + <*> pure _plotMarker + +instance HasPlotStyle f (PlotStyle b v n) b where + plotStyle = id + +-- Applying styles ----------------------------------------------------- + +-- | Apply the 'lineStyle' from a 'PlotStyle'. +-- +-- @ +-- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t +-- @ +applyLineStyle + :: (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 b v n -> t -> t +-- @ +applyMarkerStyle + :: (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 b v n -> t -> t +-- @ +applyAreaStyle + :: (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 b v n -> t -> t +-- @ +applyTextStyle + :: (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, OrderedField n) => Transformable (PlotStyle b v n) where + transform t = (plotMarker %~ transform t) . (plotStyles %~ transform t) + +------------------------------------------------------------------------ +-- Axis Style +------------------------------------------------------------------------ + +-- | The 'AxisStyle' determines the 'Style's of the plots in an axis. +-- There are various predifined styles to change the look of the plot. +data AxisStyle b v n = AxisStyle ColourMap [PlotStyle b v n] + +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 b | a -> b where + -- | Lens onto the 'AxisStyle'. + 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'. + axisColourMap :: Lens' a ColourMap + axisColourMap = axisStyle . cm + where cm f (AxisStyle c ss) = f c <&> \c' -> AxisStyle c' ss + + -- | 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 b (V a) (N a)) + axisStyles = axisStyle . stys . traversed + where stys f (AxisStyle c ss) = f ss <&> \ss' -> AxisStyle c ss' + +instance HasAxisStyle (AxisStyle b v n) b where + axisStyle = id + +instance Applicative f => HasPlotStyle f (AxisStyle b v n) b where + plotStyle = axisStyles + +------------------------------------------------------------------------ +-- Predefined themes +------------------------------------------------------------------------ + +-- $predefined +-- There are only a few themes for now. Eventually there will be a wider +-- range of themes with better support for customisation. + +-- code to display axis styles +-- > import Plots +-- > showcase :: AxisStyle B V2 Double -> Diagram B +-- > showcase sty = hsep 0.4 . take 8 $ map drawSty stys +-- > where +-- > stys = sty ^.. axisStyles +-- > drawSty s = applyMarkerStyle s (s^.plotMarker) <> applyLineStyle s lineBehind +-- > lineBehind = (p2 (-1,0) ~~ p2 (1,0)) +-- +-- > fadedColourPic = showcase fadedColours +-- > vividColourPic = showcase vividColours +-- > blackAndWhitePic = showcase blackAndWhite + +-- | Theme using 'funColours' with faded fills and thick lines. +-- +-- <> +fadedColours :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n +fadedColours = AxisStyle viridis $ + zipWith mkStyle (cycle colours1) (cycle $ map stroke filledMarkers) + where + mkStyle c = PlotStyle c lineS fadeS fadeS fillS + lineS c = mempty # lc c # lwO 3 -- normal + fadeS c = mempty # fc (blend 0.1 white c) # lc c # lwO 1 + fillS c = mempty # fc c # lw none + +-- | Theme using 'funColours' with no lines on 'areaStyle. +-- +-- <> +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 + mkStyle c = PlotStyle c lineS markS fillS fillS + lineS c = mempty # lc c # lwO 3 -- normal + markS c = mempty # fc c # lwO 1 # lc white + fillS c = mempty # fc c # lw none + +-- | Theme without any colours, useful for black and white documents. +-- +-- <> +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 + mkStyle c ls = PlotStyle c ls markerS (mk fc) (mk fc) + mk f c = mempty # f c + -- + markerS c = mempty # fc white # lc c + lineStyles = mempty : map (\ds -> mempty # dashingL ds 0) dashes + dashes = [[6,6], [6,2], [2,2], [6,8,3]] + colours = [black, blend 0.8 black white, blend 0.6 black white, blend 0.4 black white] + +------------------------------------------------------------------------ +-- Colours +------------------------------------------------------------------------ + +-- Unimaginative names :( + +-- | A colourful colour set used for 'fadedColours'. +colours1 :: OrderedField n => [Colour n] +colours1 = cycle + [ sRGB24 228 26 28 + , sRGB24 55 126 184 + , sRGB24 77 175 74 + , sRGB24 152 78 163 + , sRGB24 255 127 0 + , sRGB24 166 86 40 + , sRGB24 247 129 191 + , sRGB24 153 153 153 + ] + +-- | Another colour set, used for 'vividColours'. +colours2 :: OrderedField n => [Colour n] +colours2 = cycle + [ sRGB24 27 158 119 + , sRGB24 217 95 2 + , sRGB24 117 112 179 + , sRGB24 231 41 138 + , sRGB24 102 166 30 + , sRGB24 230 171 2 + , sRGB24 166 118 29 + , sRGB24 102 102 102 + ] + +-- | Markers which have a filling, used for 'fadedColours' and +-- 'vividColours'. +filledMarkers :: RealFloat n => [Path V2 n] +filledMarkers = scale 11 . map (centerXY . pathFromTrail) $ cycle + [ circle 0.5 + , square 1 + , triangle 1 + , diamond (1 / sqrt 2) + , pentagon 0.6 + , crossShape 1 + , plus 1 + , star' 0.8 + ] + +-- | 'asterisk' markers with varying numbers of prongs. +lineMarkers :: OrderedField n => [Path V2 n] +lineMarkers = scale 11 $ cycle + [ asterisk 4 1 # rotateBy (1/8) + , asterisk 6 1 + , asterisk 5 1 + , asterisk 2 1 + , asterisk 2 1 # rotateBy (1/4) + , asterisk 10 1 + , asterisk 3 1 + , asterisk 3 1 # rotateBy (1/2) + ] + +------------------------------------------------------------------------ +-- Shapes +------------------------------------------------------------------------ + +-- | Make an asterisk with @n@ spokes, each of length @l@. +asterisk :: OrderedField n => Int -> n -> Path V2 n +asterisk n x + = mconcat . take n + . iterate (rotateBy (1/fromIntegral n)) + $ (0 ^& 0) ~~ (0 ^& x) + +-- | A rotated 'square'. +diamond :: (InSpace V2 n t, TrailLike t) => n -> t +diamond = trailLike . rotateBy (1/8) . square + +-- | A rotated 'plus'. +crossShape :: (InSpace V2 n t, TrailLike t) => n -> t +crossShape = trailLike . rotateBy (1/8) . plus + +-- | Filled in @+@ symbol. +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, 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)] + +------------------------------------------------------------------------ +-- Colour maps +------------------------------------------------------------------------ + +-- type ColourMap = [(Double, AlphaColour Double)] + +-- | A map from a number (usually between 0 and 1) to a colour. Colour +-- maps are part of the 'AxisStyle', which is used for plots like +-- 'Plots.Types.HeatMap'. +newtype ColourMap = ColourMap (M.Map Rational (AlphaColour Double)) + deriving Show + + +type instance V ColourMap = V1 +type instance N ColourMap = Rational + +-- makeWrapped ''ColourMap +-- manually write instance to avoid template haskell splitting the +-- module up +instance Rewrapped ColourMap ColourMap +instance Wrapped ColourMap where + type Unwrapped ColourMap = M.Map Rational (AlphaColour Double) + _Wrapped' = iso (\(ColourMap a) -> a) ColourMap + {-# INLINE _Wrapped' #-} + +p1apply :: Num a => Transformation V1 a -> a -> a +p1apply t a = papply t (P (V1 a)) ^. _x + +instance Transformable ColourMap where + transform t = over (_Wrapped' . _Wrapped' . mapped . _1) (p1apply t) + +type instance Index ColourMap = Rational +type instance IxValue ColourMap = AlphaColour Double + +instance AsEmpty ColourMap where + _Empty = nearly (ColourMap M.empty) (allOf each (==transparent)) + +instance Each ColourMap ColourMap (AlphaColour Double) (AlphaColour Double) where + each = _Wrapped' . each + +instance Ixed ColourMap where + ix = ixColour + +-- | 'Nothing' == 'transparent' +instance At ColourMap where + at x = ixColour x . from (non transparent) + +ixColour :: Rational -> Lens' ColourMap (AlphaColour Double) +ixColour x f (ColourMap cm) = f c <&> \c' -> ColourMap (M.insert x c' cm) + where + c = case (M.lookupLE x cm, M.lookupGE x cm) of + (Just (i,c1), Just (j,c2)) + | i == j -> c1 + | otherwise -> + let a = fromRational $ (x - i) / (j - i) + in blend a c2 c1 + (Just (_,c1), Nothing) -> c1 + (Nothing, Just (_,c2)) -> c2 + _ -> transparent + +-- | Indexed traversal over the colours indexed and ordered by their +-- position in the map. +cmTraverse :: IndexedTraversal' Rational ColourMap (AlphaColour Double) +cmTraverse = _Wrapped' . itraversed + +-- | Return the list of colours in the [0,1] range in order. This always +-- includes colours 0 and 1. +colourList :: ColourMap -> [(Rational, AlphaColour Double)] +colourList = itoListOf (cmTraverse . ifiltered (\i _ -> i >= 0 && i <= 1)) + . (ixColour 0 %~ id) . (ixColour 1 %~ id) + -- touch colours at 0 and 1 so they're in the list + +colourMap :: [(Rational, Colour Double)] -> ColourMap +colourMap = alphaColourMap . over (mapped . _2) opaque + +alphaColourMap :: [(Rational, AlphaColour Double)] -> ColourMap +alphaColourMap [] = ColourMap M.empty +alphaColourMap cs + | a == b = ColourMap (M.singleton 0.5 c) + | otherwise = ColourMap (M.mapKeysMonotonic normalise cm) + where + cm = M.fromList cs + (a,c) = M.findMin cm + (b,_) = M.findMax cm + normalise x = (x - a) / (b - a) + +toStops :: Fractional n => ColourMap -> [GradientStop n] +toStops = map (\(x,c) -> GradientStop (SomeColor c) (fromRational x)) + . colourList + +-- Colour maps --------------------------------------------------------- + +-- > import Plots +-- > cmBar cm = gradientColourBar cm # scaleX 15 +-- > greysBar = cmBar greys +-- > magmaBar = cmBar Plots.magma +-- > infernoBar = cmBar inferno +-- > plasmaBar = cmBar plasma +-- > viridisBar = cmBar viridis + +-- | A colour map from black to white. +-- +-- <> +greys :: ColourMap +greys = colourMap [(0, black), (1, white)] + +-- | The magma colour map taken from https://bids.github.io/colormap/. +-- +-- <> +magma :: ColourMap +magma = colourMap $ zip [1..] + [ sRGB 0.001462 0.000466 0.013866, sRGB 0.002258 0.001295 0.018331 + , sRGB 0.003279 0.002305 0.023708, sRGB 0.004512 0.003490 0.029965 + , sRGB 0.005950 0.004843 0.037130, sRGB 0.007588 0.006356 0.044973 + , sRGB 0.009426 0.008022 0.052844, sRGB 0.011465 0.009828 0.060750 + , sRGB 0.013708 0.011771 0.068667, sRGB 0.016156 0.013840 0.076603 + , sRGB 0.018815 0.016026 0.084584, sRGB 0.021692 0.018320 0.092610 + , sRGB 0.024792 0.020715 0.100676, sRGB 0.028123 0.023201 0.108787 + , sRGB 0.031696 0.025765 0.116965, sRGB 0.035520 0.028397 0.125209 + , sRGB 0.039608 0.031090 0.133515, sRGB 0.043830 0.033830 0.141886 + , sRGB 0.048062 0.036607 0.150327, sRGB 0.052320 0.039407 0.158841 + , sRGB 0.056615 0.042160 0.167446, sRGB 0.060949 0.044794 0.176129 + , sRGB 0.065330 0.047318 0.184892, sRGB 0.069764 0.049726 0.193735 + , sRGB 0.074257 0.052017 0.202660, sRGB 0.078815 0.054184 0.211667 + , sRGB 0.083446 0.056225 0.220755, sRGB 0.088155 0.058133 0.229922 + , sRGB 0.092949 0.059904 0.239164, sRGB 0.097833 0.061531 0.248477 + , sRGB 0.102815 0.063010 0.257854, sRGB 0.107899 0.064335 0.267289 + , sRGB 0.113094 0.065492 0.276784, sRGB 0.118405 0.066479 0.286321 + , sRGB 0.123833 0.067295 0.295879, sRGB 0.129380 0.067935 0.305443 + , sRGB 0.135053 0.068391 0.315000, sRGB 0.140858 0.068654 0.324538 + , sRGB 0.146785 0.068738 0.334011, sRGB 0.152839 0.068637 0.343404 + , sRGB 0.159018 0.068354 0.352688, sRGB 0.165308 0.067911 0.361816 + , sRGB 0.171713 0.067305 0.370771, sRGB 0.178212 0.066576 0.379497 + , sRGB 0.184801 0.065732 0.387973, sRGB 0.191460 0.064818 0.396152 + , sRGB 0.198177 0.063862 0.404009, sRGB 0.204935 0.062907 0.411514 + , sRGB 0.211718 0.061992 0.418647, sRGB 0.218512 0.061158 0.425392 + , sRGB 0.225302 0.060445 0.431742, sRGB 0.232077 0.059889 0.437695 + , sRGB 0.238826 0.059517 0.443256, sRGB 0.245543 0.059352 0.448436 + , sRGB 0.252220 0.059415 0.453248, sRGB 0.258857 0.059706 0.457710 + , sRGB 0.265447 0.060237 0.461840, sRGB 0.271994 0.060994 0.465660 + , sRGB 0.278493 0.061978 0.469190, sRGB 0.284951 0.063168 0.472451 + , sRGB 0.291366 0.064553 0.475462, sRGB 0.297740 0.066117 0.478243 + , sRGB 0.304081 0.067835 0.480812, sRGB 0.310382 0.069702 0.483186 + , sRGB 0.316654 0.071690 0.485380, sRGB 0.322899 0.073782 0.487408 + , sRGB 0.329114 0.075972 0.489287, sRGB 0.335308 0.078236 0.491024 + , sRGB 0.341482 0.080564 0.492631, sRGB 0.347636 0.082946 0.494121 + , sRGB 0.353773 0.085373 0.495501, sRGB 0.359898 0.087831 0.496778 + , sRGB 0.366012 0.090314 0.497960, sRGB 0.372116 0.092816 0.499053 + , sRGB 0.378211 0.095332 0.500067, sRGB 0.384299 0.097855 0.501002 + , sRGB 0.390384 0.100379 0.501864, sRGB 0.396467 0.102902 0.502658 + , sRGB 0.402548 0.105420 0.503386, sRGB 0.408629 0.107930 0.504052 + , sRGB 0.414709 0.110431 0.504662, sRGB 0.420791 0.112920 0.505215 + , sRGB 0.426877 0.115395 0.505714, sRGB 0.432967 0.117855 0.506160 + , sRGB 0.439062 0.120298 0.506555, sRGB 0.445163 0.122724 0.506901 + , sRGB 0.451271 0.125132 0.507198, sRGB 0.457386 0.127522 0.507448 + , sRGB 0.463508 0.129893 0.507652, sRGB 0.469640 0.132245 0.507809 + , sRGB 0.475780 0.134577 0.507921, sRGB 0.481929 0.136891 0.507989 + , sRGB 0.488088 0.139186 0.508011, sRGB 0.494258 0.141462 0.507988 + , sRGB 0.500438 0.143719 0.507920, sRGB 0.506629 0.145958 0.507806 + , sRGB 0.512831 0.148179 0.507648, sRGB 0.519045 0.150383 0.507443 + , sRGB 0.525270 0.152569 0.507192, sRGB 0.531507 0.154739 0.506895 + , sRGB 0.537755 0.156894 0.506551, sRGB 0.544015 0.159033 0.506159 + , sRGB 0.550287 0.161158 0.505719, sRGB 0.556571 0.163269 0.505230 + , sRGB 0.562866 0.165368 0.504692, sRGB 0.569172 0.167454 0.504105 + , sRGB 0.575490 0.169530 0.503466, sRGB 0.581819 0.171596 0.502777 + , sRGB 0.588158 0.173652 0.502035, sRGB 0.594508 0.175701 0.501241 + , sRGB 0.600868 0.177743 0.500394, sRGB 0.607238 0.179779 0.499492 + , sRGB 0.613617 0.181811 0.498536, sRGB 0.620005 0.183840 0.497524 + , sRGB 0.626401 0.185867 0.496456, sRGB 0.632805 0.187893 0.495332 + , sRGB 0.639216 0.189921 0.494150, sRGB 0.645633 0.191952 0.492910 + , sRGB 0.652056 0.193986 0.491611, sRGB 0.658483 0.196027 0.490253 + , sRGB 0.664915 0.198075 0.488836, sRGB 0.671349 0.200133 0.487358 + , sRGB 0.677786 0.202203 0.485819, sRGB 0.684224 0.204286 0.484219 + , sRGB 0.690661 0.206384 0.482558, sRGB 0.697098 0.208501 0.480835 + , sRGB 0.703532 0.210638 0.479049, sRGB 0.709962 0.212797 0.477201 + , sRGB 0.716387 0.214982 0.475290, sRGB 0.722805 0.217194 0.473316 + , sRGB 0.729216 0.219437 0.471279, sRGB 0.735616 0.221713 0.469180 + , sRGB 0.742004 0.224025 0.467018, sRGB 0.748378 0.226377 0.464794 + , sRGB 0.754737 0.228772 0.462509, sRGB 0.761077 0.231214 0.460162 + , sRGB 0.767398 0.233705 0.457755, sRGB 0.773695 0.236249 0.455289 + , sRGB 0.779968 0.238851 0.452765, sRGB 0.786212 0.241514 0.450184 + , sRGB 0.792427 0.244242 0.447543, sRGB 0.798608 0.247040 0.444848 + , sRGB 0.804752 0.249911 0.442102, sRGB 0.810855 0.252861 0.439305 + , sRGB 0.816914 0.255895 0.436461, sRGB 0.822926 0.259016 0.433573 + , sRGB 0.828886 0.262229 0.430644, sRGB 0.834791 0.265540 0.427671 + , sRGB 0.840636 0.268953 0.424666, sRGB 0.846416 0.272473 0.421631 + , sRGB 0.852126 0.276106 0.418573, sRGB 0.857763 0.279857 0.415496 + , sRGB 0.863320 0.283729 0.412403, sRGB 0.868793 0.287728 0.409303 + , sRGB 0.874176 0.291859 0.406205, sRGB 0.879464 0.296125 0.403118 + , sRGB 0.884651 0.300530 0.400047, sRGB 0.889731 0.305079 0.397002 + , sRGB 0.894700 0.309773 0.393995, sRGB 0.899552 0.314616 0.391037 + , sRGB 0.904281 0.319610 0.388137, sRGB 0.908884 0.324755 0.385308 + , sRGB 0.913354 0.330052 0.382563, sRGB 0.917689 0.335500 0.379915 + , sRGB 0.921884 0.341098 0.377376, sRGB 0.925937 0.346844 0.374959 + , sRGB 0.929845 0.352734 0.372677, sRGB 0.933606 0.358764 0.370541 + , sRGB 0.937221 0.364929 0.368567, sRGB 0.940687 0.371224 0.366762 + , sRGB 0.944006 0.377643 0.365136, sRGB 0.947180 0.384178 0.363701 + , sRGB 0.950210 0.390820 0.362468, sRGB 0.953099 0.397563 0.361438 + , sRGB 0.955849 0.404400 0.360619, sRGB 0.958464 0.411324 0.360014 + , sRGB 0.960949 0.418323 0.359630, sRGB 0.963310 0.425390 0.359469 + , sRGB 0.965549 0.432519 0.359529, sRGB 0.967671 0.439703 0.359810 + , sRGB 0.969680 0.446936 0.360311, sRGB 0.971582 0.454210 0.361030 + , sRGB 0.973381 0.461520 0.361965, sRGB 0.975082 0.468861 0.363111 + , sRGB 0.976690 0.476226 0.364466, sRGB 0.978210 0.483612 0.366025 + , sRGB 0.979645 0.491014 0.367783, sRGB 0.981000 0.498428 0.369734 + , sRGB 0.982279 0.505851 0.371874, sRGB 0.983485 0.513280 0.374198 + , sRGB 0.984622 0.520713 0.376698, sRGB 0.985693 0.528148 0.379371 + , sRGB 0.986700 0.535582 0.382210, sRGB 0.987646 0.543015 0.385210 + , sRGB 0.988533 0.550446 0.388365, sRGB 0.989363 0.557873 0.391671 + , sRGB 0.990138 0.565296 0.395122, sRGB 0.990871 0.572706 0.398714 + , sRGB 0.991558 0.580107 0.402441, sRGB 0.992196 0.587502 0.406299 + , sRGB 0.992785 0.594891 0.410283, sRGB 0.993326 0.602275 0.414390 + , sRGB 0.993834 0.609644 0.418613, sRGB 0.994309 0.616999 0.422950 + , sRGB 0.994738 0.624350 0.427397, sRGB 0.995122 0.631696 0.431951 + , sRGB 0.995480 0.639027 0.436607, sRGB 0.995810 0.646344 0.441361 + , sRGB 0.996096 0.653659 0.446213, sRGB 0.996341 0.660969 0.451160 + , sRGB 0.996580 0.668256 0.456192, sRGB 0.996775 0.675541 0.461314 + , sRGB 0.996925 0.682828 0.466526, sRGB 0.997077 0.690088 0.471811 + , sRGB 0.997186 0.697349 0.477182, sRGB 0.997254 0.704611 0.482635 + , sRGB 0.997325 0.711848 0.488154, sRGB 0.997351 0.719089 0.493755 + , sRGB 0.997351 0.726324 0.499428, sRGB 0.997341 0.733545 0.505167 + , sRGB 0.997285 0.740772 0.510983, sRGB 0.997228 0.747981 0.516859 + , sRGB 0.997138 0.755190 0.522806, sRGB 0.997019 0.762398 0.528821 + , sRGB 0.996898 0.769591 0.534892, sRGB 0.996727 0.776795 0.541039 + , sRGB 0.996571 0.783977 0.547233, sRGB 0.996369 0.791167 0.553499 + , sRGB 0.996162 0.798348 0.559820, sRGB 0.995932 0.805527 0.566202 + , sRGB 0.995680 0.812706 0.572645, sRGB 0.995424 0.819875 0.579140 + , sRGB 0.995131 0.827052 0.585701, sRGB 0.994851 0.834213 0.592307 + , sRGB 0.994524 0.841387 0.598983, sRGB 0.994222 0.848540 0.605696 + , sRGB 0.993866 0.855711 0.612482, sRGB 0.993545 0.862859 0.619299 + , sRGB 0.993170 0.870024 0.626189, sRGB 0.992831 0.877168 0.633109 + , sRGB 0.992440 0.884330 0.640099, sRGB 0.992089 0.891470 0.647116 + , sRGB 0.991688 0.898627 0.654202, sRGB 0.991332 0.905763 0.661309 + , sRGB 0.990930 0.912915 0.668481, sRGB 0.990570 0.920049 0.675675 + , sRGB 0.990175 0.927196 0.682926, sRGB 0.989815 0.934329 0.690198 + , sRGB 0.989434 0.941470 0.697519, sRGB 0.989077 0.948604 0.704863 + , sRGB 0.988717 0.955742 0.712242, sRGB 0.988367 0.962878 0.719649 + , sRGB 0.988033 0.970012 0.727077, sRGB 0.987691 0.977154 0.734536 + , sRGB 0.987387 0.984288 0.742002, sRGB 0.987053 0.991438 0.749504 + ] + +-- | The inferno colour map taken from https://bids.github.io/colormap/. +-- +-- <> +inferno :: ColourMap +inferno = colourMap $ zip [1..] + [ sRGB 0.001462 0.000466 0.013866, sRGB 0.002267 0.001270 0.018570 + , sRGB 0.003299 0.002249 0.024239, sRGB 0.004547 0.003392 0.030909 + , sRGB 0.006006 0.004692 0.038558, sRGB 0.007676 0.006136 0.046836 + , sRGB 0.009561 0.007713 0.055143, sRGB 0.011663 0.009417 0.063460 + , sRGB 0.013995 0.011225 0.071862, sRGB 0.016561 0.013136 0.080282 + , sRGB 0.019373 0.015133 0.088767, sRGB 0.022447 0.017199 0.097327 + , sRGB 0.025793 0.019331 0.105930, sRGB 0.029432 0.021503 0.114621 + , sRGB 0.033385 0.023702 0.123397, sRGB 0.037668 0.025921 0.132232 + , sRGB 0.042253 0.028139 0.141141, sRGB 0.046915 0.030324 0.150164 + , sRGB 0.051644 0.032474 0.159254, sRGB 0.056449 0.034569 0.168414 + , sRGB 0.061340 0.036590 0.177642, sRGB 0.066331 0.038504 0.186962 + , sRGB 0.071429 0.040294 0.196354, sRGB 0.076637 0.041905 0.205799 + , sRGB 0.081962 0.043328 0.215289, sRGB 0.087411 0.044556 0.224813 + , sRGB 0.092990 0.045583 0.234358, sRGB 0.098702 0.046402 0.243904 + , sRGB 0.104551 0.047008 0.253430, sRGB 0.110536 0.047399 0.262912 + , sRGB 0.116656 0.047574 0.272321, sRGB 0.122908 0.047536 0.281624 + , sRGB 0.129285 0.047293 0.290788, sRGB 0.135778 0.046856 0.299776 + , sRGB 0.142378 0.046242 0.308553, sRGB 0.149073 0.045468 0.317085 + , sRGB 0.155850 0.044559 0.325338, sRGB 0.162689 0.043554 0.333277 + , sRGB 0.169575 0.042489 0.340874, sRGB 0.176493 0.041402 0.348111 + , sRGB 0.183429 0.040329 0.354971, sRGB 0.190367 0.039309 0.361447 + , sRGB 0.197297 0.038400 0.367535, sRGB 0.204209 0.037632 0.373238 + , sRGB 0.211095 0.037030 0.378563, sRGB 0.217949 0.036615 0.383522 + , sRGB 0.224763 0.036405 0.388129, sRGB 0.231538 0.036405 0.392400 + , sRGB 0.238273 0.036621 0.396353, sRGB 0.244967 0.037055 0.400007 + , sRGB 0.251620 0.037705 0.403378, sRGB 0.258234 0.038571 0.406485 + , sRGB 0.264810 0.039647 0.409345, sRGB 0.271347 0.040922 0.411976 + , sRGB 0.277850 0.042353 0.414392, sRGB 0.284321 0.043933 0.416608 + , sRGB 0.290763 0.045644 0.418637, sRGB 0.297178 0.047470 0.420491 + , sRGB 0.303568 0.049396 0.422182, sRGB 0.309935 0.051407 0.423721 + , sRGB 0.316282 0.053490 0.425116, sRGB 0.322610 0.055634 0.426377 + , sRGB 0.328921 0.057827 0.427511, sRGB 0.335217 0.060060 0.428524 + , sRGB 0.341500 0.062325 0.429425, sRGB 0.347771 0.064616 0.430217 + , sRGB 0.354032 0.066925 0.430906, sRGB 0.360284 0.069247 0.431497 + , sRGB 0.366529 0.071579 0.431994, sRGB 0.372768 0.073915 0.432400 + , sRGB 0.379001 0.076253 0.432719, sRGB 0.385228 0.078591 0.432955 + , sRGB 0.391453 0.080927 0.433109, sRGB 0.397674 0.083257 0.433183 + , sRGB 0.403894 0.085580 0.433179, sRGB 0.410113 0.087896 0.433098 + , sRGB 0.416331 0.090203 0.432943, sRGB 0.422549 0.092501 0.432714 + , sRGB 0.428768 0.094790 0.432412, sRGB 0.434987 0.097069 0.432039 + , sRGB 0.441207 0.099338 0.431594, sRGB 0.447428 0.101597 0.431080 + , sRGB 0.453651 0.103848 0.430498, sRGB 0.459875 0.106089 0.429846 + , sRGB 0.466100 0.108322 0.429125, sRGB 0.472328 0.110547 0.428334 + , sRGB 0.478558 0.112764 0.427475, sRGB 0.484789 0.114974 0.426548 + , sRGB 0.491022 0.117179 0.425552, sRGB 0.497257 0.119379 0.424488 + , sRGB 0.503493 0.121575 0.423356, sRGB 0.509730 0.123769 0.422156 + , sRGB 0.515967 0.125960 0.420887, sRGB 0.522206 0.128150 0.419549 + , sRGB 0.528444 0.130341 0.418142, sRGB 0.534683 0.132534 0.416667 + , sRGB 0.540920 0.134729 0.415123, sRGB 0.547157 0.136929 0.413511 + , sRGB 0.553392 0.139134 0.411829, sRGB 0.559624 0.141346 0.410078 + , sRGB 0.565854 0.143567 0.408258, sRGB 0.572081 0.145797 0.406369 + , sRGB 0.578304 0.148039 0.404411, sRGB 0.584521 0.150294 0.402385 + , sRGB 0.590734 0.152563 0.400290, sRGB 0.596940 0.154848 0.398125 + , sRGB 0.603139 0.157151 0.395891, sRGB 0.609330 0.159474 0.393589 + , sRGB 0.615513 0.161817 0.391219, sRGB 0.621685 0.164184 0.388781 + , sRGB 0.627847 0.166575 0.386276, sRGB 0.633998 0.168992 0.383704 + , sRGB 0.640135 0.171438 0.381065, sRGB 0.646260 0.173914 0.378359 + , sRGB 0.652369 0.176421 0.375586, sRGB 0.658463 0.178962 0.372748 + , sRGB 0.664540 0.181539 0.369846, sRGB 0.670599 0.184153 0.366879 + , sRGB 0.676638 0.186807 0.363849, sRGB 0.682656 0.189501 0.360757 + , sRGB 0.688653 0.192239 0.357603, sRGB 0.694627 0.195021 0.354388 + , sRGB 0.700576 0.197851 0.351113, sRGB 0.706500 0.200728 0.347777 + , sRGB 0.712396 0.203656 0.344383, sRGB 0.718264 0.206636 0.340931 + , sRGB 0.724103 0.209670 0.337424, sRGB 0.729909 0.212759 0.333861 + , sRGB 0.735683 0.215906 0.330245, sRGB 0.741423 0.219112 0.326576 + , sRGB 0.747127 0.222378 0.322856, sRGB 0.752794 0.225706 0.319085 + , sRGB 0.758422 0.229097 0.315266, sRGB 0.764010 0.232554 0.311399 + , sRGB 0.769556 0.236077 0.307485, sRGB 0.775059 0.239667 0.303526 + , sRGB 0.780517 0.243327 0.299523, sRGB 0.785929 0.247056 0.295477 + , sRGB 0.791293 0.250856 0.291390, sRGB 0.796607 0.254728 0.287264 + , sRGB 0.801871 0.258674 0.283099, sRGB 0.807082 0.262692 0.278898 + , sRGB 0.812239 0.266786 0.274661, sRGB 0.817341 0.270954 0.270390 + , sRGB 0.822386 0.275197 0.266085, sRGB 0.827372 0.279517 0.261750 + , sRGB 0.832299 0.283913 0.257383, sRGB 0.837165 0.288385 0.252988 + , sRGB 0.841969 0.292933 0.248564, sRGB 0.846709 0.297559 0.244113 + , sRGB 0.851384 0.302260 0.239636, sRGB 0.855992 0.307038 0.235133 + , sRGB 0.860533 0.311892 0.230606, sRGB 0.865006 0.316822 0.226055 + , sRGB 0.869409 0.321827 0.221482, sRGB 0.873741 0.326906 0.216886 + , sRGB 0.878001 0.332060 0.212268, sRGB 0.882188 0.337287 0.207628 + , sRGB 0.886302 0.342586 0.202968, sRGB 0.890341 0.347957 0.198286 + , sRGB 0.894305 0.353399 0.193584, sRGB 0.898192 0.358911 0.188860 + , sRGB 0.902003 0.364492 0.184116, sRGB 0.905735 0.370140 0.179350 + , sRGB 0.909390 0.375856 0.174563, sRGB 0.912966 0.381636 0.169755 + , sRGB 0.916462 0.387481 0.164924, sRGB 0.919879 0.393389 0.160070 + , sRGB 0.923215 0.399359 0.155193, sRGB 0.926470 0.405389 0.150292 + , sRGB 0.929644 0.411479 0.145367, sRGB 0.932737 0.417627 0.140417 + , sRGB 0.935747 0.423831 0.135440, sRGB 0.938675 0.430091 0.130438 + , sRGB 0.941521 0.436405 0.125409, sRGB 0.944285 0.442772 0.120354 + , sRGB 0.946965 0.449191 0.115272, sRGB 0.949562 0.455660 0.110164 + , sRGB 0.952075 0.462178 0.105031, sRGB 0.954506 0.468744 0.099874 + , sRGB 0.956852 0.475356 0.094695, sRGB 0.959114 0.482014 0.089499 + , sRGB 0.961293 0.488716 0.084289, sRGB 0.963387 0.495462 0.079073 + , sRGB 0.965397 0.502249 0.073859, sRGB 0.967322 0.509078 0.068659 + , sRGB 0.969163 0.515946 0.063488, sRGB 0.970919 0.522853 0.058367 + , sRGB 0.972590 0.529798 0.053324, sRGB 0.974176 0.536780 0.048392 + , sRGB 0.975677 0.543798 0.043618, sRGB 0.977092 0.550850 0.039050 + , sRGB 0.978422 0.557937 0.034931, sRGB 0.979666 0.565057 0.031409 + , sRGB 0.980824 0.572209 0.028508, sRGB 0.981895 0.579392 0.026250 + , sRGB 0.982881 0.586606 0.024661, sRGB 0.983779 0.593849 0.023770 + , sRGB 0.984591 0.601122 0.023606, sRGB 0.985315 0.608422 0.024202 + , sRGB 0.985952 0.615750 0.025592, sRGB 0.986502 0.623105 0.027814 + , sRGB 0.986964 0.630485 0.030908, sRGB 0.987337 0.637890 0.034916 + , sRGB 0.987622 0.645320 0.039886, sRGB 0.987819 0.652773 0.045581 + , sRGB 0.987926 0.660250 0.051750, sRGB 0.987945 0.667748 0.058329 + , sRGB 0.987874 0.675267 0.065257, sRGB 0.987714 0.682807 0.072489 + , sRGB 0.987464 0.690366 0.079990, sRGB 0.987124 0.697944 0.087731 + , sRGB 0.986694 0.705540 0.095694, sRGB 0.986175 0.713153 0.103863 + , sRGB 0.985566 0.720782 0.112229, sRGB 0.984865 0.728427 0.120785 + , sRGB 0.984075 0.736087 0.129527, sRGB 0.983196 0.743758 0.138453 + , sRGB 0.982228 0.751442 0.147565, sRGB 0.981173 0.759135 0.156863 + , sRGB 0.980032 0.766837 0.166353, sRGB 0.978806 0.774545 0.176037 + , sRGB 0.977497 0.782258 0.185923, sRGB 0.976108 0.789974 0.196018 + , sRGB 0.974638 0.797692 0.206332, sRGB 0.973088 0.805409 0.216877 + , sRGB 0.971468 0.813122 0.227658, sRGB 0.969783 0.820825 0.238686 + , sRGB 0.968041 0.828515 0.249972, sRGB 0.966243 0.836191 0.261534 + , sRGB 0.964394 0.843848 0.273391, sRGB 0.962517 0.851476 0.285546 + , sRGB 0.960626 0.859069 0.298010, sRGB 0.958720 0.866624 0.310820 + , sRGB 0.956834 0.874129 0.323974, sRGB 0.954997 0.881569 0.337475 + , sRGB 0.953215 0.888942 0.351369, sRGB 0.951546 0.896226 0.365627 + , sRGB 0.950018 0.903409 0.380271, sRGB 0.948683 0.910473 0.395289 + , sRGB 0.947594 0.917399 0.410665, sRGB 0.946809 0.924168 0.426373 + , sRGB 0.946392 0.930761 0.442367, sRGB 0.946403 0.937159 0.458592 + , sRGB 0.946903 0.943348 0.474970, sRGB 0.947937 0.949318 0.491426 + , sRGB 0.949545 0.955063 0.507860, sRGB 0.951740 0.960587 0.524203 + , sRGB 0.954529 0.965896 0.540361, sRGB 0.957896 0.971003 0.556275 + , sRGB 0.961812 0.975924 0.571925, sRGB 0.966249 0.980678 0.587206 + , sRGB 0.971162 0.985282 0.602154, sRGB 0.976511 0.989753 0.616760 + , sRGB 0.982257 0.994109 0.631017, sRGB 0.988362 0.998364 0.644924 + ] + +-- | The plasma colour map taken from https://bids.github.io/colormap/. +-- +-- <> +plasma :: ColourMap +plasma = colourMap $ zip [1..] + [ sRGB 0.050383 0.029803 0.527975, sRGB 0.063536 0.028426 0.533124 + , sRGB 0.075353 0.027206 0.538007, sRGB 0.086222 0.026125 0.542658 + , sRGB 0.096379 0.025165 0.547103, sRGB 0.105980 0.024309 0.551368 + , sRGB 0.115124 0.023556 0.555468, sRGB 0.123903 0.022878 0.559423 + , sRGB 0.132381 0.022258 0.563250, sRGB 0.140603 0.021687 0.566959 + , sRGB 0.148607 0.021154 0.570562, sRGB 0.156421 0.020651 0.574065 + , sRGB 0.164070 0.020171 0.577478, sRGB 0.171574 0.019706 0.580806 + , sRGB 0.178950 0.019252 0.584054, sRGB 0.186213 0.018803 0.587228 + , sRGB 0.193374 0.018354 0.590330, sRGB 0.200445 0.017902 0.593364 + , sRGB 0.207435 0.017442 0.596333, sRGB 0.214350 0.016973 0.599239 + , sRGB 0.221197 0.016497 0.602083, sRGB 0.227983 0.016007 0.604867 + , sRGB 0.234715 0.015502 0.607592, sRGB 0.241396 0.014979 0.610259 + , sRGB 0.248032 0.014439 0.612868, sRGB 0.254627 0.013882 0.615419 + , sRGB 0.261183 0.013308 0.617911, sRGB 0.267703 0.012716 0.620346 + , sRGB 0.274191 0.012109 0.622722, sRGB 0.280648 0.011488 0.625038 + , sRGB 0.287076 0.010855 0.627295, sRGB 0.293478 0.010213 0.629490 + , sRGB 0.299855 0.009561 0.631624, sRGB 0.306210 0.008902 0.633694 + , sRGB 0.312543 0.008239 0.635700, sRGB 0.318856 0.007576 0.637640 + , sRGB 0.325150 0.006915 0.639512, sRGB 0.331426 0.006261 0.641316 + , sRGB 0.337683 0.005618 0.643049, sRGB 0.343925 0.004991 0.644710 + , sRGB 0.350150 0.004382 0.646298, sRGB 0.356359 0.003798 0.647810 + , sRGB 0.362553 0.003243 0.649245, sRGB 0.368733 0.002724 0.650601 + , sRGB 0.374897 0.002245 0.651876, sRGB 0.381047 0.001814 0.653068 + , sRGB 0.387183 0.001434 0.654177, sRGB 0.393304 0.001114 0.655199 + , sRGB 0.399411 0.000859 0.656133, sRGB 0.405503 0.000678 0.656977 + , sRGB 0.411580 0.000577 0.657730, sRGB 0.417642 0.000564 0.658390 + , sRGB 0.423689 0.000646 0.658956, sRGB 0.429719 0.000831 0.659425 + , sRGB 0.435734 0.001127 0.659797, sRGB 0.441732 0.001540 0.660069 + , sRGB 0.447714 0.002080 0.660240, sRGB 0.453677 0.002755 0.660310 + , sRGB 0.459623 0.003574 0.660277, sRGB 0.465550 0.004545 0.660139 + , sRGB 0.471457 0.005678 0.659897, sRGB 0.477344 0.006980 0.659549 + , sRGB 0.483210 0.008460 0.659095, sRGB 0.489055 0.010127 0.658534 + , sRGB 0.494877 0.011990 0.657865, sRGB 0.500678 0.014055 0.657088 + , sRGB 0.506454 0.016333 0.656202, sRGB 0.512206 0.018833 0.655209 + , sRGB 0.517933 0.021563 0.654109, sRGB 0.523633 0.024532 0.652901 + , sRGB 0.529306 0.027747 0.651586, sRGB 0.534952 0.031217 0.650165 + , sRGB 0.540570 0.034950 0.648640, sRGB 0.546157 0.038954 0.647010 + , sRGB 0.551715 0.043136 0.645277, sRGB 0.557243 0.047331 0.643443 + , sRGB 0.562738 0.051545 0.641509, sRGB 0.568201 0.055778 0.639477 + , sRGB 0.573632 0.060028 0.637349, sRGB 0.579029 0.064296 0.635126 + , sRGB 0.584391 0.068579 0.632812, sRGB 0.589719 0.072878 0.630408 + , sRGB 0.595011 0.077190 0.627917, sRGB 0.600266 0.081516 0.625342 + , sRGB 0.605485 0.085854 0.622686, sRGB 0.610667 0.090204 0.619951 + , sRGB 0.615812 0.094564 0.617140, sRGB 0.620919 0.098934 0.614257 + , sRGB 0.625987 0.103312 0.611305, sRGB 0.631017 0.107699 0.608287 + , sRGB 0.636008 0.112092 0.605205, sRGB 0.640959 0.116492 0.602065 + , sRGB 0.645872 0.120898 0.598867, sRGB 0.650746 0.125309 0.595617 + , sRGB 0.655580 0.129725 0.592317, sRGB 0.660374 0.134144 0.588971 + , sRGB 0.665129 0.138566 0.585582, sRGB 0.669845 0.142992 0.582154 + , sRGB 0.674522 0.147419 0.578688, sRGB 0.679160 0.151848 0.575189 + , sRGB 0.683758 0.156278 0.571660, sRGB 0.688318 0.160709 0.568103 + , sRGB 0.692840 0.165141 0.564522, sRGB 0.697324 0.169573 0.560919 + , sRGB 0.701769 0.174005 0.557296, sRGB 0.706178 0.178437 0.553657 + , sRGB 0.710549 0.182868 0.550004, sRGB 0.714883 0.187299 0.546338 + , sRGB 0.719181 0.191729 0.542663, sRGB 0.723444 0.196158 0.538981 + , sRGB 0.727670 0.200586 0.535293, sRGB 0.731862 0.205013 0.531601 + , sRGB 0.736019 0.209439 0.527908, sRGB 0.740143 0.213864 0.524216 + , sRGB 0.744232 0.218288 0.520524, sRGB 0.748289 0.222711 0.516834 + , sRGB 0.752312 0.227133 0.513149, sRGB 0.756304 0.231555 0.509468 + , sRGB 0.760264 0.235976 0.505794, sRGB 0.764193 0.240396 0.502126 + , sRGB 0.768090 0.244817 0.498465, sRGB 0.771958 0.249237 0.494813 + , sRGB 0.775796 0.253658 0.491171, sRGB 0.779604 0.258078 0.487539 + , sRGB 0.783383 0.262500 0.483918, sRGB 0.787133 0.266922 0.480307 + , sRGB 0.790855 0.271345 0.476706, sRGB 0.794549 0.275770 0.473117 + , sRGB 0.798216 0.280197 0.469538, sRGB 0.801855 0.284626 0.465971 + , sRGB 0.805467 0.289057 0.462415, sRGB 0.809052 0.293491 0.458870 + , sRGB 0.812612 0.297928 0.455338, sRGB 0.816144 0.302368 0.451816 + , sRGB 0.819651 0.306812 0.448306, sRGB 0.823132 0.311261 0.444806 + , sRGB 0.826588 0.315714 0.441316, sRGB 0.830018 0.320172 0.437836 + , sRGB 0.833422 0.324635 0.434366, sRGB 0.836801 0.329105 0.430905 + , sRGB 0.840155 0.333580 0.427455, sRGB 0.843484 0.338062 0.424013 + , sRGB 0.846788 0.342551 0.420579, sRGB 0.850066 0.347048 0.417153 + , sRGB 0.853319 0.351553 0.413734, sRGB 0.856547 0.356066 0.410322 + , sRGB 0.859750 0.360588 0.406917, sRGB 0.862927 0.365119 0.403519 + , sRGB 0.866078 0.369660 0.400126, sRGB 0.869203 0.374212 0.396738 + , sRGB 0.872303 0.378774 0.393355, sRGB 0.875376 0.383347 0.389976 + , sRGB 0.878423 0.387932 0.386600, sRGB 0.881443 0.392529 0.383229 + , sRGB 0.884436 0.397139 0.379860, sRGB 0.887402 0.401762 0.376494 + , sRGB 0.890340 0.406398 0.373130, sRGB 0.893250 0.411048 0.369768 + , sRGB 0.896131 0.415712 0.366407, sRGB 0.898984 0.420392 0.363047 + , sRGB 0.901807 0.425087 0.359688, sRGB 0.904601 0.429797 0.356329 + , sRGB 0.907365 0.434524 0.352970, sRGB 0.910098 0.439268 0.349610 + , sRGB 0.912800 0.444029 0.346251, sRGB 0.915471 0.448807 0.342890 + , sRGB 0.918109 0.453603 0.339529, sRGB 0.920714 0.458417 0.336166 + , sRGB 0.923287 0.463251 0.332801, sRGB 0.925825 0.468103 0.329435 + , sRGB 0.928329 0.472975 0.326067, sRGB 0.930798 0.477867 0.322697 + , sRGB 0.933232 0.482780 0.319325, sRGB 0.935630 0.487712 0.315952 + , sRGB 0.937990 0.492667 0.312575, sRGB 0.940313 0.497642 0.309197 + , sRGB 0.942598 0.502639 0.305816, sRGB 0.944844 0.507658 0.302433 + , sRGB 0.947051 0.512699 0.299049, sRGB 0.949217 0.517763 0.295662 + , sRGB 0.951344 0.522850 0.292275, sRGB 0.953428 0.527960 0.288883 + , sRGB 0.955470 0.533093 0.285490, sRGB 0.957469 0.538250 0.282096 + , sRGB 0.959424 0.543431 0.278701, sRGB 0.961336 0.548636 0.275305 + , sRGB 0.963203 0.553865 0.271909, sRGB 0.965024 0.559118 0.268513 + , sRGB 0.966798 0.564396 0.265118, sRGB 0.968526 0.569700 0.261721 + , sRGB 0.970205 0.575028 0.258325, sRGB 0.971835 0.580382 0.254931 + , sRGB 0.973416 0.585761 0.251540, sRGB 0.974947 0.591165 0.248151 + , sRGB 0.976428 0.596595 0.244767, sRGB 0.977856 0.602051 0.241387 + , sRGB 0.979233 0.607532 0.238013, sRGB 0.980556 0.613039 0.234646 + , sRGB 0.981826 0.618572 0.231287, sRGB 0.983041 0.624131 0.227937 + , sRGB 0.984199 0.629718 0.224595, sRGB 0.985301 0.635330 0.221265 + , sRGB 0.986345 0.640969 0.217948, sRGB 0.987332 0.646633 0.214648 + , sRGB 0.988260 0.652325 0.211364, sRGB 0.989128 0.658043 0.208100 + , sRGB 0.989935 0.663787 0.204859, sRGB 0.990681 0.669558 0.201642 + , sRGB 0.991365 0.675355 0.198453, sRGB 0.991985 0.681179 0.195295 + , sRGB 0.992541 0.687030 0.192170, sRGB 0.993032 0.692907 0.189084 + , sRGB 0.993456 0.698810 0.186041, sRGB 0.993814 0.704741 0.183043 + , sRGB 0.994103 0.710698 0.180097, sRGB 0.994324 0.716681 0.177208 + , sRGB 0.994474 0.722691 0.174381, sRGB 0.994553 0.728728 0.171622 + , sRGB 0.994561 0.734791 0.168938, sRGB 0.994495 0.740880 0.166335 + , sRGB 0.994355 0.746995 0.163821, sRGB 0.994141 0.753137 0.161404 + , sRGB 0.993851 0.759304 0.159092, sRGB 0.993482 0.765499 0.156891 + , sRGB 0.993033 0.771720 0.154808, sRGB 0.992505 0.777967 0.152855 + , sRGB 0.991897 0.784239 0.151042, sRGB 0.991209 0.790537 0.149377 + , sRGB 0.990439 0.796859 0.147870, sRGB 0.989587 0.803205 0.146529 + , sRGB 0.988648 0.809579 0.145357, sRGB 0.987621 0.815978 0.144363 + , sRGB 0.986509 0.822401 0.143557, sRGB 0.985314 0.828846 0.142945 + , sRGB 0.984031 0.835315 0.142528, sRGB 0.982653 0.841812 0.142303 + , sRGB 0.981190 0.848329 0.142279, sRGB 0.979644 0.854866 0.142453 + , sRGB 0.977995 0.861432 0.142808, sRGB 0.976265 0.868016 0.143351 + , sRGB 0.974443 0.874622 0.144061, sRGB 0.972530 0.881250 0.144923 + , sRGB 0.970533 0.887896 0.145919, sRGB 0.968443 0.894564 0.147014 + , sRGB 0.966271 0.901249 0.148180, sRGB 0.964021 0.907950 0.149370 + , sRGB 0.961681 0.914672 0.150520, sRGB 0.959276 0.921407 0.151566 + , sRGB 0.956808 0.928152 0.152409, sRGB 0.954287 0.934908 0.152921 + , sRGB 0.951726 0.941671 0.152925, sRGB 0.949151 0.948435 0.152178 + , sRGB 0.946602 0.955190 0.150328, sRGB 0.944152 0.961916 0.146861 + , sRGB 0.941896 0.968590 0.140956, sRGB 0.940015 0.975158 0.131326 + ] + +-- | The viridis colour map taken from https://bids.github.io/colormap/. +-- This is the default colour map. +-- +-- <> +viridis :: ColourMap +viridis = colourMap $ zip [1..] + [ sRGB 0.267004 0.004874 0.329415, sRGB 0.268510 0.009605 0.335427 + , sRGB 0.269944 0.014625 0.341379, sRGB 0.271305 0.019942 0.347269 + , sRGB 0.272594 0.025563 0.353093, sRGB 0.273809 0.031497 0.358853 + , sRGB 0.274952 0.037752 0.364543, sRGB 0.276022 0.044167 0.370164 + , sRGB 0.277018 0.050344 0.375715, sRGB 0.277941 0.056324 0.381191 + , sRGB 0.278791 0.062145 0.386592, sRGB 0.279566 0.067836 0.391917 + , sRGB 0.280267 0.073417 0.397163, sRGB 0.280894 0.078907 0.402329 + , sRGB 0.281446 0.084320 0.407414, sRGB 0.281924 0.089666 0.412415 + , sRGB 0.282327 0.094955 0.417331, sRGB 0.282656 0.100196 0.422160 + , sRGB 0.282910 0.105393 0.426902, sRGB 0.283091 0.110553 0.431554 + , sRGB 0.283197 0.115680 0.436115, sRGB 0.283229 0.120777 0.440584 + , sRGB 0.283187 0.125848 0.444960, sRGB 0.283072 0.130895 0.449241 + , sRGB 0.282884 0.135920 0.453427, sRGB 0.282623 0.140926 0.457517 + , sRGB 0.282290 0.145912 0.461510, sRGB 0.281887 0.150881 0.465405 + , sRGB 0.281412 0.155834 0.469201, sRGB 0.280868 0.160771 0.472899 + , sRGB 0.280255 0.165693 0.476498, sRGB 0.279574 0.170599 0.479997 + , sRGB 0.278826 0.175490 0.483397, sRGB 0.278012 0.180367 0.486697 + , sRGB 0.277134 0.185228 0.489898, sRGB 0.276194 0.190074 0.493001 + , sRGB 0.275191 0.194905 0.496005, sRGB 0.274128 0.199721 0.498911 + , sRGB 0.273006 0.204520 0.501721, sRGB 0.271828 0.209303 0.504434 + , sRGB 0.270595 0.214069 0.507052, sRGB 0.269308 0.218818 0.509577 + , sRGB 0.267968 0.223549 0.512008, sRGB 0.266580 0.228262 0.514349 + , sRGB 0.265145 0.232956 0.516599, sRGB 0.263663 0.237631 0.518762 + , sRGB 0.262138 0.242286 0.520837, sRGB 0.260571 0.246922 0.522828 + , sRGB 0.258965 0.251537 0.524736, sRGB 0.257322 0.256130 0.526563 + , sRGB 0.255645 0.260703 0.528312, sRGB 0.253935 0.265254 0.529983 + , sRGB 0.252194 0.269783 0.531579, sRGB 0.250425 0.274290 0.533103 + , sRGB 0.248629 0.278775 0.534556, sRGB 0.246811 0.283237 0.535941 + , sRGB 0.244972 0.287675 0.537260, sRGB 0.243113 0.292092 0.538516 + , sRGB 0.241237 0.296485 0.539709, sRGB 0.239346 0.300855 0.540844 + , sRGB 0.237441 0.305202 0.541921, sRGB 0.235526 0.309527 0.542944 + , sRGB 0.233603 0.313828 0.543914, sRGB 0.231674 0.318106 0.544834 + , sRGB 0.229739 0.322361 0.545706, sRGB 0.227802 0.326594 0.546532 + , sRGB 0.225863 0.330805 0.547314, sRGB 0.223925 0.334994 0.548053 + , sRGB 0.221989 0.339161 0.548752, sRGB 0.220057 0.343307 0.549413 + , sRGB 0.218130 0.347432 0.550038, sRGB 0.216210 0.351535 0.550627 + , sRGB 0.214298 0.355619 0.551184, sRGB 0.212395 0.359683 0.551710 + , sRGB 0.210503 0.363727 0.552206, sRGB 0.208623 0.367752 0.552675 + , sRGB 0.206756 0.371758 0.553117, sRGB 0.204903 0.375746 0.553533 + , sRGB 0.203063 0.379716 0.553925, sRGB 0.201239 0.383670 0.554294 + , sRGB 0.199430 0.387607 0.554642, sRGB 0.197636 0.391528 0.554969 + , sRGB 0.195860 0.395433 0.555276, sRGB 0.194100 0.399323 0.555565 + , sRGB 0.192357 0.403199 0.555836, sRGB 0.190631 0.407061 0.556089 + , sRGB 0.188923 0.410910 0.556326, sRGB 0.187231 0.414746 0.556547 + , sRGB 0.185556 0.418570 0.556753, sRGB 0.183898 0.422383 0.556944 + , sRGB 0.182256 0.426184 0.557120, sRGB 0.180629 0.429975 0.557282 + , sRGB 0.179019 0.433756 0.557430, sRGB 0.177423 0.437527 0.557565 + , sRGB 0.175841 0.441290 0.557685, sRGB 0.174274 0.445044 0.557792 + , sRGB 0.172719 0.448791 0.557885, sRGB 0.171176 0.452530 0.557965 + , sRGB 0.169646 0.456262 0.558030, sRGB 0.168126 0.459988 0.558082 + , sRGB 0.166617 0.463708 0.558119, sRGB 0.165117 0.467423 0.558141 + , sRGB 0.163625 0.471133 0.558148, sRGB 0.162142 0.474838 0.558140 + , sRGB 0.160665 0.478540 0.558115, sRGB 0.159194 0.482237 0.558073 + , sRGB 0.157729 0.485932 0.558013, sRGB 0.156270 0.489624 0.557936 + , sRGB 0.154815 0.493313 0.557840, sRGB 0.153364 0.497000 0.557724 + , sRGB 0.151918 0.500685 0.557587, sRGB 0.150476 0.504369 0.557430 + , sRGB 0.149039 0.508051 0.557250, sRGB 0.147607 0.511733 0.557049 + , sRGB 0.146180 0.515413 0.556823, sRGB 0.144759 0.519093 0.556572 + , sRGB 0.143343 0.522773 0.556295, sRGB 0.141935 0.526453 0.555991 + , sRGB 0.140536 0.530132 0.555659, sRGB 0.139147 0.533812 0.555298 + , sRGB 0.137770 0.537492 0.554906, sRGB 0.136408 0.541173 0.554483 + , sRGB 0.135066 0.544853 0.554029, sRGB 0.133743 0.548535 0.553541 + , sRGB 0.132444 0.552216 0.553018, sRGB 0.131172 0.555899 0.552459 + , sRGB 0.129933 0.559582 0.551864, sRGB 0.128729 0.563265 0.551229 + , sRGB 0.127568 0.566949 0.550556, sRGB 0.126453 0.570633 0.549841 + , sRGB 0.125394 0.574318 0.549086, sRGB 0.124395 0.578002 0.548287 + , sRGB 0.123463 0.581687 0.547445, sRGB 0.122606 0.585371 0.546557 + , sRGB 0.121831 0.589055 0.545623, sRGB 0.121148 0.592739 0.544641 + , sRGB 0.120565 0.596422 0.543611, sRGB 0.120092 0.600104 0.542530 + , sRGB 0.119738 0.603785 0.541400, sRGB 0.119512 0.607464 0.540218 + , sRGB 0.119423 0.611141 0.538982, sRGB 0.119483 0.614817 0.537692 + , sRGB 0.119699 0.618490 0.536347, sRGB 0.120081 0.622161 0.534946 + , sRGB 0.120638 0.625828 0.533488, sRGB 0.121380 0.629492 0.531973 + , sRGB 0.122312 0.633153 0.530398, sRGB 0.123444 0.636809 0.528763 + , sRGB 0.124780 0.640461 0.527068, sRGB 0.126326 0.644107 0.525311 + , sRGB 0.128087 0.647749 0.523491, sRGB 0.130067 0.651384 0.521608 + , sRGB 0.132268 0.655014 0.519661, sRGB 0.134692 0.658636 0.517649 + , sRGB 0.137339 0.662252 0.515571, sRGB 0.140210 0.665859 0.513427 + , sRGB 0.143303 0.669459 0.511215, sRGB 0.146616 0.673050 0.508936 + , sRGB 0.150148 0.676631 0.506589, sRGB 0.153894 0.680203 0.504172 + , sRGB 0.157851 0.683765 0.501686, sRGB 0.162016 0.687316 0.499129 + , sRGB 0.166383 0.690856 0.496502, sRGB 0.170948 0.694384 0.493803 + , sRGB 0.175707 0.697900 0.491033, sRGB 0.180653 0.701402 0.488189 + , sRGB 0.185783 0.704891 0.485273, sRGB 0.191090 0.708366 0.482284 + , sRGB 0.196571 0.711827 0.479221, sRGB 0.202219 0.715272 0.476084 + , sRGB 0.208030 0.718701 0.472873, sRGB 0.214000 0.722114 0.469588 + , sRGB 0.220124 0.725509 0.466226, sRGB 0.226397 0.728888 0.462789 + , sRGB 0.232815 0.732247 0.459277, sRGB 0.239374 0.735588 0.455688 + , sRGB 0.246070 0.738910 0.452024, sRGB 0.252899 0.742211 0.448284 + , sRGB 0.259857 0.745492 0.444467, sRGB 0.266941 0.748751 0.440573 + , sRGB 0.274149 0.751988 0.436601, sRGB 0.281477 0.755203 0.432552 + , sRGB 0.288921 0.758394 0.428426, sRGB 0.296479 0.761561 0.424223 + , sRGB 0.304148 0.764704 0.419943, sRGB 0.311925 0.767822 0.415586 + , sRGB 0.319809 0.770914 0.411152, sRGB 0.327796 0.773980 0.406640 + , sRGB 0.335885 0.777018 0.402049, sRGB 0.344074 0.780029 0.397381 + , sRGB 0.352360 0.783011 0.392636, sRGB 0.360741 0.785964 0.387814 + , sRGB 0.369214 0.788888 0.382914, sRGB 0.377779 0.791781 0.377939 + , sRGB 0.386433 0.794644 0.372886, sRGB 0.395174 0.797475 0.367757 + , sRGB 0.404001 0.800275 0.362552, sRGB 0.412913 0.803041 0.357269 + , sRGB 0.421908 0.805774 0.351910, sRGB 0.430983 0.808473 0.346476 + , sRGB 0.440137 0.811138 0.340967, sRGB 0.449368 0.813768 0.335384 + , sRGB 0.458674 0.816363 0.329727, sRGB 0.468053 0.818921 0.323998 + , sRGB 0.477504 0.821444 0.318195, sRGB 0.487026 0.823929 0.312321 + , sRGB 0.496615 0.826376 0.306377, sRGB 0.506271 0.828786 0.300362 + , sRGB 0.515992 0.831158 0.294279, sRGB 0.525776 0.833491 0.288127 + , sRGB 0.535621 0.835785 0.281908, sRGB 0.545524 0.838039 0.275626 + , sRGB 0.555484 0.840254 0.269281, sRGB 0.565498 0.842430 0.262877 + , sRGB 0.575563 0.844566 0.256415, sRGB 0.585678 0.846661 0.249897 + , sRGB 0.595839 0.848717 0.243329, sRGB 0.606045 0.850733 0.236712 + , sRGB 0.616293 0.852709 0.230052, sRGB 0.626579 0.854645 0.223353 + , sRGB 0.636902 0.856542 0.216620, sRGB 0.647257 0.858400 0.209861 + , sRGB 0.657642 0.860219 0.203082, sRGB 0.668054 0.861999 0.196293 + , sRGB 0.678489 0.863742 0.189503, sRGB 0.688944 0.865448 0.182725 + , sRGB 0.699415 0.867117 0.175971, sRGB 0.709898 0.868751 0.169257 + , sRGB 0.720391 0.870350 0.162603, sRGB 0.730889 0.871916 0.156029 + , sRGB 0.741388 0.873449 0.149561, sRGB 0.751884 0.874951 0.143228 + , sRGB 0.762373 0.876424 0.137064, sRGB 0.772852 0.877868 0.131109 + , sRGB 0.783315 0.879285 0.125405, sRGB 0.793760 0.880678 0.120005 + , sRGB 0.804182 0.882046 0.114965, sRGB 0.814576 0.883393 0.110347 + , sRGB 0.824940 0.884720 0.106217, sRGB 0.835270 0.886029 0.102646 + , sRGB 0.845561 0.887322 0.099702, sRGB 0.855810 0.888601 0.097452 + , sRGB 0.866013 0.889868 0.095953, sRGB 0.876168 0.891125 0.095250 + , sRGB 0.886271 0.892374 0.095374, sRGB 0.896320 0.893616 0.096335 + , sRGB 0.906311 0.894855 0.098125, sRGB 0.916242 0.896091 0.100717 + , sRGB 0.926106 0.897330 0.104071, sRGB 0.935904 0.898570 0.108131 + , sRGB 0.945636 0.899815 0.112838, sRGB 0.955300 0.901065 0.118128 + , sRGB 0.964894 0.902323 0.123941, sRGB 0.974417 0.903590 0.130215 + , sRGB 0.983868 0.904867 0.136897, sRGB 0.993248 0.906157 0.143936 + ] + diff --git a/src/Plots/Types.hs b/src/Plots/Types.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Types.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines the various types for holding plots: +-- +-- [@'PlotOptions' b v n@] +-- Generic options all plots have. +-- +-- [@'PlotMods' b v n@] +-- Includes 'PlotOptions' along with modifications to the 'PlotStyle'. +-- +-- [@'Plot' p b@] +-- A 'rawPlot' @p@ grouped with a 'PlotMods'. +-- +-- [@'DynamicPlot' b v n@] +-- A wrapped up 'Plot' so it can be stored in an 'Axis'. +-- +-- [@'StyledPlot' b v n@] +-- A 'DynamicPlot' with a concrete 'PlotStyle', ready to be rendered. +-- +-- As well as other things like the 'Plotable' class, 'LegendEntries', +-- 'HasOrientation' and 'HasVisibility'. +-- +---------------------------------------------------------------------------- +module Plots.Types + ( + + -- * Plot options + PlotOptions + , HasPlotOptions (..) + , key + , addLegendEntry + + -- ** Plot modifications + , PlotMods + , plotMods + + -- * Plotable class + , Plotable (..) + + -- * Plot types + -- ** Parameterised plot + , Plot + , mkPlot + , rawPlot + + -- ** Dynamic plot + , DynamicPlot (..) + , _DynamicPlot + , dynamicPlot + , dynamicPlotMods + + -- ** Styled plot + , StyledPlot + , styledPlot + , styleDynamic + , renderStyledPlot + , singleStyledPlotLegend + , styledPlotLegends + + -- * Miscellaneous + -- ** Visibility + , HasVisibility (..) + , hide + , display + + -- ** Orientation + , Orientation (..) + , HasOrientation (..) + , orient + , horizontal + , vertical + + -- ** Legend entries + , LegendEntry + , LegendPic (..) + , mkLegendEntry + , legendPicture + , legendText + , legendPrecedence + + -- ** Axis spec + , AxisSpec (..) + , specTrans + , specBounds + , specScale + , scaleNum + , specPoint + , specColourMap + + -- ** Positioning + , Placement (..) + , HasPlacement (..) + , HasGap (..) + , placeAgainst + + -- *** Common positions + -- **** Inside positions + , topLeft, top, topRight, left, right, bottomLeft, bottom + , bottomRight + + -- **** Outside positions + , leftAbove, leftTop, leftMid, leftBottom, leftBelow, midAbove, midBelow + , rightAbove, rightTop, rightMid, rightBottom, rightBelow + + ) where + +import Control.Monad.State +import Data.Bool +import Data.Maybe (fromMaybe) +import Data.Orphans () +import Data.Typeable +import Data.List (sortOn) +import Diagrams.Prelude as D + +#if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (Foldable) +#endif + +import Plots.Style +import Plots.Axis.Scale +import Plots.Util + +-- Orientation --------------------------------------------------------- + +data Orientation = Horizontal | Vertical + deriving (Show, Eq, Ord, Typeable) + +-- | Pick the first @a@ if the object has 'Horizontal' orientation and +-- the second @a@ if the object has a 'Vertical' orientation. +orient :: HasOrientation o => o -> a -> a -> a +orient o h v = + case view orientation o of + Horizontal -> h + Vertical -> v + +-- | Class of things that have an orientation. +class HasOrientation a where + -- | Lens onto the orientation of an object. + orientation :: Lens' a Orientation + +instance HasOrientation Orientation where + orientation = id + +-- | Lens onto whether an object's orientation is horizontal. +horizontal :: HasOrientation a => Lens' a Bool +horizontal = orientation . iso (==Horizontal) (bool Vertical Horizontal) + +-- | Lens onto whether an object's orientation is vertical. +vertical :: HasOrientation a => Lens' a Bool +vertical = horizontal . involuted not + +------------------------------------------------------------------------ +-- Placement +------------------------------------------------------------------------ + +class HasGap a where + -- | The value of the gap when rendering. + 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 Rational + } + 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. + -- we keep posGap and posGapDir as separate values to keep lens laws + -- for 0 gaps + -- I'm not sure this should work for a 3D axis + +class HasPlacement a where + placement :: Lens' a Placement + + -- | The position relative to the axis. @V2 0 0@ corresponds to the + -- bottom left corner, @V2 1 1@ is the top right corner. + placementAt :: Lens' a (V2 Rational) + placementAt = placement . lens pAt (\p a -> p {pAt = a}) + + -- | The anchor used for the object being positioned. @V2 0 0@ + -- corresponds to the bottom left corner, @V2 1 1@ is the top right + -- corner. + placementAnchor :: Lens' a (V2 Rational) + placementAnchor = placement . lens pAnchor (\p a -> p {pAnchor = a}) + + -- | The direction to extend the 'gap' when positioning. + gapDirection :: Lens' a (Direction V2 Rational) + gapDirection = placement . lens pGapDir (\p a -> p {pGapDir = a}) + +instance HasPlacement Placement where + placement = id + +-- Inside positions ---------------------------------------------------- + +-- Internal helper for all inside placements +pInside :: V2 Rational -> Placement +pInside v = Placement + { pAt = v + , pAnchor = v + , pGapDir = dirBetween' (P v) origin + } + +-- | @dirBetween p q@ returns the directions from @p@ to @q@ +dirBetween' :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n +dirBetween' p q = direction $ q .-. p + + +topLeft, top, topRight, left, right, bottomLeft, bottom, bottomRight :: Placement +topLeft = pInside (V2 (-1) 1 ) +top = pInside (V2 0 1 ) +topRight = pInside (V2 1 1 ) +left = pInside (V2 (-1) 0 ) +right = pInside (V2 (-1) 0 ) +bottomLeft = pInside (V2 (-1) (-1)) +bottom = pInside (V2 0 (-1)) +bottomRight = pInside (V2 1 (-1)) + +-- Outside positions --------------------------------------------------- + +leftAbove, leftTop, leftMid, leftBottom, leftBelow, midAbove, midBelow, + rightAbove, rightTop, rightMid, rightBottom, rightBelow :: Placement + +leftAbove = Placement (V2 (-1) 1 ) (V2 (-1) (-1)) (direction (V2 0 1 )) +leftTop = Placement (V2 (-1) 1 ) (V2 1 1 ) (direction (V2 (-1) 0 )) +leftMid = Placement (V2 (-1) 0 ) (V2 1 0 ) (direction (V2 (-1) 0 )) +leftBottom = Placement (V2 (-1) (-1)) (V2 1 (-1)) (direction (V2 (-1) 0 )) +leftBelow = Placement (V2 (-1) (-1)) (V2 (-1) 1 ) (direction (V2 0 (-1))) + +midAbove = Placement (V2 0 1 ) (V2 0 (-1)) (direction (V2 0 1 )) +midBelow = Placement (V2 0 (-1)) (V2 0 1 ) (direction (V2 0 (-1))) + +rightAbove = Placement (V2 1 1 ) (V2 1 (-1)) (direction (V2 0 1 )) +rightTop = Placement (V2 1 1 ) (V2 (-1) 1 ) (direction (V2 1 0 )) +rightMid = Placement (V2 1 0 ) (V2 (-1) 0 ) (direction (V2 1 0 )) +rightBottom = Placement (V2 1 (-1)) (V2 (-1) (-1)) (direction (V2 1 0 )) +rightBelow = Placement (V2 1 (-1)) (V2 1 1 ) (direction (V2 0 (-1))) + +-- Using positions ----------------------------------------------------- + +-- | 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, + 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 (fmap fromRational d)) + where + pos = mkP2 (lerp' px xu xl) (lerp' py yu yl) + anchor = alignBy unitX (fromRational ax) . alignBy unitY (fromRational ay) + (P (V2 xl yl), P (V2 xu yu)) = fromMaybe (origin, origin) (getCorners $ boundingBox a) + + lerp' z u v = fromRational alpha * u + (1 - fromRational alpha) * v + where alpha = (z + 1) / 2 + +------------------------------------------------------------------------ +-- Legend entries +------------------------------------------------------------------------ + +-- | Type allowing use of the default legend picture (depending on the +-- plot) or a custom legend picture with access to the 'PlotStyle'. +data LegendPic b v n + = DefaultLegendPic + | CustomLegendPic (PlotStyle b v n -> QDiagram b v n Any) + +instance Default (LegendPic b v n) where + def = DefaultLegendPic + +-- | Data type for holding a legend entry. +data LegendEntry b v n = LegendEntry + { lPic :: LegendPic b v n + , lText :: String + , lPrecedence :: n + } deriving Typeable + +-- | The picture used in the legend entry. +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 b v n) String +legendText = lens lText (\l txt -> l {lText = txt}) + +-- | The order in which the legend entries are rendered. If precedence +-- are equal, they entries are put in the order they are added to the +-- axis. +-- +-- Default is @0@. +legendPrecedence :: Lens' (LegendEntry b v n) n +legendPrecedence = lens lPrecedence (\l n -> l {lPrecedence = n}) + +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 :: Num n => String -> LegendEntry b v n +mkLegendEntry x = LegendEntry DefaultLegendPic x 0 + +------------------------------------------------------------------------ +-- Plot attributes +------------------------------------------------------------------------ + +-- Generic Plot info + +-- | Data type for holding information all plots must contain. +data PlotOptions b v n = PlotOptions + { poName :: Name + , poClipPlot :: Bool + , poLegend :: [LegendEntry b v n] + , poVisible :: Bool + , poTransform :: Transformation v n + -- , poPostPlotBoundingBox :: BoundingBox v n -> BoundingBox v n + -- , poPlotPostProduction :: QDiagram b v n Any -> QDiagram b v n Any + } deriving Typeable + +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 b | a -> b where + {-# MINIMAL plotOptions #-} + -- | Lens onto the 'PlotOptions'. + 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. + -- + -- 'Default' is 'mempty'. + plotName :: Functor f => LensLike' f a Name + plotName = plotOptions . lens poName (\g a -> g {poName = a}) + {-# INLINE plotName #-} + + -- | Whether the plot should be clipped to the bounds of the axes. + -- + -- 'Default' is 'True'. + clipPlot :: Functor f => LensLike' f a Bool + clipPlot = plotOptions . lens poClipPlot (\g a -> g {poClipPlot = a}) + {-# INLINE clipPlot #-} + + -- | The legend entries to be used for the current plot. + -- + -- 'Default' is 'mempty'. + legendEntries :: Functor f => LensLike' f a [LegendEntry b (V a) (N a)] + legendEntries = plotOptions . lens poLegend (\g a -> g {poLegend = a}) + {-# INLINE legendEntries #-} + + -- | The transform applied to the plot once it's in the axis + -- coordinates. + -- + -- 'Default' is 'mempty'. + plotTransform :: Functor f => LensLike' f a (Transformation (V a) (N a)) + plotTransform = plotOptions . lens poTransform (\g a -> g {poTransform = a}) + {-# INLINE plotTransform #-} + + -- | Whether or not the plot should be shown. The 'BoundingBox' of the + -- plot will still affect the inferred axis bounds. + -- + -- 'Default' is 'True'. + plotVisible :: Functor f => LensLike' f a Bool + plotVisible = plotOptions . lens poVisible (\po b -> po {poVisible = b}) + {-# INLINE plotVisible #-} + +instance (Additive v, Num n) => Default (PlotOptions b v n) where + def = PlotOptions + { poName = mempty + , poClipPlot = True + , poLegend = [] + , poVisible = True + , poTransform = mempty + -- , poPostPlotBoundingBox = id + -- , poPlotPostProduction = id + } + +instance HasPlotOptions f (PlotOptions b v n) b where + plotOptions = id + {-# INLINE plotOptions #-} + +instance (HasLinearMap v, Num n) => Transformable (PlotOptions b v n) where + transform = over plotTransform . transform + +-- instance HasBounds (PlotOptions b v n) v where +-- bounds = plotBounds + +-- | Move origin by applying to @plotTransform@. +instance (Additive v, Num n) => HasOrigin (PlotOptions b v n) where + moveOriginTo = over plotTransform . moveOriginTo + +instance Qualifiable (PlotOptions b v n) where + n .>> p = over plotName (n .>>) p + +-- XXX template haskell getting in the way +-- instance HasVisibility (PlotOptions b v n) where +-- visible = plotVisible + +-- | Add a 'LegendEntry' to something with 'PlotOptions' using the +-- 'String' as the 'legendText' and a 'DefaultLegendPic'. Here are +-- some typical examples: +-- +-- @ +-- '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 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' 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 b, MonadState a m) + => LegendEntry b (V a) (N a) + -> m () +addLegendEntry l = legendEntries <>= [l] + +-- zeroInt :: Additive v => v Int +-- zeroInt = zero + +------------------------------------------------------------------------ +-- AxisSpec +------------------------------------------------------------------------ + +-- | Information from the 'Plots.Axis.Axis' necessary to render a 'Plotable'. +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 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. +scaleNum :: Floating n => (n, n) -> LogScale -> n -> n +scaleNum (a,b) s x = case s of + LinearAxis -> x + LogAxis -> subtract a $ (b / logBase 10 d) * (logBase 10 x) + where d = b - a + +-- | Apply log scaling and the transform to a point. +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 + +------------------------------------------------------------------------ +-- Plotable class +------------------------------------------------------------------------ + +-- | Class defining how plots should be rendered. +class (Typeable p, Enveloped p) => Plotable p b where + -- | Render a plot according to the 'AxisSpec', using the 'PlotStyle'. + renderPlotable + :: InSpace v n p + => AxisSpec v n + -> PlotStyle b v n + -> p + -> QDiagram b v n Any + + -- | The default legend picture when the 'LegendPic' is + -- 'DefaultLegendPic'. + defLegendPic + :: InSpace v n p + => PlotStyle b v n + -> p + -> QDiagram b v n Any + defLegendPic = mempty + +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) + +instance (TypeableFloat n, Renderable (Path V2 n) b) => Plotable (Path V2 n) b where + renderPlotable s sty path + = stroke path + # transform (s^.specTrans) + # applyLineStyle sty + + defLegendPic sty _ + = (p2 (-10,0) ~~ p2 (10,0)) + # applyLineStyle sty + +------------------------------------------------------------------------ +-- Visibility +------------------------------------------------------------------------ + +-- | Class of objects that can be hidden. +class HasVisibility a where + -- | Lens onto whether an object should be visible when rendered. + visible :: Lens' a Bool + + -- | The opposite of 'visible'. + hidden :: Lens' a Bool + hidden = visible . involuted not + {-# INLINE hidden #-} + +instance HasVisibility (PlotOptions b v n) where + visible = plotVisible + +instance HasVisibility (PlotMods b v n) where + visible = plotVisible + +instance HasVisibility (Plot p b) where + visible = plotVisible + +instance HasVisibility (DynamicPlot b v n) where + visible = plotVisible + +instance HasVisibility (StyledPlot b v n) where + visible = plotVisible + +-- | Set 'visible' to 'False' for the given setter. +-- +-- @ +-- '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 + +-- | Set 'visible' to 'True' for the given setter. +-- +-- @ +-- '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 + +------------------------------------------------------------------------ +-- Plot modification +------------------------------------------------------------------------ + +-- | A 'PlotOptions' with modifications to a 'PlotStyle'. +data PlotMods b v n + = PlotMods (PlotOptions b v n) (PlotStyle b v n -> PlotStyle b v n) + +type instance V (PlotMods b v n) = v +type instance N (PlotMods b v n) = n + +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 b v n) b where + plotStyle = sty . mapped where + sty f (PlotMods opts s) = f s <&> \s' -> PlotMods opts s' + +instance (Additive v, Num n) => Default (PlotMods b v n) where + def = PlotMods def id + +------------------------------------------------------------------------ +-- Plot type +------------------------------------------------------------------------ + +-- | A parameterised plot, together with a 'PlotMods'. This type has an +-- instance of many classes for modifying specific plots. +data Plot p b = + Plot 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 b) = V p +type instance N (Plot p b) = N p + +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 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 b) where + orientation = rawPlot . orientation + +-- | Make a 'Plot' with 'Default' 'PlotOptions'. +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 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 b) (PlotMods b (V p) (N p)) +plotMods f (Plot p opts ps) = + f (PlotMods opts ps) <&> \(PlotMods opts' ps') -> Plot p opts' ps' + +------------------------------------------------------------------------ +-- DynamicPlot +------------------------------------------------------------------------ + +-- | A wrapped up 'Plot', used to store plots in an 'Axis'. +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 b v n) = v +type instance N (DynamicPlot b v n) = n + +-- | Prism for a 'DynamicPlot'. +_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 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 b) + eq _ = eqT +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 b v n) b where + plotStyle = sty . mapped where + 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 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') + +------------------------------------------------------------------------ +-- StyledPlot +------------------------------------------------------------------------ + +-- | A 'DynamicPlot' with a concrete style. This is suitable for being +-- rendered with 'renderStyledPlot' and get extract the legend entries +-- with 'styledPlotLegend'. +-- +-- You can make a 'StyledPlot' with 'styleDynamic' +data StyledPlot b v n where + StyledPlot + :: Plotable p b + => p + -> PlotOptions b (V p) (N p) + -> PlotStyle b (V p) (N p) + -> StyledPlot b (V p) (N p) + +type instance V (StyledPlot b v n) = v +type instance N (StyledPlot b v n) = n + +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 (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 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 succesful. +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 + Nothing -> pure s + where eq :: Typeable a => a -> Maybe (a :~: p) + eq _ = eqT + +-- | Give a 'DynamicPlot' a concrete 'PlotStyle'. +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 + :: 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) phantom + & whenever (opts^.clipPlot) (clipTo $ specRect aSpec) + +specRect :: TypeableFloat n => AxisSpec V2 n -> Path V2 n +specRect aSpec = + rect (xU - xL) (yU - yL) + # moveTo (mkP2 ((xU+xL)/2) ((yU+yL)/2)) + # transform t + where + V2 (xL,xU) (yL,yU) = _specBounds aSpec + t = _specTrans aSpec + +-- | Get the legend rendered entries from a single styled plot. The +-- resulting entries are in no particular order. See also +-- 'styledPlotLegends'. +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 + mk entry = (entry ^. legendPrecedence, pic, entry ^. legendText) + where + pic = case lPic entry of + DefaultLegendPic -> defLegendPic sty p + CustomLegendPic f -> f sty + +-- | Render a list of legend entries, in order. +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) + . concatMap singleStyledPlotLegend + diff --git a/src/Plots/Types/Bar.hs b/src/Plots/Types/Bar.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Types/Bar.hs @@ -0,0 +1,658 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types.Bar +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- A bar plot is a plot that presents data with rectangular bars with +-- lengths proportional to the values that they represent. The bars can +-- be plotted vertically or horizontally. +-- +-- <> +-- +---------------------------------------------------------------------------- +module Plots.Types.Bar + ( + -- * BarPlot + BarPlot + , barPlot + , barPlot' + , namedBarPlot + , namedBarPlot' + , floatingBarPlot + + -- * Bar layout + , BarLayout + , HasBarLayout (..) + + -- * Multi bars + -- ** Adding to axis + , multiBars + , MultiBarState + + -- ** Multi bar types + , groupedBars + , groupedBars' + , stackedBars + , stackedEqualBars + , runningBars + + -- ** Modify multi bars + , onBars + , labelBars + + + -- * Low level constructors + , mkBars + , mkFloatingBars + , mkRunningBars + , mkStackedBars + , mkStackedEqualBars + , mkGroupedBars + -- , barAxisLabels + + ) where + +import Control.Lens hiding (at, none, transform, ( # )) +import Control.Monad.State +import Data.Typeable +import qualified Data.Foldable as F + +import Plots.Style +import Plots.Types +import Plots.Axis +import Plots.Axis.Ticks +import Plots.Axis.Labels +import Plots.Util + +import qualified Data.List as List +import Diagrams.Core.Transform (fromSymmetric) +import Linear.V2 (_yx) + +import Diagrams.Prelude + +-- Single bar ---------------------------------------------------------- + +-- | Data for a single bar. The bar is drawn as +-- +-- @ +-- fromCorners (V2 barPos (fst barBounds))) (V2 (barPos + barWidth) (snd barBounds)) +-- @ +-- +-- for 'Horizontal' bars, flipped for 'Vertical'. This is a low level +-- 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, TrailLike t) => Point V2 n -> V2 n -> t +rectB p (V2 x y) = + trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p .-^ V2 (x/2) 0 + +------------------------------------------------------------------------ +-- Bar layout +------------------------------------------------------------------------ + +-- | The way an individual bar plot or a group of bars plots are laid +-- out on the axis. +data BarLayout n = BarLayout + { bOrient :: Orientation + , bWidth :: n + , bSpacing :: n + , bStart :: n + } deriving Typeable + +instance Fractional n => Default (BarLayout n) where + def = BarLayout Horizontal 0.8 1 1 + +type instance N (BarLayout n) = n + +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 (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 (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 (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 (N a) + barStart = barLayout . lens bStart (\bl x -> bl {bStart = x}) + +instance HasBarLayout (BarLayout n) where + barLayout = id + +instance HasBarLayout a => HasBarLayout (Plot a b) where + barLayout = rawPlot . barLayout + +------------------------------------------------------------------------ +-- Bar plot type +------------------------------------------------------------------------ + +-- | A bar plot for a single set of bars. Multi-bar plots are achieved +-- by having multiple 'BarPlot's. Each bar plot corresponds to a +-- single legend entry. To get multiple bar entries/colours, use +-- multiple 'BarPlots' + +-- A 'BarPlot' is not intended to be constructed directly, instead use +-- one of the helper functions. +data BarPlot n = BarPlot + { bpData :: [(n,n)] + , bpLayout :: BarLayout n + } deriving Typeable + +type instance V (BarPlot n) = V2 +type instance N (BarPlot n) = n + +instance HasOrientation (BarPlot n) where + orientation = barLayout . orientation + +instance OrderedField n => Enveloped (BarPlot n) where + getEnvelope BarPlot {..} = + getEnvelope . orient bpLayout _reflectXY id . (id :: Path v n -> Path v n) $ + ifoldMap drawBar bpData + where + 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 (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (BarPlot n) b where + renderPlotable s sty BarPlot {..} = + ifoldMap drawBar bpData + # orient bpLayout _reflectXY id + # applyAreaStyle sty + # transform (s^.specTrans) + where + drawBar i (a,b) = rectB (mkP2 x a) (V2 (view barWidth bpLayout) (b - a)) + where x = view barStart bpLayout + fromIntegral i * view barSpacing bpLayout + + defLegendPic sty BarPlot {..} + = centerXY + . applyAreaStyle sty' + . orient bpLayout _reflectXY id + $ d + where + -- Multiple bars get two bars next to each other for the legend. A + -- single bar only gets one bar in the legend. + d | has (ix 1) bpData = alignB (rect 4 7) ||| strutX 3 ||| alignB (rect 4 10) + | 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 %~ atMost (local 0.8) + +instance HasBarLayout (BarPlot n) where + barLayout = lens bpLayout (\bp l -> bp {bpLayout = l}) + +------------------------------------------------------------------------ +-- Constructing bar plots +------------------------------------------------------------------------ + +-- | Create equidistant bars using the values. +mkBars :: (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 :: Foldable f => BarLayout n -> f (n,n) -> BarPlot n +mkFloatingBars bl (F.toList -> ns) = BarPlot + { bpData = ns + , bpLayout = bl + } + +-- | Create uniform bars from groups of data, placing one group after +-- the other. +mkRunningBars + :: 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) + where dx = view barSpacing bl * fromIntegral (length d) + +-- | Create uniform bars from groups of data, placing one on top of the +-- other. The first list will be the same as @mkUniformBars opts (map +-- (0,) ys)@, subsequent lists will be placed on top. +mkStackedBars + :: 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 + -- for each set of data + f y0s ys = (y1s, mkFloatingBars bl ds) + where y1s = liftU2 (+) y0s ys + ds = zipWith (\y0 y -> (y0, y0 + y)) y0s ys + +-- | Similar to 'mkMultiStacked' but stack has the same height. +mkStackedEqualBars + :: 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. + ms = map (\ys -> yM / sum ys) $ List.transpose yss + + -- Normalise each data set by multiplying it with the normalising + -- factor. + yss' = map (zipWith (*) ms) yss + +-- | Make bars that are grouped together. Each group of bars is treated +-- as a single bar when using the 'BarPlotsOpts'. There is an addition +-- parameter to adjust the width of each individual bar. +mkGroupedBars + :: 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 + bl { bStart = start' + width' * fromIntegral i + , bWidth = width' * w + } + ns + where + n = fromIntegral $ length xs + -- start' is such that middle of the middle bar is now at + -- barOptsStart bo + start' = bStart bl - (n - 1) * width' / 2 + width' = bWidth bl / n + +-- temporary functions that will be in next lib release + +_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, Transformable t) => t -> t +_reflectXY = transform _reflectionXY + +---------------------------------------------------------------------------------- +-- Single bar state API +---------------------------------------------------------------------------------- + +-- | A add 'BarPlot' to an 'Axis'. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > barAxis :: Axis B V2 Double +-- > barAxis = r2Axis &~ do +-- > yMin ?= 0 +-- > hide majorGridLines +-- > barPlot [13.5, 3.0, 6.9, 7.2, 4.6] $ do +-- > vertical .= True +-- > barWidth //= 2 +-- +-- > barExample = renderAxis barAxis +barPlot + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + 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) + +-- | Simple version of 'barPlot' without any modification to the 'Plot'. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > barAxis' :: Axis B V2 Double +-- > barAxis' = r2Axis &~ do +-- > xMin ?= 0 +-- > hide (yAxis . majorGridLines) +-- > barPlot' [13.5, 3.0, 6.9, 7.2, 4.6] +-- +-- > barExample' = renderAxis barAxis' +barPlot' + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + 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. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > namedBarAxis :: Axis B V2 Double +-- > namedBarAxis = r2Axis &~ do +-- > yMin ?= 0 +-- > hide (xAxis . majorGridLines) +-- > namedBarPlot [("eggs", 12), ("bacon", 5), ("sausage", 9), ("beans", 3)] $ do +-- > vertical .= True +-- > barWidth //= 2 +-- > +-- > namedBarExample = renderAxis namedBarAxis +namedBarPlot + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + 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 + barLayoutAxisLabels (bp ^. barLayout) nms + where + (nms, xs) = unzip $ F.toList d + bp = mkPlot (mkBars def xs) & execState s + +-- | Simple version of 'namedBarPlot' without any modification to the 'Plot'. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > namedBarAxis' :: Axis B V2 Double +-- > namedBarAxis' = r2Axis &~ do +-- > xMin ?= 0 +-- > hide majorGridLines +-- > namedBarPlot' [("eggs", 12), ("bacon", 5), ("sausage", 9), ("beans", 3)] +-- +-- > namedBarExample' = renderAxis namedBarAxis' +namedBarPlot' + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + 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 b V2 n) m, + Plotable (BarPlot n) b, + Foldable f) + => f (n,n) -- ^ bar limits + -> State (Plot (BarPlot n) b) () -- ^ changes to the bars + -> m () +floatingBarPlot ns = addPlotable (mkFloatingBars def ns) + +------------------------------------------------------------------------ +-- Multi bar state API +------------------------------------------------------------------------ + +-- Multi bar state ----------------------------------------------------- + +-- | The 'MultiBarState' is used to set the various options available +-- when building multiple bar plots together. The main functions used +-- to modify this state: +-- +-- * To choose the way the bars are grouped together choose one of +-- +-- * 'groupedBars' - Together in grouped (the default) +-- * 'stackedBars' - On on top of another +-- * 'stackedEqualBars' - 'stackedBars' with the same height +-- * 'runningBars' - each group of bars follows the last +-- +-- * Modify the 'PlotOptions' and 'PlotStyle' of groups of bars with +-- 'onBars'. +-- +-- * Modify the layout of the (groups of) bars with +-- +-- * 'orientation' - Horizontal or vertical bars +-- * 'barWidth' - Width of each (group of) bar(s) +-- * 'barSpacing' - Space between each (group of) bar(s) +-- * 'barStart' - Start of centre of first bar +-- +-- * Add labels to each (group of) bars with 'labelBars'. +-- +data MultiBarState b n a = MultiBarState + { mbsLayout :: BarLayout n + -- ^ options for building bar plots + + , 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 n -> [[n]] -> [BarPlot n] + -- ^ function used to build bar plots + } + +type instance N (MultiBarState b n a) = n + +instance HasOrientation (MultiBarState b n a) where + orientation = barLayout . orientation + +instance HasBarLayout (MultiBarState b n a) where + barLayout = lens mbsLayout (\mbs l -> mbs {mbsLayout = l}) + +-- > import Plots +-- +-- > groupedExample s = r2Axis &~ do +-- > yMin ?= 0 +-- > hide (xAxis . majorGridLines) +-- > xLabel .= "breakfast item" +-- > hide minorTicks +-- > multiBars sortedData snd $ do +-- > vertical .= True +-- > barWidth //= 2 +-- > labelBars (map fst breakfastData) +-- > onBars $ \(nm,_) -> key nm +-- > s +-- > +-- > -- show y values without decimal point +-- > yAxis . tickLabelFunction .= atMajorTicks (show . round) +-- > -- we should really force all major ticks to like on integers too +-- +-- > groupedBarsExample = renderAxis $ groupedExample groupedBars +-- > groupedBarsExample' = renderAxis $ groupedExample (groupedBars' 0.7) +-- > stackedBarsExample = renderAxis $ groupedExample stackedBars +-- > stackedEqualBarsExample = renderAxis $ groupedExample (stackedEqualBars 10) +-- > runningBarsExample = renderAxis $ groupedExample $ do +-- > runningBars +-- > labelBars (map fst breakfastData ++ map fst breakfastData) + +-- Adding to axis ------------------------------------------------------ + +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 +-- 'barWidth'. The bars in a group are touching, see groupedBars' to +-- reduce the width of individual bars. +-- +-- === __Example__ +-- +-- <> + +groupedBars :: Fractional n => State (MultiBarState b n a) () +groupedBars = groupedBars' 1 + +-- | Bars that are grouped together such that each group is a single +-- 'barWidth'. The parameter is the multiplier for the width of +-- individual bars, where @'groupedBars' 1 = groupedBars@ corresponds +-- to bars in a group touching. reduce the width of individual bars. +-- +-- === __Example__ +-- +-- <> +-- +groupedBars' :: Fractional n => n -> State (MultiBarState b n a) () +groupedBars' n = multiFun .= mkGroupedBars n + +-- | Bars stacked on top of each other. +-- +-- === __Example__ +-- +-- <> +-- +stackedBars :: Num n => State (MultiBarState b n a) () +stackedBars = multiFun .= mkStackedBars + +-- | Bars stacked on top of each other where every bar is the given +-- height. +-- +-- +-- === __Example__ +-- +-- <> +-- +stackedEqualBars :: Fractional n => n -> State (MultiBarState b n a) () +stackedEqualBars n = multiFun .= mkStackedEqualBars n + +-- | Normal 'bars' where each data set follows the last. +-- +-- === __Example__ +-- +-- <> +-- +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 +-- details on how to customise how the bars are drawn. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > breakfastData :: [(String, V2 Double)] +-- > breakfastData = [("eggs", V2 7 5), ("bacon", V2 5 4), ("sausage", V2 2 7), ("beans", V2 2 1)] +-- +-- > sortedData = [ ("girls", breakfastData^..each._2._x) +-- > , ("boys", breakfastData^..each._2._y) +-- > ] +-- +-- > multiBarAxis :: Axis B V2 Double +-- > multiBarAxis = r2Axis &~ do +-- > yMin ?= 0 +-- > hide (xAxis . majorGridLines) +-- > hide minorTicks +-- > xLabel .= "breakfast item" +-- > multiBars sortedData snd $ do +-- > vertical .= True +-- > barWidth //= 2 +-- > labelBars (map fst breakfastData) +-- > onBars $ \(nm,_) -> key nm +-- > +-- > -- show y values without decimal point +-- > yAxis . tickLabelFunction .= atMajorTicks (show . round) +-- > -- we should really force all major ticks to like on integers too +-- +-- > multiBarExample = renderAxis multiBarAxis +multiBars + :: (MonadState (Axis b V2 n) m, + Plotable (BarPlot n) b, + Foldable f, + Foldable g) + => f a -- ^ data for multi 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 + F.forM_ propertiedBars $ \(b,endo) -> + addPlotable b $ plotMods %= appEndo endo + + -- label bars on axis if necessary + barLayoutAxisLabels (bs ^. barLayout) (bs ^. labels) + where + -- bars + propertiedBars = zip barPlots endos + barPlots = mbsBarFun bs (bs ^. barLayout) $ map (F.toList . f) as + + -- data and modifiers + endos = mbsMods bs ^.. each . _2 + + -- bar state + bs = execState st bs0 + bs0 = MultiBarState + { mbsLayout = def + , mbsMods = map (\a -> (a, mempty)) as + , mbsLabels = [] + , mbsBarFun = mkGroupedBars 1 + } + +-- | Place labels under the centre of each bar using the 'BarLayout' by +-- changing that 'axisTickLabels', using the provided string in order. +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 + majorTickPositions .= xs + minorTicks . visible .= False + tickLabelPositions .= zip xs ls + where + xs = map ((+ view barStart bl) . (* view barSpacing bl) . fromIntegral) + [0 .. length ls - 1] + +-- | Given the data for the bar, modify the properties for the bar that +-- uses that data. +-- +-- Some common functions to use on the 'PlotMods': +-- +-- * 'plotColour' - change the colour of the bars +-- +-- * 'areaStyle' - modify the style of the bars +-- +-- * 'key' - add a legend entry for that group of bars +-- +onBars + :: (a -> State (PlotMods b V2 n) ()) + -- ^ Modifier the 'PlotOptions' and 'PlotStyle' for the bars + -- associated with the data from @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))) + where mods = lens mbsMods (\bs d -> bs {mbsMods = d}) + +class HasLabels a where + labels :: Lens' a [String] + +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. +labelBars :: HasLabels a => [String] -> State a () +labelBars xs = labels .= xs diff --git a/src/Plots/Types/HeatMap.hs b/src/Plots/Types/HeatMap.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Types/HeatMap.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types.HeatMap +-- Copyright : (C) 2016 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- A heat map is a graphical representation of data where the individual +-- values contained in a matrix are represented as colours. +-- +-- <> +-- +---------------------------------------------------------------------------- + +module Plots.Types.HeatMap + ( -- * Heat map + HeatMap + , heatMap + , heatMap' + , heatMapIndexed + , heatMapIndexed' + + -- * Lenses + , HasHeatMap (..) + + -- ** Rendering functions + , pathHeatRender + , pixelHeatRender + , pixelHeatRender' + + -- * Heat matrix + , HeatMatrix + , heatImage + , hmPoints + , hmSize + + -- * Low level construction + , mkHeatMap + , mkHeatMatrix + , mkHeatMatrix' + + ) where + +import Control.Lens hiding (transform, ( # )) +import qualified Data.Colour as C + +import Control.Monad.ST +import Control.Monad.State +import qualified Data.Foldable as F +import Data.Typeable +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Unboxed as V +import Data.Word (Word8) +import Statistics.Function (minMax) + +import Codec.Picture +import Diagrams.Coordinates.Isomorphic +import Diagrams.Prelude + +import Plots.Axis +import Plots.Style +import Plots.Types + +------------------------------------------------------------------------ +-- Heatmap +------------------------------------------------------------------------ + +-- | 2D Array of 'Double's. +data HeatMatrix = HeatMatrix + { hmSize :: {-# UNPACK #-} !(V2 Int) + -- ^ The size of heat matrix. + , _hmVector :: {-# UNPACK #-} !(Vector Double) + , hmBoundLower :: {-# UNPACK #-} !Double + , hmBoundUpper :: {-# UNPACK #-} !Double + } + +-- | Construct a heat matrix from a size and a generating function. +mkHeatMatrix :: V2 Int -> (V2 Int -> Double) -> HeatMatrix +mkHeatMatrix s@(V2 x y) f = runST $ do + mv <- M.new (x*y) + + let go !q !a !b !i !j + | j == y = do v <- V.unsafeFreeze mv + return (HeatMatrix s v a b) + | i == x = go q a b 0 (j + 1) + | otherwise = do let !d = f (V2 i j) + M.unsafeWrite mv q d + go (q + 1) (min a d) (max b d) (i + 1) j + + go 0 (1/0) (-1/0) 0 0 +{-# INLINE mkHeatMatrix #-} + +-- | Construct a heat matrix from a foldable of foldables. +-- +-- @ +-- 'mkHeatMatrix'' :: [['Double']] -> 'HeatMatrix' +-- 'mkHeatMatrix'' :: ['Vector' 'Double'] -> 'HeatMatrix' +-- @ +mkHeatMatrix' :: (Foldable f, Foldable g) => f (g Double) -> HeatMatrix +mkHeatMatrix' xss = HeatMatrix (V2 x y) vd a b + where + (a,b) = minMax vd + vd = V.create $ do + mv <- M.new (x*y) + let go !_ [] = return mv + go j (r:rs) = V.unsafeCopy (M.unsafeSlice (j*x) x mv) r >> go (j-1) rs + go (y - 1) vs + -- vs is in reverse since we used foldl' to build it + (!x,!y,!vs) = F.foldl' f (maxBound,0,[]) xss + f (!i,!j,!ss) xs = let !v = V.fromList (F.toList xs) + in (min i (V.length v), j+1, v : ss) + +-- | Indexed traversal over the values of a 'HeatMatrix'. +hmPoints :: IndexedTraversal' (V2 Int) HeatMatrix Double +hmPoints f (HeatMatrix e@(V2 x y) v a b) = + go 0 0 0 <&> \vs -> + let v'= V.fromListN (x*y) vs + in HeatMatrix e v' a b + where + -- V2 x y = hmExtent + go !s !i !j + | i >= x = go s 0 (j+1) + | j >= y = pure [] + | otherwise = (:) <$> indexed f (V2 i j) (V.unsafeIndex v s) + <*> go (s+1) (i+1) j +{-# INLINE [0] hmPoints #-} + +{-# RULES + "hmPoints/foldr" + hmPoints = ifoldring hmFold :: Getting (Endo r) HeatMatrix Double; + "hmPoints/ifoldr" + hmPoints = ifoldring hmFold :: IndexedGetting (V2 Int) (Endo r) HeatMatrix Double + #-} + +hmFold :: (V2 Int -> Double -> b -> b) -> b -> HeatMatrix -> b +hmFold f b0 (HeatMatrix (V2 x y) v _ _) = go 0 0 0 b0 where + go !s !i !j b + | i >= x = go s 0 (j+1) b + | j >= y = b + | otherwise = f (V2 i j) (V.unsafeIndex v s) (go (s+1) (i+1) j b) +{-# INLINE hmFold #-} + +-- Rendering heat matrices -------------------------------------------- + +-- | Render an heatmap as an 'ImageRGB8'. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > pixelHeatRenderExample = +-- > let f (V2 x y) = fromIntegral x + fromIntegral y +-- > myHM = mkHeatMatrix (V2 5 5) f +-- > in pixelHeatRender myHM viridis +-- +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 + V2 x y = hmSize hm + +-- | Render an heatmap as an 'ImageRGB8' with @n@ pixels per heat matrix +-- point. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > pixelHeatRenderExample' = +-- > let f (V2 x y) = fromIntegral x + fromIntegral y +-- > myHM = mkHeatMatrix (V2 5 5) f +-- > in pixelHeatRender' 10 myHM viridis +-- +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 . image $ DImage (ImageRaster (ImageRGB8 img)) (x*n) (y*n) mempty + where + img = scaleImage n $ heatImage hm cm + V2 x y = hmSize hm + +-- | Scale an image so each pixel takes (n*n) pixels. This can be +-- usefull for using 'heatImage' on small heat matrixes to give a +-- sharper image. +scaleImage :: Int -> Image PixelRGB8 -> Image PixelRGB8 +scaleImage n img | n == 1 = img + | n == 0 = Image 0 0 S.empty + | n < 0 = error "scaleImage: negative scale" +scaleImage n (Image x y v) = Image (n*x) (n*y) vn where + !refV = V.fromList $ map (*3) [ i + n*x*j | i <- [0..n-1], j <- [0..n-1] ] + !n3 = 3*n + vn = S.create $ do + mv <- M.new (n * n * S.length v) + let go !q !i !s | q >= 3*x*y = return mv + | i == x = go q 0 (s + 3*x*n*(n-1)) + go q i s = do + let !r = S.unsafeIndex v q + !g = S.unsafeIndex v (q+1) + !b = S.unsafeIndex v (q+2) + V.forM_ refV $ \ds -> do + M.unsafeWrite mv (s + ds ) r + M.unsafeWrite mv (s + ds + 1) g + M.unsafeWrite mv (s + ds + 2) b + go (q+3) (i+1) (s+n3) + + go 0 0 0 + +-- | Create an image of 'PixelsRGB8' using the heat matrix. +heatImage :: HeatMatrix -> ColourMap -> Image PixelRGB8 +heatImage (HeatMatrix (V2 x y) dv a b) cm = Image x y v' where + !cv = mkColourVector cm + + -- PixelRGB8 doesn't have an unboxed instance so we have to write each + -- component manually. + v' = S.create $ do + mv <- M.new (3 * x * y) + let !m = 256 / (b - a) + go s i q + | s == x-1 = do -- return mv + let !d = V.unsafeIndex dv s + let !o = 3 * (min 255 . max 0 . round $ (d - a) * m) + M.unsafeWrite mv q (V.unsafeIndex cv o ) + M.unsafeWrite mv (q+1) (V.unsafeIndex cv (o+1)) + M.unsafeWrite mv (q+2) (V.unsafeIndex cv (o+2)) + return mv + -- go (s+1) (i+1) (q+3) + | i == x = go (s - 2*x) 0 q + | otherwise = do + let !d = V.unsafeIndex dv s + let !o = 3 * (min 255 . max 0 . round $ (d - a) * m) + M.unsafeWrite mv q (V.unsafeIndex cv o ) + M.unsafeWrite mv (q+1) (V.unsafeIndex cv (o+1)) + M.unsafeWrite mv (q+2) (V.unsafeIndex cv (o+2)) + go (s+1) (i+1) (q+3) + go (x * (y-1)) 0 0 + +-- Make an unboxed colour map using 256 samples. +mkColourVector :: ColourMap -> Vector Word8 +mkColourVector cm = V.create $ do + mv <- M.new (3*256) + + let go i | i == 3*256 = return mv + | otherwise = do + let PixelRGB8 r g b = cm ^. ixColour (fromIntegral i / (3*256)) + . to colourToPixel + M.unsafeWrite mv i r + M.unsafeWrite mv (i+1) g + M.unsafeWrite mv (i+2) b + go (i+3) + + go 0 + +colourToPixel :: AlphaColour Double -> PixelRGB8 +colourToPixel c = PixelRGB8 r g b + where RGB r g b = toSRGB24 (c `C.over` black) + +-- | Render the heat map as a collection squares made up of 'Trail's. +-- This method is compatible with all backends and should always look +-- sharp. However it can become slow and large for large heat maps. +-- +-- It is recommended to use 'pathHeatRender' for small heat maps and +-- 'pixelHeatRender' for larger ones. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > +-- > pathHeatRenderExample = +-- > let f (V2 x y) = fromIntegral x + fromIntegral y +-- > myHM = mkHeatMatrix (V2 5 5) f +-- > in pathHeatRender myHM viridis +-- +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 = toRational $ (d - a) / (b - a) + mk v@(V2 i j) d = + rect w h + # alignTR + # translate (fromIntegral <$> v ^+^ 1) + # fcA (cm ^. ixColour (normalise d)) + where + -- Squares that are not on the top left edge are slightly + -- bigger to remove phantom gaps + w | i == 0 = 1 + | otherwise = 1.5 + h | j == 0 = 1 + | otherwise = 1.5 + +------------------------------------------------------------------------ +-- Heat matrix +------------------------------------------------------------------------ + +-- | A mapping from points in a 2D axis do 'Double's. These 'Double's +-- are converted to colours using the axis 'ColourMap'. +data HeatMap b n = HeatMap + { hMatrix :: HeatMatrix + , hStart :: P2 n + , hSize :: V2 n + , hGridSty :: Style V2 n + , hGridVisible :: Bool + , hLimits :: Maybe (Double,Double) + , hDraw :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any + } deriving Typeable + +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 b | a -> b where + -- | Lens onto the heatmap options. + heatMapOptions :: LensLike' f a (HeatMap b (N a)) + + -- | Whether there should be grid lines draw for the heat map. + -- + -- Default is 'False'. + heatMapGridVisible :: Functor f => LensLike' f a Bool + heatMapGridVisible = heatMapOptions . lens hGridVisible (\s b -> (s {hGridVisible = b})) + + -- | The style applied to the grid lines for the heat map, if they're + -- visible. + -- + -- Default is 'mempty'. + 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 (N a)) + heatMapSize = heatMapOptions . lens hSize (\s b -> (s {hSize = b})) + + -- | The size of the full extend of the heat map. + -- + -- Default is extent of the heat matrix. + 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) + + -- | The starting point at the bottom left corner of the heat map. + -- + -- Default is 'origin' + 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, 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 + + -- | Limits @(a,b)@ used on the data such that @a@ is the start of the + -- 'ColourMap' and @b@ is the end of the 'ColourMap'. Default is @(0,1)@. + heatMapLimits :: Functor f => LensLike' f a (Maybe (Double, Double)) + heatMapLimits = heatMapOptions . lens hLimits (\s b -> (s {hLimits = b})) + + -- | Funtion used to render the heat map. See 'pathHeatRender' and + -- 'pixelHeatRender'. + -- + -- Default is 'pathHeatRender'. + 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 b n) b where + heatMapOptions = id + +instance (Functor f, HasHeatMap f a b) => HasHeatMap f (Plot a b) b where + heatMapOptions = rawPlot . heatMapOptions + +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 (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) + # transform (scaleV hSize) + # moveTo hStart + where + --- 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 {..} = square 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 :: (Renderable (Path V2 n) b, TypeableFloat n) + => HeatMatrix -> HeatMap b n +mkHeatMap mat = HeatMap + { hMatrix = mat + , hStart = origin + , hSize = V2 1 1 + , hGridSty = mempty + , hGridVisible = False + , hLimits = Nothing + , hDraw = pathHeatRender + } + +-- Adding to axis ------------------------------------------------------ + +-- | Add a 'HeatMap' plot using the extent of the heatmap and a +-- generating function. +-- +-- @ +-- 'heatMap' :: [['Double']] -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) () +-- @ +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > heatMapAxis :: Axis B V2 Double +-- > heatMapAxis = r2Axis &~ do +-- > display colourBar +-- > axisExtend .= noExtend +-- > +-- > let xs = [[1,2,3],[4,5,6]] +-- > heatMap xs $ heatMapSize .= V2 10 10 +-- +-- > heatMapExample = renderAxis heatMapAxis +-- +heatMap + :: (Foldable f, + Foldable g, + TypeableFloat n, + Typeable b, + MonadState (Axis b V2 n) m, + Renderable (Path V2 n) b) + => f (g Double) + -> State (Plot (HeatMap b n) b) () + -- ^ changes to plot options + -> m () -- ^ add plot to 'Axis' +heatMap xss s = do + let hm@(HeatMatrix _ _ a b) = mkHeatMatrix' xss + addPlotable (mkHeatMap 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. +-- +-- @ +-- 'heatMap'' :: [['Double']] -> 'State' ('Axis' b 'V2' n) () +-- @ +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > heatMapAxis' :: Axis B V2 Double +-- > heatMapAxis' = r2Axis &~ do +-- > display colourBar +-- > axisExtend .= noExtend +-- > axisColourMap .= Plots.magma +-- > +-- > let xs = [[1,2,3],[4,5,6]] +-- > heatMap' xs +-- +-- > heatMapExample' = renderAxis heatMapAxis' +-- +heatMap' + :: (Foldable f, + Foldable g, + 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 ()) + +-- | Add a 'HeatMap' plot using the extent of the heatmap and a +-- generating function. +-- +-- @ +-- 'heatMapIndexed' :: 'V2' 'Int' -> ('V2' 'Int' -> 'Double') -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) () +-- 'heatMapIndexed' :: ('Int', 'Int') -> (('Int', 'Int') -> 'Double') -> 'State' ('Plot' ('HeatMap' b n)) () -> 'State' ('Axis' b 'V2' n) () +-- @ +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > heatMapIndexedAxis :: Axis B V2 Double +-- > heatMapIndexedAxis = r2Axis &~ do +-- > display colourBar +-- > axisExtend .= noExtend +-- > +-- > let f (V2 x y) = fromIntegral x + fromIntegral y +-- > heatMapIndexed (V2 3 3) f $ heatMapSize .= V2 10 10 +-- +-- > heatMapIndexedExample = renderAxis heatMapIndexedAxis +-- +heatMapIndexed + :: (VectorLike V2 Int i, + 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 b n) b) () + -- ^ changes to plot options + -> m () -- ^ add plot to 'Axis' +heatMapIndexed i f s = do + let hm@(HeatMatrix _ _ a b) = mkHeatMatrix (view unvectorLike i) (f . view vectorLike) + addPlotable (mkHeatMap 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 without changes to the heap map options. +-- +-- @ +-- 'heatMapIndexed' :: 'V2' 'Int' -> ('V2' 'Int' -> 'Double') -> 'State' ('Axis' b 'V2' n) () +-- 'heatMapIndexed' :: ('Int', 'Int') -> (('Int', 'Int') -> 'Double') -> 'State' ('Axis' b 'V2' n) () +-- @ +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > heatMapIndexedAxis' :: Axis B V2 Double +-- > heatMapIndexedAxis' = r2Axis &~ do +-- > display colourBar +-- > axisExtend .= noExtend +-- > axisColourMap .= Plots.magma +-- > +-- > let f (V2 x y) = fromIntegral x + fromIntegral y +-- > heatMapIndexed' (V2 3 3) f +-- +-- > heatMapIndexedExample' = renderAxis heatMapIndexedAxis' +-- +heatMapIndexed' + :: (VectorLike V2 Int i, + 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 ()) + diff --git a/src/Plots/Types/Histogram.hs b/src/Plots/Types/Histogram.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Types/Histogram.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types.Histogram +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable + +-- A histogram is a graphical representation of the distribution of +-- numerical data. It is an estimate of the probability distribution of +-- a continuous variable. +-- +---------------------------------------------------------------------------- + +module Plots.Types.Histogram + ( + -- * Histogram plot + HistogramPlot + + -- ** Already computed histograms + , computedHistogram + + -- ** Histogram options + , HistogramOptions + , HasHistogramOptions (..) + + -- ** Normalisation + , NormalisationMethod + , count + , probability + , countDensity + , pdf + , cumilative + , cdf + + -- ** Plotting histograms + , histogramPlot + , histogramPlot' + , histogramPlotOf + , histogramPlotOf' + + -- * Low level constructors + , mkComputedHistogram + , mkHistogramPlot + ) where + +import Control.Monad.State.Lazy + +import qualified Data.Foldable as F +import Data.Function +import Data.Maybe +import Data.Typeable + +import qualified Data.Vector as V +import qualified Statistics.Sample.Histogram as Stat + +import Diagrams.Core.Transform (fromSymmetric) +import Diagrams.Prelude +import Linear.V2 (_yx) + +import Plots.Axis +import Plots.Style +import Plots.Types +import Plots.Util + + +-- | Construct a rectangle of size v with the bottom left at point p. +rectBL :: (InSpace V2 n t, TrailLike t) => Point V2 n -> V2 n -> t +rectBL p (V2 x y) = + trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p + +------------------------------------------------------------------------ +-- GHistogram plot +------------------------------------------------------------------------ + +-- | Simple histogram type supporting uniform bins. +data HistogramPlot n = HistogramPlot + { hWidth :: n + , hStart :: n + , hValues :: [n] + , hOrient :: Orientation + } deriving Typeable + +type instance V (HistogramPlot n) = V2 +type instance N (HistogramPlot n) = n + +instance OrderedField n => Enveloped (HistogramPlot n) where + getEnvelope HistogramPlot {..} = + -- don't like this reduntent 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 (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (HistogramPlot n) b where + renderPlotable s sty HistogramPlot {..} = + ifoldMap drawBar hValues + # orient hOrient _reflectXY id + # applyAreaStyle sty + # transform (s^.specTrans) + where + drawBar i h = rectBL (mkP2 x 0) (V2 hWidth h) + where x = hStart + fromIntegral i * hWidth + + defLegendPic sty HistogramPlot {..} + = centerXY + . applyAreaStyle sty' + . orient hOrient _reflectXY id + $ 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 %~ atMost (local 0.8) + +instance HasOrientation (HistogramPlot n) where + orientation = lens hOrient $ \hp o -> hp {hOrient = o} + +------------------------------------------------------------------------ +-- Simple histogram plot +------------------------------------------------------------------------ + +-- | Plot an already computed histogram with equally sized bins. +computedHistogram + :: (MonadState (Axis b V2 n) m, + Plotable (HistogramPlot n) b, + 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 + :: Foldable f + => 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 + +---------------------------------------------------------------------------- +-- Building histograms +---------------------------------------------------------------------------- + +-- example setup +-- > import Plots +-- > sampleData :: [Double] +-- > sampleData = +-- > [5.1,4.9,4.7,4.6,5.0,5.4,4.6,5.0,4.4,4.9 +-- > ,5.4,4.8,4.8,4.3,5.8,5.7,5.4,5.1,5.7,5.1 +-- > ,5.4,5.1,4.6,5.1,4.8,5.0,5.0,5.2,5.2,4.7 +-- > ,4.8,5.4,5.2,5.5,4.9,5.0,5.5,4.9,4.4,5.1 +-- > ,5.0,4.5,4.4,5.0,5.1,4.8,5.1,4.6,5.3,5.0 +-- > ,7.0,6.4,6.9,5.5,6.5,5.7,6.3,4.9,6.6,5.2 +-- > ,5.0,5.9,6.0,6.1,5.6,6.7,5.6,5.8,6.2,5.6 +-- > ,5.9,6.1,6.3,6.1,6.4,6.6,6.8,6.7,6.0,5.7 +-- > ,5.5,5.5,5.8,6.0,5.4,6.0,6.7,6.3,5.6,5.5 +-- > ,5.5,6.1,5.8,5.0,5.6,5.7,5.7,6.2,5.1,5.7 +-- > ,6.3,5.8,7.1,6.3,6.5,7.6,4.9,7.3,6.7,7.2 +-- > ,6.5,6.4,6.8,5.7,5.8,6.4,6.5,7.7,7.7,6.0 +-- > ,6.9,5.6,7.7,6.3,6.7,7.2,6.2,6.1,6.4,7.2 +-- > ,7.4,7.9,6.4,6.3,6.1,7.7,6.3,6.4,6.0,6.9 +-- > ,6.7,6.9,5.8,6.8,6.7,6.7,6.3,6.5,6.2,5.9 +-- > ] +-- +-- > mkNmExample nm = r2Axis &~ do +-- > yMin ?= 0 +-- > histogramPlot sampleData $ do +-- > normaliseSample .= nm +-- > countDia = renderAxis $ mkNmExample count +-- > probabilityDia = renderAxis $ mkNmExample probability +-- > countDensityDia = renderAxis $ mkNmExample countDensity +-- > pdfDia = renderAxis $ mkNmExample pdf +-- > cumilativeDia = renderAxis $ mkNmExample cumilative +-- > cdfDia = renderAxis $ mkNmExample cdf + +-- Histogram options --------------------------------------------------- + +-- | The way to normalise the data from a histogram. The default method +-- is 'count'. +newtype NormalisationMethod = + NM { runNM :: forall n. Fractional n => n -> V.Vector n -> V.Vector n } + -- width -> heights -> normalised heights + +instance Default NormalisationMethod where + def = count + +-- | The height of each bar is the number of observations. This is the +-- 'Default' method. +-- +-- === __Example__ +-- +-- <> +count :: NormalisationMethod +count = NM $ \_ v -> v + +-- | The sum of the heights of the bars is equal to 1. +-- +-- === __Example__ +-- +-- <> +probability :: NormalisationMethod +probability = NM $ \_ v -> v ^/ V.sum v + +-- | The height of each bar is @n / w@ where @n@ is the number of +-- observations and @w@ is the total width. +-- +-- === __Example__ +-- +-- <> +countDensity :: NormalisationMethod +countDensity = NM $ \w v -> v ^/ w + +-- | The total area of the bars is @1@. This gives a probability density +-- function estimate. +-- +-- === __Example__ +-- +-- <> +pdf :: NormalisationMethod +pdf = NM $ \w v -> v ^/ (w * V.sum v) + +-- | The height of each bar is the cumulative number of observations in +-- each bin and all previous bins. The height of the last bar is the +-- total number of observations. +-- +-- === __Example__ +-- +-- <> +cumilative :: NormalisationMethod +cumilative = NM $ \_ -> V.scanl1 (+) + +-- | Cumulative density function estimate. The height of each bar is +-- equal to the cumulative relative number of observations in the bin +-- and all previous bins. The height of the last bar is 1. +-- +-- === __Example__ +-- +-- <> +cdf :: NormalisationMethod +cdf = NM $ \_ v -> V.scanl1 (+) v ^/ V.sum v + +-- | Options for binning histogram data. For now only very basic +-- histograms building is supported. +data HistogramOptions n = HistogramOptions + { hBins :: Int + , hRange :: Maybe (n, n) + , hNorm :: NormalisationMethod + , oOrient :: Orientation + } + +type instance V (HistogramOptions n) = V2 +type instance N (HistogramOptions n) = n + +instance Default (HistogramOptions n) where + def = HistogramOptions + { hBins = 10 + , hRange = Nothing + , hNorm = def + , oOrient = Vertical + } + +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 (N a)) + + -- | The number of bins (bars) to use for the histogram. Must be + -- positive. + -- + -- 'Default' is @10@. + numBins :: Lens' a Int + numBins = histogramOptions . lens hBins (\ho n -> ho {hBins = n}) + + -- | The range of data to consider when building the histogram. Any + -- data outside the range is ignored. + -- + -- 'Default' is 'Nothing'. + 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 + -- 1. + -- + -- 'Default' is False. + normaliseSample :: Lens' a NormalisationMethod + normaliseSample = histogramOptions . lens hNorm (\ho b -> ho {hNorm = b}) + +instance HasHistogramOptions (HistogramOptions n) where + histogramOptions = id + +instance HasHistogramOptions a => HasHistogramOptions (Plot a b) where + histogramOptions = rawPlot . histogramOptions + +-- | Create a histogram by binning the data using the +-- 'HistogramOptions'. +mkHistogramPlot + :: (Foldable f, RealFrac n) + => HistogramOptions n -> f n -> HistogramPlot n +mkHistogramPlot HistogramOptions {..} xs = + HistogramPlot + { hWidth = w + , hStart = a + , hValues = V.toList $ runNM hNorm w ns + , hOrient = Vertical + } + where + w = (b - a) / fromIntegral hBins + ns = Stat.histogram_ hBins a b v + v = V.fromList (F.toList xs) + (a,b) = fromMaybe (range hBins v) hRange + +-- Taken from Statistics, which was limited to '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" + | lo == hi = case abs lo / 10 of + a | a < 1e-6 -> (-1,1) + | otherwise -> (lo - a, lo + a) + | otherwise = (lo-d, hi+d) + where + d | nBins == 1 = 0 + | otherwise = (hi - lo) / ((fromIntegral nBins - 1) * 2) + (lo,hi) = minMaxOf folded xs +{-# INLINE range #-} + +-- | +-- mkWeightedHistogram +-- :: (Foldable f, OrderdField n) +-- => HistogramOptions n -> [(n, n)] -> HistogramPlot n +-- mkWeightedHistogram + +------------------------------------------------------------------------ +-- Histogram +------------------------------------------------------------------------ + +-- $ histogram +-- Histograms display data as barplot of x data, bin y data. +-- Box plots have the following lenses: +-- +-- @ +-- * 'setBin' :: 'Lens'' ('BoxPlot' v n) 'Double' - 10 +-- @ + +-- | Add a 'HistogramPlot' to the 'AxisState' from a data set. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > histogramAxis :: Axis B V2 Double +-- > histogramAxis = r2Axis &~ do +-- > histogramPlot sampleData $ do +-- > key "histogram" +-- > plotColor .= blue +-- > areaStyle . _opacity .= 0.5 +-- +-- > histogramExample = renderAxis histogramAxis +histogramPlot + :: (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 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 b V2 n) m, Plotable (HistogramPlot n) b, RealFrac n) + => Fold s n -- ^ fold over the data + -> s -- ^ data to fold + -> 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 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 :: (Additive v, R2 v, Num n) => Transformation v n +_reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) + +_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 new file mode 100644 --- /dev/null +++ b/src/Plots/Types/Line.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} +----------------------------------------------------------------------------- +-- | +-- 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 line plot is simply a 'Path' used as a plot. This module contains +-- helpers adding path plots. For line plots with markers, see +-- 'Plots.Types.Scatter'. +-- +---------------------------------------------------------------------------- + +module Plots.Types.Line + ( -- Plot trails/paths + trailPlot + , trailPlot' + , pathPlot + , pathPlot' + + -- * Line plots from points + , linePlot + , linePlot' + , smoothLinePlot + , smoothLinePlot' + + -- * Contruction utilities + + -- ** Trails + , mkTrail + , mkTrailOf + + -- ** Paths + , mkPath + , mkPathOf + + + ) where + +import Control.Monad.State.Lazy + +import qualified Data.Foldable as F + +import Diagrams.Coordinates.Isomorphic +import Diagrams.Prelude + +import Plots.Axis +import Plots.Types + +------------------------------------------------------------------------ +-- Trails and Paths +------------------------------------------------------------------------ + +-- | Add a 'Trail' as a 'Plot' to an 'Axis'. +trailPlot + :: (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 . toPath + +-- | Add a 'Trail' as a 'Plot' to an 'Axis' without changes to the plot +-- options. +trailPlot' + :: (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' . toPath + +-- | Add a 'Path' as a 'Plot' to an 'Axis'. +pathPlot + :: (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, + 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' + +------------------------------------------------------------------------ +-- From list of points +------------------------------------------------------------------------ + +-- | Add a 'Path' plot from a list of points. +linePlot + :: (BaseSpace c ~ v, + Metric v, + F.Foldable f, + 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 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, + Metric v, + F.Foldable f, + 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, + 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 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 +------------------------------------------------------------------------ + +-- | Construct a localed trail from a list of folable of points. +mkTrail :: (PointLike v n p, OrderedField n, F.Foldable f) => f p -> Located (Trail v n) +mkTrail = mkTrailOf folded + +-- | Construct a localed trail from a fold over points. +mkTrailOf :: (PointLike v n p, OrderedField n) => Fold s p -> s -> Located (Trail v n) +mkTrailOf f ps = fromVertices $ toListOf (f . unpointLike) ps + +-- | Construct a localed trail from a fold over points. +mkPath :: (PointLike v n p, OrderedField n, F.Foldable f, F.Foldable g) => g (f p) -> Path v n +mkPath pss = toPath $ map mkTrail (F.toList pss) + +-- | 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 $ 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,306 @@ +{-# 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. +-- +-- <> +-- +---------------------------------------------------------------------------- + +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 draw 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, + 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, + 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 new file mode 100644 --- /dev/null +++ b/src/Plots/Types/Scatter.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plots.Types.Scatter +-- Copyright : (C) 2015 Christopher Chalmers +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Christopher Chalmers +-- Stability : experimental +-- Portability : non-portable +-- +-- A scatter plot is a type of mathematical diagram using Cartesian +-- coordinates to display values for typically two variables for a set +-- of data. +-- +-- <> +-- +---------------------------------------------------------------------------- +module Plots.Types.Scatter + ( -- * Scatter plot + ScatterPlot + + -- * Scatter plot lenses + , ScatterOptions + , HasScatterOptions (..) + , HasConnectingLine (..) + + -- * Basic scatter plot + -- ** Add plots to the axis + , scatterPlot + , scatterPlot' + , scatterPlotOf + , scatterPlotOf' + + -- * Scatter options + , scatterOptions + + -- * Bubble plots + , bubblePlot + , bubblePlot' + , bubblePlotOf + , bubblePlotOf' + + -- ** Bubble options + , BubbleOptions + , bubbleOptions + , bubbleTransform + , bubbleStyle + + -- ** General scatter plot + , gscatterPlot + , gscatterOptionsFor + + -- * Low level construction + , mkScatterOptions + ) where + +import Control.Lens hiding (lmap, transform, ( # )) +import Control.Monad.State.Lazy + +import qualified Data.Foldable as F +import Data.Typeable + +import Diagrams.Coordinates.Isomorphic +import Diagrams.Prelude hiding (view) + +import Plots.Axis +import Plots.Style +import Plots.Types + +-- config +-- > import Plots + +------------------------------------------------------------------------ +-- General scatter plot +------------------------------------------------------------------------ + +-- | 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 n where + ScatterPlot :: Typeable a => ScatterOptions v n a -> ScatterPlot v n + deriving Typeable + +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 n a = ScatterOptions + { oData :: [a] + , oPos :: a -> Point v n + , oTr :: a -> Transformation v n + , oSty :: a -> Style v n + , oLine :: Bool + } deriving Typeable + +type instance V (ScatterOptions v n a) = v +type instance N (ScatterOptions v n a) = n + +instance (Metric v, OrderedField n) => Enveloped (ScatterPlot v n) where + getEnvelope (ScatterPlot (ScatterOptions {..})) = getEnvelope (map oPos oData) + +instance (TypeableFloat n, Renderable (Path V2 n) b) + => Plotable (ScatterPlot V2 n) b where + renderPlotable s sty (ScatterPlot (ScatterOptions {..})) = + markers <> line + where + markers = 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 = 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 n p, Foldable f, Fractional n) + => f a + -> (a -> p) + -> ScatterOptions v n a +mkScatterOptions xs pf = ScatterOptions + { oData = F.toList xs + , oPos = view unpointLike . pf + , oTr = mempty + , oSty = const (_Wrapped ## mempty) + , oLine = False + } + +------------------------------------------------------------------------ +-- Scatter plot lenses +------------------------------------------------------------------------ + +-- | Class of things that have a 'LensLike' for a 'ScatterPlot' \'s +-- connecting line. +class HasConnectingLine f a where + -- | 'LensLike' onto whether the scatter plot should have a connecting + -- line between points. If the line is present, it uses the + -- 'lineStyle' from the 'PlotStyle'. + connectingLine :: Functor f => LensLike' f a Bool + +instance HasConnectingLine f (ScatterOptions v n a) where + connectingLine = lens oLine (\o b -> o {oLine = b}) + +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 b) where + connectingLine = rawPlot . connectingLine + +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, 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), 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) (N a) d) + + -- | Apply a transform to the markers using the associated data. + 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) (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) (N a)) + scatterPosition = gscatterOptions . lens oPos (\o pos -> o {oPos = pos}) + +instance d ~ d' => HasScatterOptions f (ScatterOptions v n d) d' where + gscatterOptions = id + +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 n d) + eq _ = eqT + +instance (Functor f, HasScatterOptions f p a) => HasScatterOptions f (Plot p b) a where + gscatterOptions = rawPlot . gscatterOptions + +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 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 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 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 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 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 + +------------------------------------------------------------------------ +-- Scatter plot +------------------------------------------------------------------------ + +-- $ scatter +-- Scatter plots display data as dots. There are several representations +-- for scatter plots for extra parameters. Scatter plots have the +-- following lenses: +-- +-- * 'connectingLine' - line between points +-- * +-- + +-- | Add a 'ScatterPlot' to the 'AxisState' from a data set. +-- +-- @ +-- myaxis = r2Axis ~& +-- scatterPlot data1 +-- @ +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > mydata1 = [(1,3), (2,5.5), (3.2, 6), (3.5, 6.1)] +-- > 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 B V2 Double +-- > scatterAxis = r2Axis &~ do +-- > scatterPlot mydata1 $ key "data 1" +-- > scatterPlot mydata2 $ key "data 2" +-- > scatterPlot mydata3 $ key "data 3" +-- +-- > scatterExample = renderAxis scatterAxis +scatterPlot + :: (BaseSpace c ~ 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 n (Point v n)) b) () + -- ^ changes to plot options + -> m () -- ^ add plot to 'Axis' +scatterPlot xs = gscatterPlot (xs ^.. folded . unpointLike) id + +-- | Version of 'scatterPlot' without any changes to the +-- 'ScatterOptions'. +-- +-- === __Example__ +-- +-- <> +-- +-- > import Plots +-- > mydata4 = [(1,3), (2,5.5), (3.2, 6), (3.5, 6.1)] +-- > mydata5 = mydata1 & each . _1 *~ 0.5 +-- > mydata6 = [V2 1.2 2.7, V2 2 5.1, V2 3.2 2.6, V2 3.5 5] +-- +-- > scatterAxis' :: Axis B V2 Double +-- > scatterAxis' = r2Axis &~ do +-- > scatterPlot' mydata4 +-- > scatterPlot' mydata5 +-- > scatterPlot' mydata6 +-- +-- > scatterExample' = renderAxis scatterAxis' +scatterPlot' + :: (BaseSpace c ~ 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' +scatterPlot' xs = scatterPlot xs (return ()) + +-- | Version of 'scatterPlot' that accepts a 'Fold' over the data. +scatterPlotOf + :: (BaseSpace c ~ 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 + -> 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) + +-- | Version of 'scatterPlot' that accepts a 'Fold' over the data +-- without any changes to the 'ScatterOptions'. +scatterPlotOf' + :: (BaseSpace c ~ 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 +scatterPlotOf' f s = scatterPlot' (toListOf f s) + +------------------------------------------------------------------------ +-- Bubble plot -- +------------------------------------------------------------------------ + +-- | A bubble plot is a scatter plot using point together with a scalar. +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 + :: (BaseSpace c ~ v, + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Typeable n, + Foldable f) + => 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 + bubbleTransform .= scaling + s + +-- | Simple version of 'bubblePlot' without any changes to the 'Plot'. +bubblePlot' + :: (v ~ BaseSpace c, + PointLike v n p, + Typeable n, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Foldable f) + => 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 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 n) b) () + -- ^ changes to the options + -> m () -- ^ add plot to 'Axis' +bubblePlotOf f s = bubblePlot (toListOf f s) + +-- | Version of 'bubblePlot' using a 'Fold' over the data without any +-- changes to the 'BubbleOptions'. +bubblePlotOf' + :: (BaseSpace c ~ v, + 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 n) b) () + -- ^ changes to the options + -> m () -- ^ add plot to 'Axis' +bubblePlotOf' f s = bubblePlot (toListOf f s) + +-- Bubble scatter lenses ----------------------------------------------- + +-- | LensLike onto into a 'ScatterOptions' made up of a scaler @n@, and +-- a point, @'Point' v n@ +-- +-- @ +-- 'bubbleOptions' :: 'Lens'' ('Plot' ('BubbleOptions' v n) v) ('BubbleOptions' v n) +-- @ +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 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 n) -> 'Transformation' v n@. +-- +bubbleTransform + :: (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 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 n) -> 'Style' v n@. +-- +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 + +------------------------------------------------------------------------ +-- General scatter plot +------------------------------------------------------------------------ + +-- | A general scatter plot allow using any data type @d@ to determine +-- the 'scatterTransform' and 'scatterStyle'. +gscatterPlot + :: (BaseSpace c ~ v, + PointLike v n p, + MonadState (Axis b c n) m, + Plotable (ScatterPlot v n) b, + Typeable d, + F.Foldable f) + => f d -- ^ data + -> (d -> p) -- ^ extract point from data + -> State (Plot (ScatterOptions v n d) b) () + -- ^ options for plot + -> m () -- ^ add plot to 'Axis' +gscatterPlot xs pf s = addPlot $ over rawPlot ScatterPlot p1 + where + p1 = execState s p0 + p0 = mkPlot $ mkScatterOptions xs (view unpointLike . pf) + +-- | Helper to traverse over a general scatter plot where the type of d +-- is not infered. +gscatterOptionsFor + :: (InSpace v n a, HasScatterOptions f a d) + => proxy d -> LensLike' f a (ScatterOptions v n d) +gscatterOptionsFor _ = gscatterOptions + diff --git a/src/Plots/Util.hs b/src/Plots/Util.hs new file mode 100644 --- /dev/null +++ b/src/Plots/Util.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Plots.Util + ( pathFromVertices + , minMaxOf + , enumFromToN + , whenever + + -- * State helpers + , (&=) + , (&~~) + ) where + +import Control.Lens +import Control.Monad.State +import Data.Bool + +import Diagrams.Prelude hiding (diff) + +-- | Similar to '(%=)' but takes a state modification instead of a +-- function. +(&=) :: MonadState s m => ASetter' s b -> State b a -> m () +l &= s = l %= execState s +infix 3 &= + +-- | Similar to '(&~)' but works with 'StateT' and returns it in @m@. +(&~~) :: Monad m => s -> StateT s m a -> m s +l &~~ s = execStateT s l +infix 1 &~~ + +-- | @enumFromToN a b n@ calculates a list from @a@ to @b@ in @n@ steps. +enumFromToN :: Fractional n => n -> n -> Int -> [n] +enumFromToN a b n = go n a + where + go !i !x | i < 1 = [x] + | otherwise = x : go (i - 1) (x + diff) + diff = (b - a) / fromIntegral n + +-- | Apply a function if the predicate is true. +whenever :: Bool -> (a -> a) -> a -> a +whenever b f = bool id f b + +------------------------------------------------------------------------ +-- Diagrams +------------------------------------------------------------------------ + +-- | Type specialised version of 'fromVertices'. +pathFromVertices :: (Metric v, OrderedField n) => [Point v n] -> Path v n +pathFromVertices = fromVertices +{-# INLINE pathFromVertices #-} + +-- | Minmax of a getter in the form @V2 min max@. Returns @(V2 +-- (-Infinity) Infinity)@ for empty folds. +minMaxOf :: (Fractional a, Ord a) => Getting (Endo (Endo (V2 a))) s a -> s -> (a,a) +minMaxOf l = foldlOf' l (\(V2 mn mx) a -> V2 (min mn a) (max mx a)) (V2 (1/0) (-1/0)) + <&> \(V2 x y) -> (x,y) + -- (\acc a -> acc <**> V2 min max ?? a) +-- V2 is used instead of a tuple because V2 is strict. +{-# INLINE minMaxOf #-} +