Merge pull request #130 from paleolimbot/geodesic-inherit

Allow NA value for geodesic attribute

NAMESPACE

@@ -230,6 +230,7 @@ S3method(wk_is_geodesic,default)
 S3method(wk_is_geodesic,wk_wkb)
 S3method(wk_is_geodesic,wk_wkt)
 S3method(wk_meta,default)
+S3method(wk_plot,default)
 S3method(wk_restore,data.frame)
 S3method(wk_restore,default)
 S3method(wk_restore,sf)
@@ -345,6 +346,7 @@ export(wk_envelope_handler)
 export(wk_flatten)
 export(wk_flatten_filter)
 export(wk_format)
+export(wk_geodesic_inherit)
 export(wk_geometry_type)
 export(wk_geometry_type_label)
 export(wk_handle)

NEWS.md

@@ -29,6 +29,7 @@
 * Fix `as_xy()` for nested data frames and geodesic objects (#126, #128).
 * Remove deprecated `wkb_problems()`, `wkt_problems()`, `wkb_format()`,
   and `wkt_format()` (#129).
+* `wk_plot()` is now an S3 generic (#130).
 
 # wk 0.5.0
 

R/pkg-vctrs.R

@@ -101,13 +101,13 @@ vec_ptype2.wk_wkb.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
 #' @method vec_ptype2.wk_wkb wk_wkb
 #' @export
 vec_ptype2.wk_wkb.wk_wkb <- function(x, y, ..., x_arg = "x", y_arg = "y") {
-  new_wk_wkb(crs = wk_crs_output(x, y), geodesic = if (wk_is_geodesic_output(x, y)) TRUE)
+  new_wk_wkb(crs = wk_crs_output(x, y), geodesic = geodesic_attr(wk_is_geodesic_output(x, y)))
 }
 
 #' @method vec_ptype2.wk_wkb wk_wkt
 #' @export
 vec_ptype2.wk_wkb.wk_wkt <- function(x, y, ..., x_arg = "x", y_arg = "y") {
-  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = if (wk_is_geodesic_output(x, y)) TRUE)
+  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = geodesic_attr(wk_is_geodesic_output(x, y)))
 }
 
 #' @method vec_ptype2.wk_wkb wk_xy
@@ -137,7 +137,7 @@ vec_ptype2.wk_wkb.wk_xyzm <- function(x, y, ..., x_arg = "x", y_arg = "y") {
 #' @method vec_ptype2.wk_wkb wk_rct
 #' @export
 vec_ptype2.wk_wkb.wk_rct <- function(x, y, ..., x_arg = "x", y_arg = "y") {
-  new_wk_wkb(crs = wk_crs_output(x, y), geodesic = if (wk_is_geodesic_output(x, y)) TRUE)
+  new_wk_wkb(crs = wk_crs_output(x, y), geodesic = geodesic_attr(wk_is_geodesic_output(x, y)))
 }
 
 #' @method vec_ptype2.wk_wkb wk_crc
@@ -239,13 +239,13 @@ vec_ptype2.wk_wkt.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
 #' @method vec_ptype2.wk_wkt wk_wkt
 #' @export
 vec_ptype2.wk_wkt.wk_wkt <- function(x, y, ..., x_arg = "x", y_arg = "y") {
-  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = if (wk_is_geodesic_output(x, y)) TRUE)
+  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = geodesic_attr(wk_is_geodesic_output(x, y)))
 }
 
 #' @method vec_ptype2.wk_wkt wk_wkb
 #' @export
 vec_ptype2.wk_wkt.wk_wkb <- function(x, y, ..., x_arg = "x", y_arg = "y") {
-  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = if (wk_is_geodesic_output(x, y)) TRUE)
+  new_wk_wkt(crs = wk_crs_output(x, y), geodesic = geodesic_attr(wk_is_geodesic_output(x, y)))
 }
 
 #' @method vec_ptype2.wk_wkt wk_xy

R/plot.R

