Drop warnings, add optional probabilistic comparisons (#69)

* drop coercion and boolean warnings, add support for probabilistic comparisons

* add errors scales so that the mapping (comparisons) works even when probabilistic comparisons are enabled

* do not use probabilistic comparisons with vctrs

* update tests

* bump version, update NEWS

* move scales to separate file, document functions

* restore ! behavior

Author: Enchufa2

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: errors
 Type: Package
 Title: Uncertainty Propagation for R Vectors
-Version: 0.4.4.2
+Version: 0.4.4.3
 Authors@R: c(
     person("Iñaki", "Ucar", email="iucar@fedoraproject.org",
       role=c("aut", "cph", "cre"), comment=c(ORCID="0000-0001-6403-5550")),
@@ -20,6 +20,6 @@ LazyData: true
 Depends: R (>= 3.0.0)
 Suggests: dplyr (>= 1.0.0), vctrs (>= 0.5.0), pillar, ggplot2 (>= 3.5.0),
     testthat, vdiffr, knitr, rmarkdown
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3
 Roxygen: list(old_usage = TRUE)
 VignetteBuilder: knitr

NAMESPACE

@@ -67,6 +67,16 @@ export(errors)
 export(errors_max)
 export(errors_min)
 export(geom_errors)
+export(scale_alpha_errors)
+export(scale_color_errors)
+export(scale_colour_errors)
+export(scale_fill_errors)
+export(scale_linewidth_errors)
+export(scale_radius_errors)
+export(scale_size_area_errors)
+export(scale_size_errors)
+export(scale_x_errors)
+export(scale_y_errors)
 export(set_correl)
 export(set_covar)
 export(set_errors)

NEWS.md

@@ -2,6 +2,10 @@
 
 - Fix `print()` method, which now correctly returns the object invisibly (#64).
 - Fix `all.equal.errors()` registration (@MichaelChirico #67 addressing #66).
+- Operations with errors and numeric vectors no longer warn about coercion;
+  comparisons no longer warn about errors being dropped (#69 addressing #68).
+  Also, probabilistic comparisons are now available via a dedicated option,
+  see `?Ops.errors` for details.
 
 # errors 0.4.4
 

R/geom_errors.R

@@ -147,6 +147,3 @@ MakeGeomErrors <- function() ggplot2::ggproto(
     grob
   }
 )
-
-# registered in .onLoad()
-scale_type.errors <- function(x) "continuous"

R/init.R

@@ -1,6 +1,3 @@
 .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/ops.R

@@ -1,50 +1,78 @@
 #' @rdname groupGeneric.errors
 #'
 #' @details \subsection{\code{Ops}}{
-#' Boolean operators drop the uncertainty (showing a warning once) and operate on the
-#' numeric values. The rest of the operators propagate the uncertainty as expected from
+#' Boolean operators drop the uncertainty and operate on the numeric values
+#' unless the option \code{errors.compare.probabilistic} is set to \code{TRUE}.
+#' In such case the comparison operators return a numeric value between 0 and 1,
+#' representing the probability that the comparison is true, assuming normal
+#' distribution of the errors.
+#' The rest of the operators propagate the uncertainty as expected from
 #' the first-order Taylor series method. Any numeric operand is automatically
-#' coerced to \code{errors} (showing a warning once) with no uncertainty.}
+#' coerced to \code{errors} with no uncertainty.}
 #'
 #' @examples
-#' y <- set_errors(4:6, 0.2)
+#' y <- set_errors(1:3 + 0.1, c(0, 0.1, 0.2))
 #' x / sqrt(y) + y * sin(x)
 #'
 #' # numeric values are automatically coerced to errors
 #' x^2
 #'
 #' # boolean operators drop uncertainty
 #' y > x
+#' # unless probabilistic comparisons are enabled
+#' options(errors.compare.probabilistic = TRUE)
+#' y > x
+#' options(errors.compare.probabilistic = NULL)
 #'
 #' @export
 Ops.errors <- function(e1, e2) {
-  if (.Generic %in% c("&", "|", "!", "==", "!=", "<", ">", "<=", ">=")) {
-    warn_once_bool(.Generic)
+  if (.Generic == "!")
+    return(NextMethod())
+
+  cmp <- .Generic %in% c("==", "!=", "<", ">", "<=", ">=") # comparison-type
+  pm  <- .Generic %in% c("+", "-")                         # addition-type
+  prd <- .Generic %in% c("*", "/", "%/%", "%%")            # product-type
+  pw  <- .Generic %in% c("**", "^")                        # power-type
+
+  if (!any(cmp, pm, prd, pw))
+    stop(paste("operation", .Generic, "not allowed"))
+
+  if (cmp && !getOption("errors.compare.probabilistic", default=FALSE))
     return(NextMethod())
-  }
 
   if (!missing(e2)) {
-    coercion <- cond2int(!inherits(e1, "errors"), !inherits(e2, "errors"))
-    if (coercion) {
-      warn_once_coercion("Ops")
-      switch(coercion, e1<-set_errors(e1), e2<-set_errors(e2))
-    }
+    if (!inherits(e1, "errors")) e1 <- set_errors(e1)
+    if (!inherits(e2, "errors")) e2 <- set_errors(e2)
   }
 
   deriv <- switch(
     .Generic,
+
+    # comparison-type
+    "==" = return(NextMethod() & ((!.e(e1) & !.e(e2)) | .c(e1, e2) == 1)),
+    "!=" = return(NextMethod() | (( .e(e1) |  .e(e2)) & .c(e1, e2) != 1)),
+    "<" = , "<=" = return(zstd(e2 - e1, .Generic)),
+    ">" = , ">=" = return(zstd(e1 - e2, .Generic)),
+
+    # addition-type
     "+" = , "-" =
       if (missing(e2)) {
         e2 <- NA
         list(do.call(.Generic, list(1)), NA)
       }
       else list(1, do.call(.Generic, list(1))),
+
+    # product-type
     "*" = list(.v(e2), .v(e1)),
     "/" = list(1 / .v(e2), -.v(e1) / .v(e2)^2),
     "%/%" = return(round(e1 / e2)),
     "%%" = return(e1 - round(e1 / e2) * e2),
-    "^" = list(.v(e1)^(.v(e2)-1) * .v(e2), .v(e1)^.v(e2) * log(abs(.v(e1))))
+
+    # power-type
+    "**" = , "^" =
+      list(.v(e1)^(.v(e2)-1) * .v(e2), .v(e1)^.v(e2) * log(abs(.v(e1))))
   )
+
   propagate(unclass(NextMethod()), e1, e2, deriv[[1]], deriv[[2]])
 }
 
@@ -61,10 +89,6 @@ Ops.errors <- function(e1, e2) {
 #'
 #' #' @export
 #' `%*%.errors` = function(x, y) {
-#'   warn_once(
-#'     "matrix multiplication not supported for 'errors' objects, uncertainty dropped",
-#'     fun = .Generic,
-#'     type = "matmult"
-#'   )
+#'   warning("matrix multiplication not supported for 'errors' objects, uncertainty dropped")
 #'   base::`%*%`(unclass(x), unclass(y))
 #' }

R/scale_errors.R

@@ -0,0 +1,91 @@
+#' Continuous scales for \code{errors} objects
+#'
+#' Default scales for the \code{errors} class.
+#'
+#' @param ... arguments passed on to the corresponding continuous scale
+#' (see the manual page for each \code{scale_{type}} for details).
+#'
+#' @name scale_errors
+#' @aliases NULL
+NULL
+
+#' @rdname scale_errors
+#' @export
+scale_x_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_x_continuous(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_y_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_y_continuous(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_colour_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_colour_continuous(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_color_errors <- scale_colour_errors
+
+#' @rdname scale_errors
+#' @export
+scale_fill_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_fill_continuous(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_alpha_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_alpha(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_size_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_size(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_size_area_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_size_area(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_radius_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_radius(...))
+}
+
+#' @rdname scale_errors
+#' @export
+scale_linewidth_errors <- function(...) {
+  make_scale_errors(ggplot2::scale_linewidth(...))
+}
+
+make_scale_errors <- function(parent) {
+  if (!requireNamespace("ggplot2", quietly=TRUE))
+    stop("package 'ggplot2' is required for this functionality", call.=FALSE)
+
+  ggplot2::ggproto(
+    paste0(class(parent)[1], "Errors"),
+    parent,
+
+    map = function(self, x, limits = self$get_limits()) {
+      # remove errors for comparisons
+      ggplot2::ggproto_parent(parent, self)$map(.v(x), limits)
+    }
+  )
+}
+
+# registered in .onLoad()
+scale_type.errors <- function(x) {
+  if (!"errors" %in% .packages())
+    stop("Variable of class 'errors' found, but 'errors' package is not attached.\n",
+         "  Please, attach it using 'library(errors)' to properly show scales with errors.")
+  c("errors", "continuous")
+}

R/tidyverse.R

@@ -38,7 +38,8 @@ vec_restore.errors <- function(x, ...) {
 }
 
 vec_proxy_equal.errors <- function(x, ...) {
-  warn_once_bool("vctrs::vec_proxy_equal")
+  old <- options(errors.compare.probabilistic = FALSE)
+  on.exit(do.call(options, old), TRUE)
   x
 }
 # Currently necessary because of r-lib/vctrs/issues/1140

R/utils.R

@@ -1,28 +1,18 @@
 .pm <- enc2native(intToUtf8(177))
 
-warn_once <- function(message, fun, type) {
-  type <- paste0("errors.warn.", type)
-  if (getOption(type)) {
-    options(as.list(setNames(FALSE, type)))
-    warning("In '", fun, "' : ", message, call. = FALSE)
-  }
-}
-
-warn_once_bool <- function(fun) warn_once(
-  "boolean operators not defined for 'errors' objects, uncertainty dropped",
-  fun = fun,
-  type = "bool"
-)
-
-warn_once_coercion <- function(fun) warn_once(
-  "non-'errors' operand automatically coerced to an 'errors' object with no uncertainty",
-  fun = "Ops",
-  type = "coercion"
-)
-
 # ensure it's numeric
 .v <- function(x) as.numeric(x)
 .e <- function(x) as.numeric(errors(x))
+.c <- function(x, y) {
+  if (is.null(cor <- correl(x, y)))
+    cor <- rep(0, length(x))
+  cor
+}
+
+zstd <- function(x, op) {
+  p <- pnorm(.v(x) / .e(x))
+  replace(p, is.nan(p), if (nchar(op) == 1L) 0 else 1)
+}
 
 get_exponent <- function(x) ifelse(.v(x), floor(log10(abs(.v(x)))), 0)