From 9d44ff8ce127b1814f9256e67008e3ece9d1cd02 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 19 Jun 2026 07:20:01 -0500 Subject: [PATCH] Implement wrappers for condition classes Fixes #586 --- NAMESPACE | 3 ++ NEWS.md | 1 + R/conditions.R | 69 +++++++++++++++++++++++++++++ _pkgdown.yml | 1 + man/base_condition_classes.Rd | 35 +++++++++++++++ tests/testthat/_snaps/conditions.md | 15 +++++++ tests/testthat/test-conditions.R | 35 +++++++++++++++ 7 files changed, 159 insertions(+) create mode 100644 R/conditions.R create mode 100644 man/base_condition_classes.Rd create mode 100644 tests/testthat/_snaps/conditions.md create mode 100644 tests/testthat/test-conditions.R diff --git a/NAMESPACE b/NAMESPACE index 16148e7b..5e357af2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -65,9 +65,11 @@ export(class_atomic) export(class_call) export(class_character) export(class_complex) +export(class_condition) export(class_data.frame) export(class_double) export(class_environment) +export(class_error) export(class_expression) export(class_factor) export(class_formula) @@ -81,6 +83,7 @@ export(class_name) export(class_numeric) export(class_raw) export(class_vector) +export(class_warning) export(convert) export(method) export(method_explain) diff --git a/NEWS.md b/NEWS.md index 94f68d5e..f45b35e9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658). * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646). +* New `class_condition`, `class_error`, and `class_warning` wrap the base condition classes, making it easier to use S7 to define custom condition classes (#586). * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401). * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553). * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595). diff --git a/R/conditions.R b/R/conditions.R new file mode 100644 index 00000000..56238e99 --- /dev/null +++ b/R/conditions.R @@ -0,0 +1,69 @@ +#' S7 wrappers for base condition classes +#' +#' @description +#' S7 bundles [S3 definitions][new_S3_class] for the base condition classes, +#' making it easier to use S7 to define custom condition classes: +#' +#' * `class_condition` for conditions, the parent class of all conditions. +#' * `class_error` for errors, as signalled by [stop()]. +#' * `class_warning` for warnings, as signalled by [warning()]. +#' +#' These classes are lists with `message` and `call` elements, since base +#' accessors like [conditionMessage()] and [conditionCall()] retrieve these +#' fields from the underlying list. Subclasses inherit these elements, so they +#' remain compatible with base condition handling. +#' +#' @name base_condition_classes +#' @order 0 +#' @returns S7 classes wrapping around the base condition classes. +#' @examples +#' class_error +NULL + +validate_condition <- function(self) { + if (!is.list(self)) { + return("Underlying data must be a ") + } + if (!is.character(self$message) || length(self$message) != 1) { + return("`message` must be a single string") + } +} + +new_condition_constructor <- function(class) { + function(.data = list(), message = "", call = NULL) { + structure( + c(list(message = message, call = call), .data), + class = class + ) + } +} + +#' @export +#' @rdname base_condition_classes +#' @format NULL +#' @order 1 +class_condition <- new_S3_class( + "condition", + constructor = new_condition_constructor("condition"), + validator = validate_condition +) + +#' @export +#' @rdname base_condition_classes +#' @format NULL +#' @order 1 +class_error <- new_S3_class( + c("error", "condition"), + constructor = new_condition_constructor(c("error", "condition")), + validator = validate_condition +) + +#' @export +#' @rdname base_condition_classes +#' @format NULL +#' @order 1 +class_warning <- new_S3_class( + c("warning", "condition"), + constructor = new_condition_constructor(c("warning", "condition")), + validator = validate_condition +) diff --git a/_pkgdown.yml b/_pkgdown.yml index 8f091ee1..3055ac18 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -54,6 +54,7 @@ reference: - base_classes - class_environment - base_s3_classes + - base_condition_classes - new_S3_class - S4_register diff --git a/man/base_condition_classes.Rd b/man/base_condition_classes.Rd new file mode 100644 index 00000000..2ec5011c --- /dev/null +++ b/man/base_condition_classes.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conditions.R +\name{base_condition_classes} +\alias{base_condition_classes} +\alias{class_condition} +\alias{class_error} +\alias{class_warning} +\title{S7 wrappers for base condition classes} +\usage{ +class_condition + +class_error + +class_warning +} +\value{ +S7 classes wrapping around the base condition classes. +} +\description{ +S7 bundles \link[=new_S3_class]{S3 definitions} for the base condition classes, +making it easier to use S7 to define custom condition classes: +\itemize{ +\item \code{class_condition} for conditions, the parent class of all conditions. +\item \code{class_error} for errors, as signalled by \code{\link[=stop]{stop()}}. +\item \code{class_warning} for warnings, as signalled by \code{\link[=warning]{warning()}}. +} + +These classes are lists with \code{message} and \code{call} elements, since base +accessors like \code{\link[=conditionMessage]{conditionMessage()}} and \code{\link[=conditionCall]{conditionCall()}} retrieve these +fields from the underlying list. Subclasses inherit these elements, so they +remain compatible with base condition handling. +} +\examples{ +class_error +} diff --git a/tests/testthat/_snaps/conditions.md b/tests/testthat/_snaps/conditions.md new file mode 100644 index 00000000..e7f6d284 --- /dev/null +++ b/tests/testthat/_snaps/conditions.md @@ -0,0 +1,15 @@ +# catches invalid conditions + + Code + validate_condition(1) + Output + [1] "Underlying data must be a " + Code + validate_condition(structure(list(), class = "condition")) + Output + [1] "`message` must be a single string" + Code + validate_condition(structure(list(message = 1), class = "condition")) + Output + [1] "`message` must be a single string" + diff --git a/tests/testthat/test-conditions.R b/tests/testthat/test-conditions.R new file mode 100644 index 00000000..66e661f3 --- /dev/null +++ b/tests/testthat/test-conditions.R @@ -0,0 +1,35 @@ +test_that("base condition classes have the right class vectors", { + expect_equal(class(class_construct(class_condition)), "condition") + expect_equal(class(class_construct(class_error)), c("error", "condition")) + expect_equal( + class(class_construct(class_warning)), + c("warning", "condition") + ) +}) + +test_that("can construct condition subclasses with S7 properties", { + my_error := new_class( + parent = class_error, + properties = list(data = class_numeric), + package = NULL + ) + x <- my_error(message = "boom", data = 1:3) + + expect_equal(class(x), c("my_error", "error", "condition", "S7_object")) + expect_equal(conditionMessage(x), "boom") + expect_equal(x@data, 1:3) + expect_equal(validate(x), x) + + caught <- tryCatch(stop(x), my_error = function(e) e) + expect_equal(conditionMessage(caught), "boom") + expect_equal(caught@data, 1:3) +}) + +test_that("catches invalid conditions", { + expect_snapshot({ + validate_condition(1) + validate_condition(structure(list(), class = "condition")) + validate_condition(structure(list(message = 1), class = "condition")) + }) + expect_null(validate_condition(simpleError("boom"))) +})