@@ -24,11 +24,29 @@
 wk_plot <- function(handleable, ...,
                     asp = 1, bbox = NULL, xlab = "", ylab = "",
                     rule = "evenodd", add = FALSE) {
+  UseMethod("wk_plot")
+}
+
+#' @rdname wk_plot
+#' @export
+wk_plot.default <- function(handleable, ...,
+                            asp = 1, bbox = NULL, xlab = "", ylab = "",
+                            rule = "evenodd", add = FALSE) {
   # this is too hard without vctrs (already in Suggests)
   if (!requireNamespace("vctrs", quietly = TRUE)) {
     stop("Package 'vctrs' is required for wk_plot()", call. = FALSE) # nocov
   }
 
+  if (isTRUE(wk_is_geodesic(handleable))) {
+    stop(
+      paste0(
+        "wk_plot.default() can't plot geodesic objects.\n",
+        "Use `wk_set_geodesic(x, FALSE)` to ignore geodesic edge specification"
+      ),
+      call. = FALSE
+    )
+  }
+
   # should be refactored
   x <- handleable
 

R/wk-crs.R

@@ -83,6 +83,10 @@ wk_crs2 <- function(x, y) {
 wk_is_geodesic2 <- function(x, y) {
   if (identical(x, y)) {
     x
+  } else if (identical(x, NA)) {
+    y
+  } else if (identical(y, NA)) {
+    x
   } else {
     stop("objects have differing values for geodesic", call. = FALSE)
   }
@@ -157,6 +161,12 @@ wk_set_geodesic <- function(x, geodesic) {
  wk_set_geodesic(x, value)
 }
 
+#' @rdname wk_is_geodesic
+#' @export
+wk_geodesic_inherit <- function() {
+  NA
+}
+
 #' @export
 wk_is_geodesic.default <- function(x) {
   FALSE
@@ -188,16 +198,28 @@ wk_set_geodesic.default <- function(x, geodesic) {
 
 #' @export
 wk_set_geodesic.wk_wkb <- function(x, geodesic) {
-  attr(x, "geodesic") <- if (isTRUE(geodesic)) TRUE else NULL
+  attr(x, "geodesic") <- geodesic_attr(geodesic)
   x
 }
 
 #' @export
 wk_set_geodesic.wk_wkt <- function(x, geodesic) {
-  attr(x, "geodesic") <- if (isTRUE(geodesic)) TRUE else NULL
+  attr(x, "geodesic") <- geodesic_attr(geodesic)
   x
 }
 
+geodesic_attr <- function(geodesic) {
+  if (!is.logical(geodesic) || (length(geodesic) != 1L)) {
+    stop("`geodesic` must be TRUE, FALSE, or NA", call. = FALSE)
+  }
+
+  if (identical(geodesic, FALSE)) {
+    NULL
+  } else {
+    geodesic
+  }
+}
+
 #' CRS object generic methods
 #'
 #' @param crs An arbitrary R object

R/wkb.R

@@ -14,7 +14,7 @@
 wkb <- function(x = list(), crs = wk_crs_auto(), geodesic = FALSE) {
   crs <- wk_crs_auto_value(x, crs)
   attributes(x) <- NULL
-  wkb <- new_wk_wkb(x, crs = crs, geodesic = if (isTRUE(geodesic)) TRUE else NULL)
+  wkb <- new_wk_wkb(x, crs = crs, geodesic = geodesic_attr(geodesic))
   validate_wk_wkb(wkb)
   wkb
 }
@@ -24,7 +24,7 @@ wkb <- function(x = list(), crs = wk_crs_auto(), geodesic = FALSE) {
 parse_wkb <- function(x, crs = wk_crs_auto(), geodesic = FALSE) {
   crs <- wk_crs_auto_value(x, crs)
   attributes(x) <- NULL
-  wkb <- new_wk_wkb(x, crs = crs, geodesic = if (isTRUE(geodesic)) TRUE else NULL)
+  wkb <- new_wk_wkb(x, crs = crs, geodesic = geodesic_attr(geodesic))
   parse_base(wkb, wk_problems(wkb))
 }
 
@@ -45,7 +45,7 @@ as_wkb <- function(x, ...) {
 as_wkb.default <- function(x, ...) {
   wk_translate(
     x,
-    new_wk_wkb(crs = wk_crs_inherit(), geodesic = if (wk_is_geodesic(x)) TRUE),
+    new_wk_wkb(crs = wk_crs_inherit(), geodesic = wk_geodesic_inherit()),
     ...
   )
 }
@@ -129,7 +129,7 @@ is_wk_wkb <- function(x) {
   x[i] <- replacement
   attr(x, "crs") <- NULL
   attr(x, "geodesic") <- NULL
-  new_wk_wkb(x, crs = crs_out, geodesic = if (geodesic_out) TRUE else NULL)
+  new_wk_wkb(x, crs = crs_out, geodesic = geodesic_attr(geodesic_out))
 }
 
 #' @export

R/wkt.R

@@ -14,7 +14,7 @@
 wkt <- function(x = character(), crs = wk_crs_auto(), geodesic = FALSE) {
   x <- as.character(x)
   crs <- wk_crs_auto_value(x, crs)
-  wkt <- new_wk_wkt(x, crs = crs, geodesic = if (isTRUE(geodesic)) TRUE else NULL)
+  wkt <- new_wk_wkt(x, crs = crs, geodesic = geodesic_attr(geodesic))
   validate_wk_wkt(wkt)
   wkt
 }
@@ -24,7 +24,7 @@ wkt <- function(x = character(), crs = wk_crs_auto(), geodesic = FALSE) {
 parse_wkt <- function(x, crs = wk_crs_auto(), geodesic = FALSE) {
   x <- as.character(x)
   crs <- wk_crs_auto_value(x, crs)
-  wkt <- new_wk_wkt(x, crs = crs, geodesic = if (isTRUE(geodesic)) TRUE else NULL)
+  wkt <- new_wk_wkt(x, crs = crs, geodesic = geodesic_attr(geodesic))
   parse_base(wkt, wk_problems(wkt))
 }
 
@@ -39,7 +39,7 @@ as_wkt <- function(x, ...) {
 as_wkt.default <- function(x, ...) {
   wk_translate(
     x,
-    new_wk_wkt(crs = wk_crs_inherit(), geodesic = if (wk_is_geodesic(x)) TRUE)
+    new_wk_wkt(crs = wk_crs_inherit(), geodesic = wk_geodesic_inherit())
   )
 }
 
@@ -106,7 +106,7 @@ validate_wk_wkt <- function(x) {
   x[i] <- replacement
   attr(x, "crs") <- NULL
   attr(x, "geodesic") <- NULL
-  new_wk_wkt(x, crs = crs_out, geodesic = if (geodesic_out) TRUE else NULL)
+  new_wk_wkt(x, crs = crs_out, geodesic = geodesic_attr(geodesic_out))
 }
 
 #' @export

tests/testthat/test-plot.R

@@ -42,6 +42,10 @@ test_that("wk_plot() recycles args for each feature", {
   expect_identical(wk_plot(x, col = c("blue", "red"), pch = 16), x)
 })
 
+test_that("wk_plot() errors for geodesic objects", {
+  expect_error(wk_plot(wkt(geodesic = TRUE)), "can't plot geodesic objects")
+})
+
 test_that("plot methods work", {
   x <- "LINESTRING (0 0, 1 1)"
   expect_identical(plot(as_wkt(x)), as_wkt(x))

tests/testthat/test-wk-crs.R

@@ -29,6 +29,11 @@ test_that("geodesic getting and setting works for wkb", {
   wk_is_geodesic(x) <- FALSE
   expect_false(wk_is_geodesic(x))
   expect_null(attr(x, "geodesic"))
+
+  wk_is_geodesic(x) <- wk_geodesic_inherit()
+  expect_identical(wk_is_geodesic(x), NA)
+
+  expect_error(wk_set_geodesic(x, "fish"), "must be TRUE, FALSE, or NA")
 })
 
 test_that("geodesic getting and setting works for wkt", {
@@ -39,12 +44,49 @@ test_that("geodesic getting and setting works for wkt", {
   wk_is_geodesic(x) <- FALSE
   expect_false(wk_is_geodesic(x))
   expect_null(attr(x, "geodesic"))
+
+  wk_is_geodesic(x) <- wk_geodesic_inherit()
+  expect_identical(wk_is_geodesic(x), NA)
+
+  expect_error(wk_set_geodesic(x, "fish"), "must be TRUE, FALSE, or NA")
 })
 
 test_that("geodesic setting gives a warning when this isn't supported", {
   expect_warning(wk_set_geodesic(xy(), TRUE), "for object of class 'wk_xy'")
 })
 
+test_that("wk_geodesic_output() works", {
+  expect_identical(
+    wk_is_geodesic_output(wkt(geodesic = FALSE), wkt(geodesic = FALSE)),
+    FALSE
+  )
+
+  expect_identical(
+    wk_is_geodesic_output(wkt(geodesic = TRUE), wkt(geodesic = TRUE)),
+    TRUE
+  )
+
+  expect_identical(
+    wk_is_geodesic_output(wkt(geodesic = wk_geodesic_inherit()), wkt(geodesic = FALSE)),
+    FALSE
+  )
+
+  expect_identical(
+    wk_is_geodesic_output(wkt(geodesic = FALSE), wkt(geodesic = wk_geodesic_inherit())),
+    FALSE
+  )
+
+  expect_error(
+    wk_is_geodesic_output(wkt(geodesic = TRUE), wkt(geodesic = FALSE)),
+    "differing values"
+  )
+
+  expect_error(
+    wk_is_geodesic_output(wkt(geodesic = FALSE), wkt(geodesic = TRUE)),
+    "differing values"
+  )
+})
+
 test_that("crs comparison works", {
   expect_true(wk_crs_equal(NULL, NULL))
   expect_false(wk_crs_equal(NULL, "something"))