From 510e7d33c27cc9f903db2b68f96edd9b40995b2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:06:20 +0200 Subject: [PATCH 1/7] drop coercion and boolean warnings, add support for probabilistic comparisons --- R/init.R | 3 -- R/ops.R | 57 ++++++++++++++++++++++++++------------ R/tidyverse.R | 1 - R/utils.R | 30 +++++++------------- man/groupGeneric.errors.Rd | 16 ++++++++--- 5 files changed, 61 insertions(+), 46 deletions(-) diff --git a/R/init.R b/R/init.R index c37412b..fb6a549 100644 --- a/R/init.R +++ b/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() } diff --git a/R/ops.R b/R/ops.R index adb4047..4869863 100644 --- a/R/ops.R +++ b/R/ops.R @@ -1,13 +1,17 @@ #' @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 @@ -15,36 +19,57 @@ #' #' # 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)) #' } diff --git a/R/tidyverse.R b/R/tidyverse.R index 433a095..4428e19 100644 --- a/R/tidyverse.R +++ b/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 diff --git a/R/utils.R b/R/utils.R index 021776e..3e74f64 100644 --- a/R/utils.R +++ b/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) diff --git a/man/groupGeneric.errors.Rd b/man/groupGeneric.errors.Rd index 2382464..1271bd7 100644 --- a/man/groupGeneric.errors.Rd +++ b/man/groupGeneric.errors.Rd @@ -34,10 +34,14 @@ error to the original uncertainty. \code{lgamma}, \code{gamma}, \code{digamma} a uncertainty as expected from the first-order Taylor series method.} \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.} \subsection{\code{Summary}}{ The methods \code{all} and \code{any} are not supported for \code{errors} @@ -53,7 +57,7 @@ log(x) cumsum(x) cumprod(x) -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 @@ -61,6 +65,10 @@ 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) c(min(x), max(x)) range(x) From e8476136691b9721dfe876d99daec457f7e789c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:08:34 +0200 Subject: [PATCH 2/7] add errors scales so that the mapping (comparisons) works even when probabilistic comparisons are enabled --- NAMESPACE | 10 +++++++ R/geom_errors.R | 70 +++++++++++++++++++++++++++++++++++++++++++++- man/geom_errors.Rd | 8 ++++-- 3 files changed, 84 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4737c20..ddafa35 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/geom_errors.R b/R/geom_errors.R index e1bdde1..1a4a6f0 100644 --- a/R/geom_errors.R +++ b/R/geom_errors.R @@ -149,4 +149,72 @@ MakeGeomErrors <- function() ggplot2::ggproto( ) # registered in .onLoad() -scale_type.errors <- function(x) "continuous" +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") +} + +#' @export +scale_x_errors <- function(...) { + make_scale_errors(ggplot2::scale_x_continuous(...)) +} + +#' @export +scale_y_errors <- function(...) { + make_scale_errors(ggplot2::scale_y_continuous(...)) +} + +#' @export +scale_colour_errors <- function(...) { + make_scale_errors(ggplot2::scale_colour_continuous(...)) +} + +#' @export +scale_color_errors <- scale_colour_errors + +#' @export +scale_fill_errors <- function(...) { + make_scale_errors(ggplot2::scale_fill_continuous(...)) +} + +#' @export +scale_alpha_errors <- function(...) { + make_scale_errors(ggplot2::scale_alpha(...)) +} + +#' @export +scale_size_errors <- function(...) { + make_scale_errors(ggplot2::scale_size(...)) +} + +#' @export +scale_size_area_errors <- function(...) { + make_scale_errors(ggplot2::scale_size_area(...)) +} + +#' @export +scale_radius_errors <- function(...) { + make_scale_errors(ggplot2::scale_radius(...)) +} + +#' @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) + } + ) +} diff --git a/man/geom_errors.Rd b/man/geom_errors.Rd index 3fe72c1..02fd9fb 100644 --- a/man/geom_errors.Rd +++ b/man/geom_errors.Rd @@ -31,7 +31,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -95,12 +95,14 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions that define both data and aesthetics and shouldn't inherit behaviour from -the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.} +the default plot specification, e.g. \code{\link[ggplot2:annotation_borders]{annotation_borders()}}.} } \description{ Automatic errorbars for variables with uncertainty. From df088358fe5ad0a3a3561e78ea247adc13090c0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:08:53 +0200 Subject: [PATCH 3/7] do not use probabilistic comparisons with vctrs --- R/tidyverse.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/tidyverse.R b/R/tidyverse.R index 4428e19..4e36d6c 100644 --- a/R/tidyverse.R +++ b/R/tidyverse.R @@ -38,6 +38,8 @@ vec_restore.errors <- function(x, ...) { } vec_proxy_equal.errors <- function(x, ...) { + old <- options(errors.compare.probabilistic = FALSE) + on.exit(do.call(options, old), TRUE) x } # Currently necessary because of r-lib/vctrs/issues/1140 From c160417171915e4f2fbb3b00975ce74b06dcacd3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:09:02 +0200 Subject: [PATCH 4/7] update tests --- tests/testthat/test-math.R | 2 +- tests/testthat/test-ops.R | 88 ++++++++++++++++++++++---------------- 2 files changed, 52 insertions(+), 38 deletions(-) diff --git a/tests/testthat/test-math.R b/tests/testthat/test-math.R index 22e3029..8112192 100644 --- a/tests/testthat/test-math.R +++ b/tests/testthat/test-math.R @@ -30,7 +30,7 @@ test_that("math methods work properly", { xerr <- seq(0.005, 0.05, 0.005)/100 x <- set_errors(xval, xerr) - expect_warning(test_expr(sqrt(x))) + test_expr(sqrt(x)) test_expr(exp(x)) test_expr(log(x)) expect_equal(log(x, 10), log10(x)) diff --git a/tests/testthat/test-ops.R b/tests/testthat/test-ops.R index 9f4d0b4..ec812f5 100644 --- a/tests/testthat/test-ops.R +++ b/tests/testthat/test-ops.R @@ -1,45 +1,59 @@ -.onLoad() +test_that("boolean ops return probabilities", { + xval <- 1:2 + xerr <- c(0, 1) + x1 <- set_errors(xval, xerr) + x2 <- set_errors(xval, xerr) + y1 <- x1 + 1 + y2 <- set_errors(xval+1, xerr) -test_that("bolean ops throw a warning once", { - xval <- 1 - x <- set_errors(xval, 1) + old <- options(errors.compare.probabilistic = TRUE) + on.exit(do.call(options, old), TRUE) - expect_warning(expect_equal(!x, !xval)) - expect_silent(expect_equal(!x, !xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x & x, xval & xval)) - expect_silent(expect_equal(x & x, xval & xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x | x, xval | xval)) - expect_silent(expect_equal(x | x, xval | xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x == x, xval == xval)) - expect_silent(expect_equal(x == x, xval == xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x != x, xval != xval)) - expect_silent(expect_equal(x != x, xval != xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x < x, xval < xval)) - expect_silent(expect_equal(x < x, xval < xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x > x, xval > xval)) - expect_silent(expect_equal(x > x, xval > xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x <= x, xval <= xval)) - expect_silent(expect_equal(x <= x, xval <= xval)) - options(errors.warn.bool = TRUE) - expect_warning(expect_equal(x >= x, xval >= xval)) - expect_silent(expect_equal(x >= x, xval >= xval)) + # uncorrelated equal + expect_equal(x1 < x2, c(0, 0.5)) + expect_equal(x1 > x2, c(0, 0.5)) + expect_equal(x1 <= x2, c(1, 0.5)) + expect_equal(x1 >= x2, c(1, 0.5)) + expect_equal(x1 == x2, c(TRUE, FALSE)) + expect_equal(x1 != x2, c(FALSE, TRUE)) + + # uncorrelated different + expect_equal(x1 < y2, c(1, 0.7602499), tolerance=1e-6) + expect_equal(x1 > y2, c(0, 1 - 0.7602499), tolerance=1e-6) + expect_equal(x1 <= y2, c(1, 0.7602499), tolerance=1e-6) + expect_equal(x1 >= y2, c(0, 1 - 0.7602499), tolerance=1e-6) + expect_equal(x1 == y2, c(FALSE, FALSE)) + expect_equal(x1 != y2, c(TRUE, TRUE)) + + # correlated equal + expect_equal(x1 < x1, c(0, 0)) + expect_equal(x1 > x1, c(0, 0)) + expect_equal(x1 <= x1, c(1, 1)) + expect_equal(x1 >= x1, c(1, 1)) + expect_equal(x1 == x1, c(TRUE, TRUE)) + expect_equal(x1 != x1, c(FALSE, FALSE)) + + # correlated different + expect_equal(x1 < y1, c(1, 1)) + expect_equal(x1 > y1, c(0, 0)) + expect_equal(x1 <= y1, c(1, 1)) + expect_equal(x1 >= y1, c(0, 0)) + expect_equal(x1 == y1, c(FALSE, FALSE)) + expect_equal(x1 != y1, c(TRUE, TRUE)) + + # not allowed + expect_error(!x1, "not allowed") + expect_error(x1 & x1, "not allowed") + expect_error(x1 | x1, "not allowed") }) -test_that("ops with numerics throw a warning", { - x <- set_errors(1, 1) +test_that("numerics are treated as numbers with no uncertainty", { + xval <- 1:10 + xerr <- seq(0.005, 0.05, 0.005) + x <- set_errors(xval, xerr) - expect_warning(1 + x) - expect_silent(1 + x) - options(errors.warn.coercion = TRUE) - expect_warning(x + 1) - expect_silent(x + 1) + expect_equal(1 + x, set_errors(1 + xval, xerr)) + expect_equal(x + 1, set_errors(xval + 1, xerr)) }) test_that("ops work properly", { From e4b641d2c7c37646b2b1f6bb582a5a88fe464583 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:15:03 +0200 Subject: [PATCH 5/7] bump version, update NEWS --- DESCRIPTION | 4 ++-- NEWS.md | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c997365..547484b 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NEWS.md b/NEWS.md index f9bd789..0055501 100644 --- a/NEWS.md +++ b/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 From 00f65160c830d246fab14fdfdaa2b6e0c75d66cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:24:43 +0200 Subject: [PATCH 6/7] move scales to separate file, document functions --- R/geom_errors.R | 71 ----------------------------------- R/scale_errors.R | 91 +++++++++++++++++++++++++++++++++++++++++++++ man/scale_errors.Rd | 42 +++++++++++++++++++++ 3 files changed, 133 insertions(+), 71 deletions(-) create mode 100644 R/scale_errors.R create mode 100644 man/scale_errors.Rd diff --git a/R/geom_errors.R b/R/geom_errors.R index 1a4a6f0..57a1200 100644 --- a/R/geom_errors.R +++ b/R/geom_errors.R @@ -147,74 +147,3 @@ MakeGeomErrors <- function() ggplot2::ggproto( grob } ) - -# 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") -} - -#' @export -scale_x_errors <- function(...) { - make_scale_errors(ggplot2::scale_x_continuous(...)) -} - -#' @export -scale_y_errors <- function(...) { - make_scale_errors(ggplot2::scale_y_continuous(...)) -} - -#' @export -scale_colour_errors <- function(...) { - make_scale_errors(ggplot2::scale_colour_continuous(...)) -} - -#' @export -scale_color_errors <- scale_colour_errors - -#' @export -scale_fill_errors <- function(...) { - make_scale_errors(ggplot2::scale_fill_continuous(...)) -} - -#' @export -scale_alpha_errors <- function(...) { - make_scale_errors(ggplot2::scale_alpha(...)) -} - -#' @export -scale_size_errors <- function(...) { - make_scale_errors(ggplot2::scale_size(...)) -} - -#' @export -scale_size_area_errors <- function(...) { - make_scale_errors(ggplot2::scale_size_area(...)) -} - -#' @export -scale_radius_errors <- function(...) { - make_scale_errors(ggplot2::scale_radius(...)) -} - -#' @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) - } - ) -} diff --git a/R/scale_errors.R b/R/scale_errors.R new file mode 100644 index 0000000..5fd4c5c --- /dev/null +++ b/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") +} diff --git a/man/scale_errors.Rd b/man/scale_errors.Rd new file mode 100644 index 0000000..ad42039 --- /dev/null +++ b/man/scale_errors.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale_errors.R +\name{scale_errors} +\alias{scale_x_errors} +\alias{scale_y_errors} +\alias{scale_colour_errors} +\alias{scale_color_errors} +\alias{scale_fill_errors} +\alias{scale_alpha_errors} +\alias{scale_size_errors} +\alias{scale_size_area_errors} +\alias{scale_radius_errors} +\alias{scale_linewidth_errors} +\title{Continuous scales for \code{errors} objects} +\usage{ +scale_x_errors(...) + +scale_y_errors(...) + +scale_colour_errors(...) + +scale_color_errors(...) + +scale_fill_errors(...) + +scale_alpha_errors(...) + +scale_size_errors(...) + +scale_size_area_errors(...) + +scale_radius_errors(...) + +scale_linewidth_errors(...) +} +\arguments{ +\item{...}{arguments passed on to the corresponding continuous scale +(see the manual page for each \code{scale_{type}} for details).} +} +\description{ +Default scales for the \code{errors} class. +} From 8445670579ec73d65c5785f7a3037f0fcfca7a13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20=C3=9Acar?= Date: Thu, 30 Apr 2026 18:54:38 +0200 Subject: [PATCH 7/7] restore ! behavior --- R/ops.R | 3 +++ tests/testthat/test-ops.R | 1 - 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/R/ops.R b/R/ops.R index 4869863..21216cb 100644 --- a/R/ops.R +++ b/R/ops.R @@ -26,6 +26,9 @@ #' #' @export Ops.errors <- function(e1, e2) { + if (.Generic == "!") + return(NextMethod()) + cmp <- .Generic %in% c("==", "!=", "<", ">", "<=", ">=") # comparison-type pm <- .Generic %in% c("+", "-") # addition-type prd <- .Generic %in% c("*", "/", "%/%", "%%") # product-type diff --git a/tests/testthat/test-ops.R b/tests/testthat/test-ops.R index ec812f5..c1286aa 100644 --- a/tests/testthat/test-ops.R +++ b/tests/testthat/test-ops.R @@ -42,7 +42,6 @@ test_that("boolean ops return probabilities", { expect_equal(x1 != y1, c(TRUE, TRUE)) # not allowed - expect_error(!x1, "not allowed") expect_error(x1 & x1, "not allowed") expect_error(x1 | x1, "not allowed") })