Merge pull request #104 from qfes/wk-geom

WK Geometries

DESCRIPTION

@@ -27,7 +27,7 @@ Imports:
     tidyselect,
     uuid,
     vctrs,
-    wk
+    wk (>= 0.9)
 Suggests:
     geojsonsf,
     knitr,

NEWS.md

@@ -3,6 +3,7 @@
 - Layer data enhancements (#100)
 - Fix regression in set_layer_visibility (#101)
 - Rescalers no longer require `center` to be inside input domain (#103)
+- All layers now support geometry vectors which {wk} can read (#104)
 
 # rdeck 0.5.2
 

R/doc-deckgl-layers.R

@@ -482,8 +482,10 @@ NULL
 #' @inherit layer_props
 #' @param elevation_data url
 #' @param mesh_max_error number
-#' @param bounds <`bbox`> A [`st_bbox`][sf::st_bbox] object with CRS
-#' [EPSG:4326](http://epsg.io/4326). Must be supplied when using non-tiled elevation data.
+#' @param bounds <[`rct`][wk::rct]/[`st_bbox`][sf::st_bbox]/[`wk-geometry`]>
+#' The bounds of the image to fit x,y coordinates into.
+#' Requires CRS [EPSG:4326](http://epsg.io/4326).
+#' Must be supplied when using non-tiled elevation data.
 #' @param color color
 #' @param elevation_decoder object
 #' @param worker_url string
@@ -561,7 +563,7 @@ NULL
 #' @param tooltip <[`tooltip`]> Defines the columns (and their order) that will be displayed in
 #' the layer tooltip, if `pickable == TRUE`.
 #' Supports [tidy-select](https://dplyr.tidyverse.org/reference/dplyr_tidy_select.html) if a
-#' `data` is a `data.frame`. `sfc` columns are always removed.
+#' `data` is a `data.frame`. Geometry columns are always removed.
 #' @param data <`data.frame` | [`sf`][sf::sf] | `string`> The layer's data. Data frames and
 #' sf objects will contain all columns that are referenced by the layer's accessors. Strings
 #' will be interpreted as a URL and data will be retrieved dynamically in the browser.
@@ -582,11 +584,11 @@ NULL
 #' highlight all objects in the layer. Per-object highlighting is achieved with a colour scale,
 #' or a [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html) column of colours.
 #' @param wrap_longitude <`boolean`> Normalises geometry longitudes.
-#' @param get_source_position <[`accessor`]> The source position geometry column, either a
-#' `sfc_POINT` or a `sfc_MULTIPOINT` column with CRS [EPSG:4326](http://epsg.io/4326).
+#' @param get_source_position <[`accessor`]> The feature source positions. A
+#' `<point/multipoint>` [wk-geometry] column with CRS [EPSG:4326](http://epsg.io/4326).
 #' Supports [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html).
-#' @param get_target_position <[`accessor`]> The target position geometry column, either a
-#' `sfc_POINT` or a `sfc_MULTIPOINT` column with CRS [EPSG:4326](http://epsg.io/4326).
+#' @param get_target_position <[`accessor`]> The feature target positions. A
+#' `<point/multipoint>` [wk-geometry] column with CRS [EPSG:4326](http://epsg.io/4326).
 #' Supports [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html).
 #' @param get_source_color <[`accessor`] | [`scale`] | [`color`]> The colour of the
 #' _source end_ of the arc.
@@ -616,16 +618,16 @@ NULL
 #' @param width_scale <`number`> The scaling multiplier for the width of each line.
 #' @param width_min_pixels <`number`> The minimum line width in pixels.
 #' @param width_max_pixels <`number`> The maximum line width in pixels.
-#' @param bounds  <`bbox`> A [`st_bbox`][sf::st_bbox] object with CRS
-#' [EPSG:4326](http://epsg.io/4326).
-
+#' @param bounds <[`rct`][wk::rct]/[`st_bbox`][sf::st_bbox]/[`wk-geometry`]>
+#' The bounds of the image to fit x,y coordinates into.
+#' Requires CRS [EPSG:4326](http://epsg.io/4326).
 #' @param size_scale <`number`> The size multiplier.
 #' @param size_units <`"pixels"` | `"common"` | `"meters"`> The units of the size specified by
 #' `get_size`.
 #' @param size_min_pixels <`number`> The minimum size in pixels.
 #' @param size_max_pixels <`number`> The maximum size in pixels.
-#' @param get_position <[`accessor`]> The position geometry column, either a `sfc_POINT` or
-#' a `sfc_MULTIPOINT` column with CRS [EPSG:4326](http://epsg.io/4326).
+#' @param get_position <[`accessor`]> The feature positions. A
+#' `<point/multipoint>` [wk-geometry] column with CRS [EPSG:4326](http://epsg.io/4326).
 #' Supports [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html).
 #' @param get_color <[`accessor`] | [`scale`] | [`color`]> The colour of each object.
 #' Accepts a single colour value, a colour scale, or a
@@ -683,15 +685,15 @@ NULL
 #' joints.
 #' @param miter_limit <`number`> The maximum extent of a joint in ratio to the stroke width.
 #' Only applicable if `rounded == FALSE`.
-#' @param get_path <[`accessor`]> The path geometry column, either a `sfc_LINESTRING` or
-#' a `sfc_MULTILINESTRING` column with CRS [EPSG:4326](http://epsg.io/4326).
+#' @param get_path <[`accessor`]> The feature paths. A
+#' `<linestring/multilinestring>` [wk-geometry] column with CRS [EPSG:4326](http://epsg.io/4326).
 #' Supports [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html).
 #' @param cap_rounded <`boolean`> If `TRUE`, draw round caps; else draw square caps.
 #' @param joint_rounded <`boolean`> If `TRUE`, draw round joints; else draw square joints.
 #' @param line_joint_rounded <`boolean`>
 #' @param line_miter_limit number
-#' @param get_polygon <[`accessor`]> The polygon geometry column, either a `sfc_POLYGON`
-#' or a `sfc_MULTIPOLYGON` column with CRS [EPSG:4326](http://epsg.io/4326).
+#' @param get_polygon <[`accessor`]> The feature polygons. A
+#' `<polygon/multipolygon>` [wk-geometry] column with CRS [EPSG:4326](http://epsg.io/4326).
 #' Supports [tidy-eval](https://dplyr.tidyverse.org/articles/programming.html).
 #' @param point_type <`"circle"`|`"icon"`|`"text"`|combination>
 #' Determines how to render point and multipoint features. May be one of:

R/doc-proptypes.R

@@ -178,3 +178,31 @@ NULL
 #' @name color
 #' @keywords internal
 NULL
+
+
+#' Prop Type: WK Geometry
+#'
+#' @description
+#' Geometry vectors are parsed with [wk::wk_handle()]. All geometry formats
+#' that \{wk\} supports directly are available to use in {rdeck} layers. You may
+#' also use geometry formats which \{wk\} doesn't directly support, provided a
+#' _loaded_ package defines a \{wk\} _reader_ (i.e. [wk::wk_handle()] S3 method)
+#' for the geometry type.
+#'
+#' Geometry formats supported by \{wk\} (always supported):
+#' - [wk::wkb()]
+#' - [wk::wkt()]
+#' - [wk::xy()] (`m` dimension is always ignored)
+#' - [wk::crc()]
+#' - [wk::grd()]
+#' - [wk::rct()]
+#' - [sf::st_sfc()]
+#'
+#' Geometry formats supported by other packages (not dependencies of \{rdeck\}):
+#' - [s2::s2_geography()]
+#' - [geos::geos_geometry()]
+#' - Others?
+#'
+#' @name wk-geometry
+#' @keywords internal
+NULL

R/geometry.R

@@ -43,10 +43,13 @@ is_sf <- function(object) inherits(object, "sf")
 
 # is crs = epsg:4326
 is_wgs84 <- function(object) {
-  crs <- sf::st_crs(object)
-  wgs84 <- sf::st_crs(4326)
+  obj_proj <- wk::wk_crs_proj_definition(wk::wk_crs(object))
+  wgs84_proj <- c(
+    wk::wk_crs_proj_definition("EPSG:4326"),
+    wk::wk_crs_proj_definition("OGC:CRS84")
+  )
 
-  crs == wgs84 || !is.na(crs$input) && crs$input == wgs84$input
+  !is.na(obj_proj) & obj_proj %in% wgs84_proj
 }
 
 
@@ -193,3 +196,14 @@ wk_is_linestring <- function(handleable, ignore_empty = TRUE) {
 wk_is_polygon <- function(handleable, ignore_empty = TRUE) {
   wk_is(handleable, wk::wk_geometry_type(c("polygon", "multipolygon")), ignore_empty)
 }
+
+
+# should this live in the wk package?
+wk_bbox.bbox <- function(handleable) {
+  wk::as_rct(handleable)
+}
+
+# should this live in the wk package?
+wk_crs.bbox <- function(handleable) {
+  wk::wk_crs(wk::as_rct(handleable))
+}

R/json.R

@@ -85,8 +85,11 @@ as_json.view_state <- function(object, ...) {
   )
 }
 
-as_json.bbox <- function(object, ...) {
-  json_stringify(object, digits = 6)
+as_json.wk_rct <- function(object, ...) {
+  json_stringify(
+    unname(unlist(object)),
+    digits = 6
+  )
 }
 
 #' @autoglobal

R/validation.R

@@ -63,7 +63,7 @@ validate_data.MVTLayer <- function(layer) {
   }
 }
 
-validate_geometry_accessor <- function(layer, name, sfc_type) {
+validate_geometry_accessor <- function(layer, name, geom_type) {
   prop <- layer[[name]]
   if (is_cur_value(prop)) return()
 
@@ -75,49 +75,69 @@ validate_geometry_accessor <- function(layer, name, sfc_type) {
 
   data <- layer$data
   if (inherits(data, "data.frame") && nrow(data) != 0) {
-    accessor_data <- data[[tidyselect::eval_select(prop$col, data)]]
+    vec <- data[[tidyselect::eval_select(prop$col, data)]]
     tidyassert::assert(
-      inherits(accessor_data, sfc_type) && is_wgs84(accessor_data),
+      wk_is(vec, geom_type) && is_wgs84(vec),
       c(
         "x" = "Column {.col {col}} is invalid for accessor {.arg {name}}",
-        "x" = "A {.emph WGS84} {.cls {type}} vector is required"
+        "x" = "A {.emph WGS84} {.cls {type}} geometry vector expected"
       ),
       call = rlang::caller_call(),
       # prettier assertion expression
       print_expr = substitute(
-        inherits(data$col, sfc_type) && is_wgs84(data$col),
-        list(col = prop$col, sfc_type = sfc_type)
+        wk_is(data$col, geom_type) && is_wgs84(data$col),
+        list(col = prop$col, geom_type = geom_type)
       ),
       name = name,
       col = prop$col,
-      type = sfc_type
+      type = wk::wk_geometry_type_label(geom_type)
     )
   }
 }
 
 # validate get_path
 validate_get_path.layer <- function(layer) {
-  validate_geometry_accessor(layer, "get_path", c("sfc_LINESTRING", "sfc_MULTILINESTRING"))
+  validate_geometry_accessor(
+    layer,
+    "get_path",
+    wk::wk_geometry_type(c("linestring", "multilinestring"))
+  )
 }
 
 # validate get_polygon
 validate_get_polygon.layer <- function(layer) {
-  validate_geometry_accessor(layer, "get_polygon", c("sfc_POLYGON", "sfc_MULTIPOLYGON"))
+  validate_geometry_accessor(
+    layer,
+    "get_polygon",
+    wk::wk_geometry_type(c("polygon", "multipolygon"))
+  )
 }
 
 # validate get_position
 validate_get_position.layer <- function(layer) {
-  validate_geometry_accessor(layer, "get_position", c("sfc_POINT", "sfc_MULTIPOINT"))
+  validate_geometry_accessor(
+    layer,
+    "get_position",
+    wk::wk_geometry_type(c("point", "multipoint"))
+  )
 }
 
 # validate get_source_position
 validate_get_source_position.layer <- function(layer) {
-  validate_geometry_accessor(layer, "get_source_position", c("sfc_POINT", "sfc_MULTIPOINT"))
+  validate_geometry_accessor(
+    layer,
+    "get_source_position",
+    wk::wk_geometry_type(c("point", "multipoint"))
+  )
 }
 
 # validate get_target_position
 validate_get_target_position.layer <- function(layer) {
-  validate_geometry_accessor(layer, "get_target_position", c("sfc_POINT", "sfc_MULTIPOINT"))
+  validate_geometry_accessor(
+    layer,
+    "get_target_position",
+    wk::wk_geometry_type(c("point", "multipoint"))
+  )
 }
 
 # validate image

R/widget.R

@@ -9,8 +9,10 @@
 #' See <https://docs.mapbox.com/api/maps/#mapbox-styles>
 #' @param theme <`"kepler"` | `"light"`> The widget theme which alters the style of the
 #' legend and tooltips.
-#' @param initial_bounds <[`st_bbox`][sf::st_bbox] | [`sf`][sf::sf] | [`sfc`][sf::sfc]>
-#' The initial bounds of the map; overwrites `initial_view_state`.
+#' @param initial_bounds <[`rct`][wk::rct]/[`st_bbox`][sf::st_bbox]/[`wk-geometry`]>
+#' Sets the initial bounds of the map if not `NULL`. Takes priority over `initial_view_state`.
+#' Accepts a bounding box, or a geometry from which a bounding box can be computed. Requires
+#' CRS [EPSG:4326](http://epsg.io/4326).
 #' @param initial_view_state <[`view_state`]> Defines the map position, zoom, bearing and pitch.
 #' @param controller <`logical`> If `NULL` or `FALSE`, the map is not interactive.
 #' @param picking_radius <`number`> Extra pixels around the pointer to include while picking;
@@ -64,9 +66,12 @@ rdeck <- function(map_style = mapbox_dark(),
     is_editor_options(editor) | rlang::is_scalar_logical(editor)
   )
 
+  initial_bounds <- if (!is.null(initial_bounds)) wk::wk_bbox(initial_bounds)
+  tidyassert::assert(is.null(initial_bounds) || is_wgs84(initial_bounds))
+
   deckgl <- deck_props(
     ...,
-    initial_bounds = if (!is.null(initial_bounds)) map_bounds(initial_bounds),
+    initial_bounds = initial_bounds,
     initial_view_state = initial_view_state,
     controller = controller,
     picking_radius = picking_radius,
@@ -166,19 +171,6 @@ props <- function(rdeck) {
   rdeck$x$props
 }
 
-map_bounds <- function(initial_bounds) {
-  tidyassert::assert_inherits(initial_bounds, c("bbox", "sf", "sfc", "sfg"))
-
-  sfc <- if (inherits(initial_bounds, "bbox")) {
-    sf::st_as_sfc(initial_bounds)
-  } else {
-    sf::st_geometry(initial_bounds)
-  }
-
-  sfc %>%
-    sf::st_transform(4326) %>%
-    sf::st_bbox()
-}
 
 deck_props <- function(...,
                         initial_bounds = cur_value(),

_pkgdown.yml

@@ -36,6 +36,7 @@ reference:
       - scale
       - tooltip
       - color
+      - wk-geometry
 
   - title: Core layers
     desc: Deck.GL core layers