Add vctrs methods

DESCRIPTION

@@ -4,7 +4,9 @@ Title: Uncertainty Propagation for R Vectors
 Version: 0.3.3.9000
 Authors@R: c(
     person("Iñaki", "Ucar", email="iucar@fedoraproject.org",
-      role=c("aut", "cph", "cre"), comment=c(ORCID="0000-0001-6403-5550")))
+      role=c("aut", "cph", "cre"), comment=c(ORCID="0000-0001-6403-5550")),
+    person("Lionel", "Henry", role = "ctb", email = "lionel@rstudio.com"),
+    person(given = "RStudio", role = "cph", comment = "Copyright for code written by RStudio employees."))
 Description: Support for measurement errors in R vectors, matrices and arrays:
     automatic uncertainty propagation and reporting.
     Documentation about 'errors' is provided in the paper by Ucar, Pebesma &
@@ -16,7 +18,7 @@ URL: https://github.com/r-quantities/errors
 BugReports: https://github.com/r-quantities/errors/issues
 LazyData: true
 Depends: R (>= 3.0.0)
-Suggests: tibble, pillar, testthat, knitr, rmarkdown
-RoxygenNote: 7.0.2
+Suggests: dplyr (>= 1.0.0), tibble, pillar, testthat, knitr, rmarkdown, vctrs (>= 0.3.0)
+RoxygenNote: 7.1.0
 Roxygen: list(old_usage = TRUE)
 VignetteBuilder: knitr

NAMESPACE

@@ -62,11 +62,4 @@ export(errors_min)
 export(set_correl)
 export(set_covar)
 export(set_errors)
-if(getRversion() >= "3.6.0") {
-  S3method(pillar::type_sum, errors)
-  S3method(pillar::pillar_shaft, errors)
-} else {
-  export(type_sum.errors)
-  export(pillar_shaft.errors)
-}
 import(stats)

NEWS.md

@@ -1,5 +1,6 @@
 # errors 0.3.4
 
