Merge pull request #105 from qfes/wk-geom-editor

Feature editor + WK geometries

NEWS.md

@@ -4,6 +4,7 @@
 - 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)
+- Feature editor accepts geometry vectors which {wk} can read (#105)
 
 # rdeck 0.5.2
 

R/controls.R

@@ -11,7 +11,8 @@
 #' - `linestring`: draw linestrings by clicking each vertex
 #' - `polygon`: draw polygons by clicking each vertex
 #' - `lasso`: freehand polygon draw by click-dragging
-#' @param features <`sf` | `sfc`> Features with which to initialise the editor
+#' @param features <[`wk-geometry`]> Features with which to initialise the editor.
+#' Requires CRS [EPSG:4326](http://epsg.io/4326).
 #' @export
 editor_options <- function(mode = cur_value(), features = cur_value()) {
   tidyassert::assert(
@@ -22,14 +23,17 @@ editor_options <- function(mode = cur_value(), features = cur_value()) {
   )
 
   tidyassert::assert(
-    is.null(features) ||
-      is_cur_value(features) ||
-      (is_sf(features) || is_sfc(features)) && is_wgs84(features),
+    is.null(features) || is_cur_value(features) ||
+      wk::is_handleable(features) && is_wgs84(features),
     error_message = c(
-      "x" = "{.arg features} must be a {.emph WGS84} {.cls sf/sfc}"
+      "x" = "{.arg features} must be a {.emph WGS84} {.cls wk-geometry}"
     )
   )
 
+  if (inherits(features, "data.frame")) {
+    features <- purrr::detect(features, wk::is_handleable)
+  }
+
   structure(
     list(
       mode = mode,
@@ -51,6 +55,7 @@ editor_modes <- function() {
 is_editor_options <- function(object) inherits(object, "editor_options")
 
 as_editor_options <- function(object) UseMethod("as_editor_options")
-as_editor_options.default <- function(object) object
+as_editor_options.editor_options <- function(object) object
+as_editor_options.cur_value <- function(object) object
 as_editor_options.NULL <- function(object) NULL
 as_editor_options.logical <- function(object) if (isTRUE(object)) editor_options() else NULL

R/geometry.R

@@ -41,6 +41,18 @@ is_sfc <- function(object) inherits(object, "sfc")
 # is object a simple features column
 is_sf <- function(object) inherits(object, "sf")
 
+# create a new sf object
+new_sf <- function(x = list(), n = NULL, ...) {
+  handleable <- purrr::keep(x, wk::is_handleable)
+  vctrs::new_data_frame(
+    x,
+    n %??% length(x[[1]]),
+    ...,
+    sf_column = names(handleable[1]),
+    class = "sf"
+  )
+}
+
 # is crs = epsg:4326
 is_wgs84 <- function(object) {
   obj_proj <- wk::wk_crs_proj_definition(wk::wk_crs(object))

R/json.R

@@ -95,22 +95,24 @@ as_json.wk_rct <- function(object, ...) {
 #' @autoglobal
 #' @noRd
 as_json.editor_options <- function(object, ...) {
-  options <- mutate(select(object, -where(is_cur_value)))
+  options <- purrr::discard(object, is_cur_value)
 
   # features to geojson
   if (rlang::has_name(options, "features")) {
     rlang::check_installed("geojsonsf")
 
-    options <- mutate(
-      options,
-      geojson = geojsonsf::sf_geojson(
-        sf::st_sf(features %??% sf::st_sfc()),
-        simplify = FALSE,
-        digits = 6L
-      )
+    features <- wk::wk_handle(
+      options$features %??% wk::xy(),
+      wk::sfc_writer()
     )
 
-    options <- select(options, -features)
+    options$geojson <- geojsonsf::sf_geojson(
+      new_sf(list(geometry = features)),
+      simplify = FALSE,
+      digits = 6L
+    )
+
+    options$features <- NULL
   }
 
   json_stringify(

tests/testthat/test-editor.R

@@ -0,0 +1,85 @@
+test_that("editor_options works", {
+  # cur_value
+  expect_equal(
+    editor_options(),
+    structure(list(mode = cur_value(), features = cur_value()), class = "editor_options")
+  )
+
+  # can set mode, or features, or both
+  expect_equal(
+    editor_options(mode = "lasso"),
+    structure(list(mode = "lasso", features = cur_value()), class = "editor_options")
+  )
+
+  expect_equal(
+    editor_options(features = wk::wkt("POINT EMPTY", "OGC:CRS84")),
+    structure(list(mode = cur_value(), features = wk::wkt("POINT EMPTY", "OGC:CRS84")), class = "editor_options")
+  )
+
+  expect_equal(
+    editor_options(mode = "transform", features = wk::wkt("POINT (1 1)", "OGC:CRS84")),
+    structure(list(mode = "transform", features = wk::wkt("POINT (1 1)", "OGC:CRS84")), class = "editor_options")
+  )
+
+  # strips off data frame
+  expect_equal(
+    editor_options(
+      mode = "polygon",
+      features = vctrs::data_frame(features = wk::wkt("POLYGON ((1 1))", "OGC:CRS84"))
+    ),
+    structure(
+      list(
+        mode = "polygon",
+        features = wk::wkt("POLYGON ((1 1))", "OGC:CRS84")
+      ),
+      class = "editor_options"
+    )
+  )
+})
+
+test_that("as_editor_options works", {
+  expect_equal(
+    as_editor_options(NULL),
+    NULL
+  )
+
+  expect_equal(
+    as_editor_options(TRUE),
+    editor_options()
+  )
+
+  expect_equal(
+    as_editor_options(FALSE),
+    NULL
+  )
+
+  expect_equal(
+    as_editor_options(cur_value()),
+    cur_value()
+  )
+
+  expect_equal(
+    as_editor_options(editor_options("modify")),
+    editor_options("modify")
+  )
+})
+
+test_that("editor_options json works", {
+  expect_equal(
+    as_json(editor_options()),
+    structure("{}", class = "json")
+  )
+
+  expect_equal(
+    as_json(editor_options(mode = "lasso")),
+    structure('{"mode":"lasso"}', class = "json")
+  )
+
+  expect_equal(
+    as_json(editor_options(features = wk::wkt("LINESTRING (1 1)", "OGC:CRS84"))),
+    structure(
+      '{"geojson":{"type":"FeatureCollection","features":[{"type":"Feature","properties":{},"geometry":{"type":"LineString","coordinates":[[1.0,1.0]]}}]}}', # nolint
+      class = "json"
+    )
+  )
+})