drop coercion and boolean warnings, add support for probabilistic comparisons

Author: Enchufa2

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,75 @@
 #' @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)
+  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 +86,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/tidyverse.R

@@ -38,7 +38,6 @@ vec_restore.errors <- function(x, ...) {
 }
 
 vec_proxy_equal.errors <- function(x, ...) {
-  warn_once_bool("vctrs::vec_proxy_equal")
   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)