+- vctrs methods are now implemented for compatibility with dplyr 1.0 (#38).
 - Implement prettier `str` print (#36).
 
 # errors 0.3.3

R/init.R

@@ -0,0 +1,6 @@
+.onLoad <- function(libname, pkgname) {
+  types <- c("bool", "coercion", "matmult")
+  types <- paste0("errors.warn.", types)
+  options(as.list(setNames(rep.int(TRUE, length(types)), types)))
+  register_all_s3_methods()
+}

R/misc.R

@@ -232,41 +232,6 @@ all.equal.errors <- function(target, current, ...) {
   else msg
 }
 
-#' Methods for Tidy \code{tibble} Printing
-#'
-#' S3 methods for \code{errors} objects.
-#'
-#' @param x object of class errors.
-#' @param ... see \link[pillar]{pillar_shaft}.
-#'
-#' @name tibble
-#' @rawNamespace if(getRversion() >= "3.6.0") {
-#'   S3method(pillar::type_sum, errors)
-#'   S3method(pillar::pillar_shaft, errors)
-#' } else {
-#'   export(type_sum.errors)
-#'   export(pillar_shaft.errors)
-#' }
-type_sum.errors <- function(x) {
-  not <- getOption("errors.notation")
-  out <- ifelse(is.null(not) || not == "parenthesis", "(err)", paste(.pm, "err"))
-  paste0("[", out, "]")
-}
-
-#' @name tibble
-pillar_shaft.errors <- function(x, ...) {
-  out <- format(x)
-  if (!requireNamespace("pillar", quietly = TRUE))
-    return(out)
-
-  not <- getOption("errors.notation")
-  sep <- ifelse(is.null(not) || not == "parenthesis", "(", " ")
-  out <- sapply(strsplit(out, "[[:space:]|\\(]"), function(x) {
-    paste0(x[1], pillar::style_subtle(paste0(sep, x[-1], collapse="")))
-  })
-  pillar::new_pillar_shaft_simple(out, align = "right", min_width = 8)
-}
-
 #' @export
 str.errors <- function(object, ...) {
   rval <- NULL

R/ops.R

@@ -19,11 +19,7 @@
 #' @export
 Ops.errors <- function(e1, e2) {
   if (.Generic %in% c("&", "|", "!", "==", "!=", "<", ">", "<=", ">=")) {
-    warn_once(
-      "boolean operators not defined for 'errors' objects, uncertainty dropped",
-      fun = .Generic,
-      type = "bool"
-    )
+    warn_once_bool(.Generic)
     return(NextMethod())
   }
 

R/tidyverse.R

@@ -0,0 +1,161 @@
+type_sum.errors <- function(x) {
+  not <- getOption("errors.notation")
+  out <- ifelse(is.null(not) || not == "parenthesis", "(err)", paste(.pm, "err"))
+  paste0("[", out, "]")
+}
+
+pillar_shaft.errors <- function(x, ...) {
+  out <- format(x)
+  if (!requireNamespace("pillar", quietly = TRUE))
+    return(out)
+
+  not <- getOption("errors.notation")
+  sep <- ifelse(is.null(not) || not == "parenthesis", "(", " ")
+  out <- sapply(strsplit(out, "[[:space:]|\\(]"), function(x) {
+    paste0(x[1], pillar::style_subtle(paste0(sep, x[-1], collapse="")))
+  })
+  pillar::new_pillar_shaft_simple(out, align = "right", min_width = 8)
+}
+
+
+# vctrs proxying and restoration -------------------------------------
+
+vec_proxy.errors <- function(x, ...) {
+  data <- drop_errors.errors(x)
+  errors <- attr(x, "errors")
+
+  # Simplifies coercion methods
+  errors <- as.double(errors)
+
+  # The `errors` are a vectorised attribute, which requires a data
+  # frame proxy
+  vctrs::new_data_frame(
+    list(data = data, errors = errors),
+    n = length(data)
+  )
+}
+vec_restore.errors <- function(x, ...) {
+  set_errors(x$data, x$errors)
+}
+
+vec_proxy_equal.errors <- function(x, ...) {
+  warn_once_bool("vctrs::vec_proxy_equal")
+  x
+}
+# Currently necessary because of r-lib/vctrs/issues/1140
+vec_proxy_compare.errors <- function(x, ...) {
+  vec_proxy_equal.errors(x)
+}
+
+
+# vctrs coercion -----------------------------------------------------
+
+# Ideally this would be implemented as a higher order type, i.e. the
+# coercion hierarchy would be determined by the wrapped class rather
+# than by `errors` specific methods (r-lib/vctrs#1080).
+
+errors_ptype2 <- function(x, y, ...) {
+  bare_x <- drop_errors.errors(x)
+  bare_y <- drop_errors.errors(y)
+
+  common <- vctrs::vec_ptype2(bare_x, bare_y, ...)
+
+  set_errors(common, double())
+}
+
+vec_ptype2.errors.errors <- function(x, y, ...) {
+  errors_ptype2(x, y, ...)
+}
+
+vec_ptype2.errors.integer <- function(x, y, ...) {
+  errors_ptype2(x, y, ...)
+}
+vec_ptype2.integer.errors <- function(x, y, ...) {
+  errors_ptype2(x, y, ...)
+}
+
+vec_ptype2.errors.double <- function(x, y, ...) {
+  errors_ptype2(x, y, ...)
+}
+vec_ptype2.double.errors <- function(x, y, ...) {
+  errors_ptype2(x, y, ...)
+}
+
+
+errors_upcast <- function(x, to, ...) {
+  bare_x <- drop_errors.errors(x)
+  bare_to <- drop_errors.errors(to)
+
+  # Assumes the conversion doesn't change the scale of `x`. Is this reasonable?
+  out <- vctrs::vec_cast(bare_x, bare_to, ...)
+
+  set_errors(out, errors(x))
+}
+errors_downcast <- function(x, to, ...) {
+  bare_x <- drop_errors.errors(x)
+  vctrs::vec_cast(bare_x, to, ...)
+}
+
+vec_cast.errors.errors <- function(x, to, ...) {
+  errors_upcast(x, to, ...)
+}
+
+vec_cast.errors.integer <- function(x, to, ...) {
+  errors_upcast(x, to, ...)
+}
+vec_cast.integer.errors <- function(x, to, ...) {
+  errors_downcast(x, to, ...)
+}
+
+vec_cast.errors.double <- function(x, to, ...) {
+  errors_upcast(x, to, ...)
+}
+vec_cast.double.errors <- function(x, to, ...) {
+  errors_downcast(x, to, ...)
+}
+
+
+#nocov start
+register_all_s3_methods <- function() {
+  register_s3_method("pillar::type_sum", "errors")
+  register_s3_method("pillar::pillar_shaft", "errors")
+
+  register_s3_method("vctrs::vec_proxy", "errors")
+  register_s3_method("vctrs::vec_restore", "errors")
+  register_s3_method("vctrs::vec_proxy_equal", "errors")
+  register_s3_method("vctrs::vec_proxy_compare", "errors")
+
+  register_s3_method("vctrs::vec_ptype2", "errors.errors")
+  register_s3_method("vctrs::vec_ptype2", "errors.integer")
+  register_s3_method("vctrs::vec_ptype2", "integer.errors")
+  register_s3_method("vctrs::vec_ptype2", "errors.double")
+  register_s3_method("vctrs::vec_ptype2", "double.errors")
+
+  register_s3_method("vctrs::vec_cast", "errors.errors")
+  register_s3_method("vctrs::vec_cast", "errors.integer")
+  register_s3_method("vctrs::vec_cast", "integer.errors")
+  register_s3_method("vctrs::vec_cast", "errors.double")
+  register_s3_method("vctrs::vec_cast", "double.errors")
+}
+
+register_s3_method <- function(generic, class, fun=NULL) {
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  pieces <- strsplit(generic, "::")[[1]]
+  stopifnot(length(pieces) == 2)
+  package <- pieces[[1]]
+  generic <- pieces[[2]]
+
+  if (is.null(fun))
+    fun <- get(paste0(generic, ".", class), envir=parent.frame())
+  stopifnot(is.function(fun))
+
+  if (package %in% loadedNamespaces())
+    registerS3method(generic, class, fun, envir=asNamespace(package))
+
+  # Always register hook in case package is later unloaded & reloaded
+  setHook(packageEvent(package, "onLoad"), function(...)
+    registerS3method(generic, class, fun, envir=asNamespace(package)))
+}
+# nocov end

R/utils.R

@@ -1,11 +1,5 @@
 .pm <- enc2native(intToUtf8(177))
 
-.onLoad <- function(libname, pkgname) {
-  types <- c("bool", "coercion", "matmult")
-  types <- paste0("errors.warn.", types)
-  options(as.list(setNames(rep.int(TRUE, length(types)), types)))
-}
-
 warn_once <- function(message, fun, type) {
   type <- paste0("errors.warn.", type)
   if (getOption(type)) {
@@ -14,6 +8,14 @@ warn_once <- function(message, fun, type) {
   }
 }
 
+warn_once_bool <- function(fun) {
+  warn_once(
+    "boolean operators not defined for 'errors' objects, uncertainty dropped",
+    fun = fun,
+    type = "bool"
+  )
+}
+
 .v <- function(x) as.numeric(x)
 
 get_exponent <- function(x) ifelse(.v(x), floor(log10(abs(.v(x)))), 0)

tests/testthat.R

@@ -1,36 +1,5 @@
 library(testthat)
 library(errors)
 
-D <- function(expr, var) {
-  if (identical(expr, quote(asinh(x))))
-    quote(1 / sqrt(1 + x^2))
-  else if (identical(expr, quote(acosh(x))))
-    quote(1 / (sqrt(x - 1) * sqrt(x + 1)))
-  else if (identical(expr, quote(atanh(x))))
-    quote(1 / (1 - x^2))
-  else
-    stats::D(expr, as.character(var))
-}
-
-test_expr <- function(expr) {
-  expr <- substitute(expr)
-  x <- get("x", parent.frame())
-  ex <- errors(x)
-  ey <- exy <- 0
-  if ("y" %in% as.list(expr)) {
-    y <- get("y", parent.frame())
-    ey <- errors(y)
-    exy <- covar(x, y)
-    if (is.null(exy)) exy <- 0
-  }
-  object <- eval(expr)
-  dx <- as.numeric(eval(D(expr, "x")))
-  dy <- as.numeric(eval(D(expr, "y")))
-  expected <- set_errors(
-    object, sqrt(dx^2 * ex^2 + dy^2 * ey^2 + 2 * dx * dy * exy)
-  )
-  expect_equal(object, expected)
-}
-
 test_check("errors")
 detach("package:errors", unload = TRUE)