fix: Fix vctrs methods for forthcoming vctrs release (#231)

* Increment version number to 0.9.4.9000

* add missing methods + redocument

* passing tests with dev vctrs

* remove badly added methods

* NEWS

* nope

Author: paleolimbot

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: wk
 Title: Lightweight Well-Known Geometry Parsing
-Version: 0.9.4
+Version: 0.9.4.9000
 Authors@R:
     c(
       person(given = "Dewey",
@@ -31,7 +31,7 @@ Description: Provides a minimal R and C++ API for parsing
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
 Suggests:
     testthat (>= 3.0.0),
     vctrs (>= 0.3.0),

NAMESPACE

@@ -115,7 +115,9 @@ S3method(rep_len,wk_vctr)
 S3method(str,wk_rcrd)
 S3method(str,wk_vctr)
 S3method(vec_cast.wk_crc,default)
+S3method(vec_cast.wk_crc,wk_crc)
 S3method(vec_cast.wk_rct,default)
+S3method(vec_cast.wk_rct,wk_rct)
 S3method(vec_cast.wk_wkb,default)
 S3method(vec_cast.wk_wkb,wk_crc)
 S3method(vec_cast.wk_wkb,wk_rct)
@@ -274,6 +276,7 @@ S3method(wk_is_geodesic,data.frame)
 S3method(wk_is_geodesic,default)
 S3method(wk_is_geodesic,wk_wkb)
 S3method(wk_is_geodesic,wk_wkt)
+S3method(wk_is_geodesic,wk_xy)
 S3method(wk_meta,default)
 S3method(wk_plot,default)
 S3method(wk_restore,data.frame)
@@ -291,6 +294,7 @@ S3method(wk_set_geodesic,data.frame)
 S3method(wk_set_geodesic,default)
 S3method(wk_set_geodesic,wk_wkb)
 S3method(wk_set_geodesic,wk_wkt)
+S3method(wk_set_geodesic,wk_xy)
 S3method(wk_trans_inverse,wk_trans_affine)
 S3method(wk_translate,data.frame)
 S3method(wk_translate,default)

NEWS.md

@@ -1,3 +1,7 @@
+# wk (development version)
+
+- Ensure package tests pass against forthcoming vctrs (#231).
+
 # wk 0.9.4
 
 - Ensure package tests pass against sf 1.0-18 (#224, #225).

R/pkg-vctrs.R

@@ -56,24 +56,28 @@ vec_cast.wk_wkb.wk_wkt <- function(x, to, ...) {
 #' @method vec_cast.wk_wkb wk_xy
 #' @export
 vec_cast.wk_wkb.wk_xy <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkb wk_xyz
 #' @export
 vec_cast.wk_wkb.wk_xyz <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkb wk_xym
 #' @export
 vec_cast.wk_wkb.wk_xym <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkb wk_xyzm
 #' @export
 vec_cast.wk_wkb.wk_xyzm <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
@@ -195,24 +199,28 @@ vec_cast.wk_wkt.wk_wkb <- function(x, to, ...) {
 #' @method vec_cast.wk_wkt wk_xy
 #' @export
 vec_cast.wk_wkt.wk_xy <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkt wk_xyz
 #' @export
 vec_cast.wk_wkt.wk_xyz <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkt wk_xym
 #' @export
 vec_cast.wk_wkt.wk_xym <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
 #' @method vec_cast.wk_wkt wk_xyzm
 #' @export
 vec_cast.wk_wkt.wk_xyzm <- function(x, to, ...) {
+  wk_is_geodesic(x) <- wk_is_geodesic(to)
   wk_translate(x, to)
 }
 
@@ -832,6 +840,14 @@ vec_ptype2.wk_rct <- function(x, y, ...) {
   UseMethod("vec_ptype2.wk_rct", y) # nocov
 }
 
+#' @method vec_cast.wk_rct wk_rct
+#' @export
+vec_cast.wk_rct.wk_rct <- function(x, to, ...) {
+  wk_crs_output(x, to)
+  wk_is_geodesic_output(x, to)
+  x
+}
+
 #' @method vec_ptype2.wk_rct wk_rct
 #' @export
 vec_ptype2.wk_rct.wk_rct <- function(x, y, ..., x_arg = "x", y_arg = "y") {
@@ -905,6 +921,14 @@ vec_cast.wk_crc.default <- function(x, to, ...) {
   vctrs::vec_default_cast(x, to) # nocov
 }
 
+#' @method vec_cast.wk_crc wk_crc
+#' @export
+vec_cast.wk_crc.wk_crc <- function(x, to, ...) {
+  wk_crs_output(x, to)
+  wk_is_geodesic_output(x, to)
+  x
+}
+
 #' @rdname vctrs-methods
 #' @export vec_ptype2.wk_crc
 vec_ptype2.wk_crc <- function(x, y, ...) {

R/wk-crs.R

@@ -184,6 +184,11 @@ wk_is_geodesic.wk_wkt <- function(x) {
   attr(x, "geodesic", exact = TRUE) %||% FALSE
 }
 
+#' @export
+wk_is_geodesic.wk_xy <- function(x) {
+  attr(x, "geodesic", exact = TRUE) %||% FALSE
+}
+
 #' @export
 wk_set_geodesic.default <- function(x, geodesic) {
   if (geodesic) {
@@ -210,6 +215,12 @@ wk_set_geodesic.wk_wkt <- function(x, geodesic) {
   x
 }
 
+#' @export
+wk_set_geodesic.wk_xy <- function(x, geodesic) {
+  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)

tests/testthat/test-wk-crs.R

@@ -52,7 +52,10 @@ test_that("geodesic getting and setting works for wkt", {
 })
 
 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'")
+  expect_warning(
+    wk_set_geodesic(structure(list(), class = "foofy"), TRUE),
+    "for object of class 'foofy'"
+  )
 })
 
 test_that("wk_geodesic_output() works", {