hvega-0.5.0.0: src/Graphics/Vega/VegaLite/Geometry.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : Graphics.Vega.VegaLite.Geometry
Copyright : (c) Douglas Burke, 2018-2020
License : BSD3
Maintainer : dburke.gw@gmail.com
Stability : unstable
Portability : CPP, OverloadedStrings
Geometric shapes and projections.
-}
module Graphics.Vega.VegaLite.Geometry
( geometry
, geoFeatureCollection
, geometryCollection
, Geometry(..)
, sphere
, graticule
, GraticuleProperty(..)
, projection
, ProjectionProperty(..)
, Projection(..)
, ClipRect(..)
-- not for external export
, projectionProperty
) where
import qualified Data.Aeson as A
import qualified Data.Text as T
import Control.Arrow (second)
import Data.Aeson ((.=), object, toJSON)
#if !(MIN_VERSION_base(4, 12, 0))
import Data.Monoid ((<>))
#endif
import Graphics.Vega.VegaLite.Data
( DataValue
, dataValueSpec
)
import Graphics.Vega.VegaLite.Foundation (fromT)
import Graphics.Vega.VegaLite.Specification
( VLProperty(VLData, VLProjection)
, VLSpec
, LabelledSpec
, PropertySpec
)
import Graphics.Vega.VegaLite.Input
( Data
)
type_ :: T.Text -> LabelledSpec
type_ t = "type" .= t
{-|
Specifies a list of geo features to be used in a geoShape specification.
Each feature object in this collection can be created with the 'geometry'
function.
@
'geoFeatureCollection'
[ 'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( -3, 52 ), ( 4, 52 ), ( -3, 59 ) ] ])
[ ( "myRegionName", 'Graphics.Vega.VegaLite.Str' "Northern region" ) ]
, 'geometry' ('GeoPolygon' [ [ ( -3, 52 ), ( 4, 52 ), ( 4, 45 ), ( -3, 52 ) ] ])
[ ( "myRegionName", 'Graphics.Vega.VegaLite.Str' "Southern region" ) ]
]
@
-}
geoFeatureCollection :: [VLSpec] -> VLSpec
geoFeatureCollection geoms =
object [ type_ "FeatureCollection"
, "features" .= geoms
]
{-|
Specifies a list of geometry objects to be used in a geoShape specification.
Each geometry object in this collection can be created with the 'geometry'
function.
@
'geometryCollection'
[ 'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( 4, 59 ), ( 4, 52 ), ( -3, 59 ) ] ]) []
, 'geometry' ('GeoPoint' -3.5 55.5) []
]
@
-}
geometryCollection :: [VLSpec] -> VLSpec
geometryCollection geoms =
object [ type_ "GeometryCollection"
, "geometries" .= geoms
]
{-|
Types of geographic map projection. These are based on a subset of those provided
by the <https://github.com/d3/d3-geo d3-geo library>. For details of available
projections see the
<https://vega.github.io/vega-lite/docs/projection.html#projection-types Vega-Lite documentation>.
-}
-- based on schema 3.3.0 #/definitions/ProjectionType
data Projection
= Albers
-- ^ An Albers equal-area conic map projection.
| AlbersUsa
-- ^ An Albers USA map projection that combines continental USA with
-- Alaska and Hawaii. Unlike other projection types, this remains
-- unaffected by 'PrRotate'.
| AzimuthalEqualArea
-- ^ An azimuthal equal area map projection.
| AzimuthalEquidistant
-- ^ An azimuthal equidistant map projection.
| ConicConformal
-- ^ A conformal conic map projection.
| ConicEqualArea
-- ^ An equal area conic map projection.
| ConicEquidistant
-- ^ An equidistant conic map projection.
| Custom T.Text
-- ^ Specify the name of the custom D3 prohection to use. See the
-- <https://vega.github.io/vega/docs/projections/#register Vega API>
-- for more information.
--
-- An example: @Custom "winkle3"@
| EqualEarth
-- ^ An <https://github.com/d3/d3-geo#equal-earth Equal Earth map projection>
-- that provides a reasonable shape approximation while retaining relative areas.
--
-- @since 0.5.0.0
| Equirectangular
-- ^ An equirectangular map projection that maps longitude to x and latitude to y.
-- While showing less area distortion towards the poles than the default 'Mercator'
-- projection, it is neither equal-area nor conformal.
| Gnomonic
-- ^ A gnomonic map projection.
| Identity
-- ^ The identiy projection. This can be combined with 'PrReflectX' and
-- 'PrReflectY' in the list of projection properties.
--
-- @since 0.4.0.0
| Mercator
-- ^ A Mercator map projection. This is the default projection of longitude, latitude
-- values if no projection is set explicitly. It preserves shape (local angle) and
-- lines of equal angular bearing remain parallel straight lines. The area is
-- /significantly/ enlarged towards the poles.
| NaturalEarth1
-- ^ The <https://github.com/d3/d3-geo#geoNaturalEarth1 Natural Earth projection>
-- is neither conformal nor equal-area, but is designed to be \"appealing to the
-- eye\" for small-scale maps of the whole world.
--
-- @since 0.5.0.0
| Orthographic
-- ^ An orthographic map projection.
| Stereographic
-- ^ A stereographic map projection.
| TransverseMercator
-- ^ A transverse Mercator map projection.
projectionLabel :: Projection -> T.Text
projectionLabel Albers = "albers"
projectionLabel AlbersUsa = "albersUsa"
projectionLabel AzimuthalEqualArea = "azimuthalEqualArea"
projectionLabel AzimuthalEquidistant = "azimuthalEquidistant"
projectionLabel ConicConformal = "conicConformal"
projectionLabel ConicEqualArea = "conicEqualarea"
projectionLabel ConicEquidistant = "conicEquidistant"
projectionLabel (Custom pName) = pName
projectionLabel EqualEarth = "equalEarth"
projectionLabel Equirectangular = "equirectangular"
projectionLabel Gnomonic = "gnomonic"
projectionLabel Identity = "identity"
projectionLabel Mercator = "mercator"
projectionLabel NaturalEarth1 = "naturalEarth1"
projectionLabel Orthographic = "orthographic"
projectionLabel Stereographic = "stereographic"
projectionLabel TransverseMercator = "transverseMercator"
-- | Specifies a clipping rectangle for defining
-- the clip extent of a map projection.
data ClipRect
= NoClip
-- ^ No clipping it to be applied.
| LTRB Double Double Double Double
-- ^ The left, top, right, and bottom extents, in pixels,
-- of a rectangular clip.
{-|
Properties for customising a geospatial projection that converts longitude,latitude
pairs into planar @(x,y)@ coordinate pairs for rendering and query. For details see the
<https://vega.github.io/vega-lite/docs/projection.html Vega-Lite documentation>.
This type has been changed in the @0.4.0.0@ release so that all constructors
start with @Pr@ rather than @P@ (and so provide some differentiation to the
'Graphics.Vega.VegaLite.PositionChannel' constructors).
-}
-- based on schema 3.3.0 #/definitions/Projection
data ProjectionProperty
= PrType Projection
-- ^ The type of the map projection.
| PrClipAngle (Maybe Double)
-- ^ The clipping circle angle in degrees. A value of @Nothing@ will switch to
-- antimeridian cutting rather than small-circle clipping.
| PrClipExtent ClipRect
-- ^ Projection’s viewport clip extent to the specified bounds in pixels.
| PrCenter Double Double
-- ^ Projection’s center as longitude and latitude in degrees.
| PrScale Double
-- ^ The projection's zoom scale, which if set, overrides automatic scaling of a
-- geo feature to fit within the viewing area.
--
-- @since 0.4.0.0
| PrTranslate Double Double
-- ^ A projection’s panning translation, which if set, overrides automatic positioning
-- of a geo feature to fit within the viewing area
--
-- Note that the prefix is @Pr@ and not @P@, to match the Elm API.
--
-- @since 0.4.0.0
| PrRotate Double Double Double
-- ^ A projection’s three-axis rotation angle. The order is @lambda@ @phi@ @gamma@,
-- and specifies the rotation angles in degrees about each spherical axis.
| PrPrecision Double
-- ^ Threshold for the projection’s adaptive resampling in pixels, and corresponds to the
-- Douglas–Peucker distance. If precision is not specified, the projection’s current
-- resampling precision of 0.707 is used.
--
-- Version 3.3.0 of the Vega-Lite spec claims this should be output as a string,
-- but it is written out as a number since the
-- [spec is in error](https://github.com/vega/vega-lite/issues/5190).
| PrReflectX Bool
-- ^ Reflect the x-coordinates after performing an identity projection. This
-- creates a left-right mirror image of the geoshape marks when subject to an
-- identity projection with 'Identity'.
--
-- @since 0.4.0.0
| PrReflectY Bool
-- ^ Reflect the y-coordinates after performing an identity projection. This
-- creates a left-right mirror image of the geoshape marks when subject to an
-- identity projection with 'Identity'.
--
-- @since 0.4.0.0
| PrCoefficient Double
-- ^ The @Hammer@ map projection coefficient.
| PrDistance Double
-- ^ The @Satellite@ map projection distance.
| PrFraction Double
-- ^ The @Bottomley@ map projection fraction.
| PrLobes Int
-- ^ Number of lobes in lobed map projections such as the @Berghaus star@.
| PrParallel Double
-- ^ Parallel for map projections such as the @Armadillo@.
| PrRadius Double
-- ^ Radius value for map projections such as the @Gingery@.
| PrRatio Double
-- ^ Ratio value for map projections such as the @Hill@.
| PrSpacing Double
-- ^ Spacing value for map projections such as the @Lagrange@.
| PrTilt Double
-- ^ @Satellite@ map projection tilt.
projectionProperty :: ProjectionProperty -> LabelledSpec
projectionProperty (PrType proj) = "type" .= projectionLabel proj
projectionProperty (PrClipAngle numOrNull) = "clipAngle" .= maybe A.Null toJSON numOrNull
projectionProperty (PrClipExtent rClip) =
("clipExtent", case rClip of
NoClip -> A.Null
LTRB l t r b -> toJSON (map toJSON [l, t, r, b])
)
projectionProperty (PrCenter lon lat) = "center" .= [lon, lat]
projectionProperty (PrScale sc) = "scale" .= sc
projectionProperty (PrTranslate tx ty) = "translate" .= [tx, ty]
projectionProperty (PrRotate lambda phi gamma) = "rotate" .= [lambda, phi, gamma]
projectionProperty (PrPrecision pr) = "precision" .= pr -- the 3.3.0 spec says this is a string, but that's wrong, See https://github.com/vega/vega-lite/issues/5190
projectionProperty (PrReflectX b) = "reflectX" .= b
projectionProperty (PrReflectY b) = "reflectY" .= b
projectionProperty (PrCoefficient x) = "coefficient" .= x
projectionProperty (PrDistance x) = "distance" .= x
projectionProperty (PrFraction x) = "fraction" .= x
projectionProperty (PrLobes n) = "lobes" .= n
projectionProperty (PrParallel x) = "parallel" .= x
projectionProperty (PrRadius x) = "radius" .= x
projectionProperty (PrRatio x) = "ratio" .= x
projectionProperty (PrSpacing x) = "spacing" .= x
projectionProperty (PrTilt x) = "tilt" .= x
{-|
Sets the cartographic projection used for geospatial coordinates. A projection
defines the mapping from @(longitude,latitude)@ to an @(x,y)@ plane used for rendering.
This is useful when using the 'Graphics.Vega.VegaLite.Geoshape' mark. For further details see the
<https://vega.github.io/vega-lite/docs/projection.html Vega-Lite documentation>.
@
'projection' [ 'PrType' 'Orthographic', 'PrRotate' (-40) 0 0 ]
@
-}
projection :: [ProjectionProperty] -> PropertySpec
projection pProps = (VLProjection, object (map projectionProperty pProps))
{-|
Specifies the type and content of geometry specifications for programatically
creating GeoShapes. These can be mapped to the
<https://tools.ietf.org/html/rfc7946#section-3.1 GeoJson geometry object types>
where the pluralised type names refer to their @Multi@ prefixed equivalent in the
GeoJSON specification.
-}
data Geometry
= GeoPoint Double Double
-- ^ The GeoJson geometry @point@ type.
| GeoPoints [(Double, Double)]
-- ^ The GeoJson geometry @multi-point@ type.
| GeoLine [(Double, Double)]
-- ^ The GeoJson geometry @line@ type.
| GeoLines [[(Double, Double)]]
-- ^ The GeoJson geometry @multi-line@ type.
| GeoPolygon [[(Double, Double)]]
-- ^ The GeoJson geometry @polygon@ type.
| GeoPolygons [[[(Double, Double)]]]
-- ^ The GeoJson geometry @multi-polygon@ type.
{-|
Specifies a geometric object to be used in a geoShape specification. The first
parameter is the geometric type, the second an optional list of properties to be
associated with the object.
@
'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( 4, 59 ), ( 4, 52 ), ( -3, 59 ) ] ]) []
@
-}
geometry :: Geometry -> [(T.Text, DataValue)] -> VLSpec
geometry gType properties =
object ([ ("type", fromT "Feature")
, ("geometry", geometryTypeSpec gType) ]
<> if null properties
then []
else [("properties",
object (map (second dataValueSpec) properties))]
)
geometryTypeSpec :: Geometry -> VLSpec
geometryTypeSpec gType =
let toCoords :: [(Double, Double)] -> VLSpec
toCoords = toJSON -- rely on Aeson converting a pair to a 2-element list
toCoordList :: [[(Double, Double)]] -> VLSpec
toCoordList = toJSON . map toCoords -- this is just toJSON isn't it?
-- can we replace this infinite tower of toJSON calls with one toJSON call?
(ptype, cs) = case gType of
GeoPoint x y -> ("Point", toJSON [x, y])
GeoPoints coords -> ("MultiPoint", toCoords coords)
GeoLine coords -> ("LineString", toCoords coords)
GeoLines coords -> ("MultiLineString", toCoordList coords)
GeoPolygon coords -> ("Polygon", toCoordList coords)
GeoPolygons ccoords -> ("MultiPolygon", toJSON (map toCoordList ccoords))
in object [("type", ptype), ("coordinates", cs)]
{-|
Generate a data source that is a sphere for bounding global geographic data.
The sphere will be subject to whatever projection is specified for the view.
@
'Graphics.Vega.VegaLite.toVegaLite'
[ 'sphere'
, 'projection' [ 'PrType' 'Orthographic' ]
, 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFill' "aliceblue" ]
]
@
@since 0.4.0.0
-}
sphere :: Data
sphere = (VLData, object ["sphere" .= True])
{-|
Generate a grid of lines of longitude (meridians) and latitude
(parallels).
@
let proj = 'projection' [ 'PrType' 'Orthographic' ]
sphereSpec = 'Graphics.Vega.VegaLite.asSpec' [ 'sphere'
, 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFill' "aliceblue" ] ]
gratSpec =
'Graphics.Vega.VegaLite.asSpec'
[ 'graticule' [ 'GrStep' (5, 5) ]
, 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFilled' False, 'Graphics.Vega.VegaLite.MStrokeWidth' 0.3 ]
]
in 'Graphics.Vega.VegaLite.toVegaLite' [ proj, 'Graphics.Vega.VegaLite.layer' [ sphereSpec, gratSpec ] ]
@
@since 0.4.0.0
-}
graticule ::
[GraticuleProperty] -- ^ An empty list uses the default parameters
-> Data
graticule [] = (VLData, object ["graticule" .= True])
graticule grProps =
(VLData, object ["graticule" .= object (map graticuleProperty grProps)])
{-|
Determine the properties of graticules. See the
<https://vega.github.io/vega-lite/docs/data.html#graticule Vega-Lite documentation> for details.
@since 0.4.0.0
-}
data GraticuleProperty
= GrExtent (Double, Double) (Double, Double)
-- ^ Define the extent of both the major and minor graticules.
-- The range is given as longitude, latitude pairs of the
-- minimum and then maximum extent. The units are degrees.
| GrExtentMajor (Double, Double) (Double, Double)
-- ^ As @GrExtent@ but for the major graticule lines only.
| GrExtentMinor (Double, Double) (Double, Double)
-- ^ As @GrExtent@ but for the minor graticule lines only.
| GrStep (Double, Double)
-- ^ The step angles for the graticule lines, given as a longitude,
-- latitude pair defining the EW and NS intervals respectively.
-- The units are degrees.
--
-- By default major graticule lines extend to both poles but the
-- minor lines stop at ±80 degrees latitude.
| GrStepMajor (Double, Double)
-- ^ As @GrStep@ but for the major graticule lines only.
--
-- The default is @(90, 360)@.
| GrStepMinor (Double, Double)
-- ^ As @GrStep@ but for the minor graticule lines only.
--
-- The default is @(10, 10)@.
| GrPrecision Double
-- ^ The precision of the graticule. The units are degrees.
-- A smaller value reduces visual artifacts (steps) but takes longer
-- to render.
--
-- The default is @2.5@.
graticuleProperty :: GraticuleProperty -> LabelledSpec
graticuleProperty (GrExtent (lng1, lat1) (lng2, lat2)) =
"extent" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrExtentMajor (lng1, lat1) (lng2, lat2)) =
"extentMajor" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrExtentMinor (lng1, lat1) (lng2, lat2)) =
"extentMinor" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrStep (lng, lat)) = "step" .= [lng, lat]
graticuleProperty (GrStepMajor (lng, lat)) = "stepMajor" .= [lng, lat]
graticuleProperty (GrStepMinor (lng, lat)) = "stepMinor" .= [lng, lat]
graticuleProperty (GrPrecision x) = "precision" .= x