From 311d4d604861b3a859caed35d1d32c8462a7218d Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 1 Aug 2025 16:46:51 -0500 Subject: [PATCH 1/2] Implement `expect_r6_class()` Fixes #2030 --- NAMESPACE | 1 + NEWS.md | 1 + R/expect-inheritance.R | 23 ++++++++++++++++ man/inheritance-expectations.Rd | 6 +++++ tests/testthat/_snaps/expect-inheritance.md | 12 +++++++++ tests/testthat/test-expect-inheritance.R | 29 +++++++++++++++++++++ 6 files changed, 72 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 9b87ed886..1d06507d0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -114,6 +114,7 @@ export(expect_no_warning) export(expect_null) export(expect_output) export(expect_output_file) +export(expect_r6_class) export(expect_reference) export(expect_s3_class) export(expect_s4_class) diff --git a/NEWS.md b/NEWS.md index fb3221d5a..eeac2a68a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # testthat (development version) +* New `expect_r6_class()` (#2030). * `expect_*()` functions consistently and rigorously check their inputs (#1754). * `JunitReporter()` no longer fails with `"no applicable method for xml_add_child"` for warnings outside of tests (#1913). Additionally, warnings now save their backtraces. * `JunitReporter()` strips ANSI escapes in more placese (#1852, #2032). diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index b5f4ceb51..9d309ad17 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -12,6 +12,8 @@ #' * `expect_s4_class(x, class)` checks that `x` is an S4 object that #' [is()] `class`. #' * `expect_s4_class(x, NA)` checks that `x` isn't an S4 object. +#' * `expect_r6_class(x, class)` checks that `x` an R6 object that +#' inherits from `class`. #' * `expect_s7_class(x, Class)` checks that `x` is an S7 object that #' [S7::S7_inherits()] from `Class` #' @@ -26,6 +28,7 @@ #' `exact = TRUE`. #' * `expect_s4_class()`: a character vector of class names or `NA` to assert #' that `object` isn't an S4 object. +#' * `expect_r6_class()`: a string. #' * `expect_s7_class()`: an [S7::S7_class()] object. #' @inheritParams expect_that #' @family expectations @@ -154,6 +157,26 @@ expect_s4_class <- function(object, class) { pass(act$val) } +#' @export +#' @rdname inheritance-expectations +expect_r6_class <- function(object, class) { + act <- quasi_label(enquo(object)) + check_string(class) + + if (!inherits(act$val, "R6")) { + return(fail(sprintf("%s is not an R6 object", act$lab))) + } + + if (!inherits(act$val, class)) { + act_class <- format_class(class(act$val)) + exp_class <- format_class(class) + msg <- sprintf("%s inherits from %s not %s.", act$lab, act_class, exp_class) + return(fail(msg)) + } + + pass(act$val) +} + #' @export #' @rdname inheritance-expectations expect_s7_class <- function(object, class) { diff --git a/man/inheritance-expectations.Rd b/man/inheritance-expectations.Rd index 830a51c68..5d678b9d9 100644 --- a/man/inheritance-expectations.Rd +++ b/man/inheritance-expectations.Rd @@ -5,6 +5,7 @@ \alias{expect_type} \alias{expect_s3_class} \alias{expect_s4_class} +\alias{expect_r6_class} \alias{expect_s7_class} \title{Does code return an object inheriting from the expected base type, S3 class, or S4 class?} @@ -15,6 +16,8 @@ expect_s3_class(object, class, exact = FALSE) expect_s4_class(object, class) +expect_r6_class(object, class) + expect_s7_class(object, class) } \arguments{ @@ -33,6 +36,7 @@ the test will pass if \code{object} inherits from any of them, unless \code{exact = TRUE}. \item \code{expect_s4_class()}: a character vector of class names or \code{NA} to assert that \code{object} isn't an S4 object. +\item \code{expect_r6_class()}: a string. \item \code{expect_s7_class()}: an \code{\link[S7:S7_class]{S7::S7_class()}} object. }} @@ -51,6 +55,8 @@ the vocabulary used here. \item \code{expect_s4_class(x, class)} checks that \code{x} is an S4 object that \code{\link[=is]{is()}} \code{class}. \item \code{expect_s4_class(x, NA)} checks that \code{x} isn't an S4 object. +\item \code{expect_r6_class(x, class)} checks that \code{x} an R6 object that +inherits from \code{class}. \item \code{expect_s7_class(x, Class)} checks that \code{x} is an S7 object that \code{\link[S7:S7_inherits]{S7::S7_inherits()}} from \code{Class} } diff --git a/tests/testthat/_snaps/expect-inheritance.md b/tests/testthat/_snaps/expect-inheritance.md index 09c590978..eee9dbb33 100644 --- a/tests/testthat/_snaps/expect-inheritance.md +++ b/tests/testthat/_snaps/expect-inheritance.md @@ -47,6 +47,18 @@ `x` inherits from 'a'/'b' not 'c'/'d'. +# expect_r6_class generates useful failures + + `x` is not an R6 object + +# expect_r6_class validates its inputs + + Code + expect_r6_class(1, c("Person", "Student")) + Condition + Error in `expect_r6_class()`: + ! `class` must be a single string, not a character vector. + # can check with actual class Foo() inherits from not . diff --git a/tests/testthat/test-expect-inheritance.R b/tests/testthat/test-expect-inheritance.R index aa11f02d7..50a461108 100644 --- a/tests/testthat/test-expect-inheritance.R +++ b/tests/testthat/test-expect-inheritance.R @@ -88,6 +88,35 @@ test_that("expect_s3_class validates its inputs", { }) }) +# expect_r6_class -------------------------------------------------------- + +test_that("expect_r6_class succeeds when object inherits from expected class", { + Person <- R6::R6Class("Person") + Student <- R6::R6Class("Student", inherit = Person) + + person <- Person$new() + student <- Student$new() + + expect_success(expect_r6_class(person, "Person")) + expect_success(expect_r6_class(student, "Student")) + expect_success(expect_r6_class(student, "Person")) +}) + +test_that("expect_r6_class generates useful failures", { + x <- 1 + person <- R6::R6Class("Person")$new() + + expect_snapshot_failure({ + expect_r6_class(x, "Student") + expect_r6_class(person, "Student") + }) +}) + +test_that("expect_r6_class validates its inputs", { + expect_snapshot(error = TRUE, { + expect_r6_class(1, c("Person", "Student")) + }) +}) # expect_s7_class -------------------------------------------------------- From bd7369bb78c4a9bfbb32e50b75af3c1a00f16b40 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 4 Aug 2025 08:12:49 -0500 Subject: [PATCH 2/2] Add missing period --- R/expect-inheritance.R | 2 +- tests/testthat/_snaps/expect-inheritance.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 9d309ad17..58dd72b84 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -164,7 +164,7 @@ expect_r6_class <- function(object, class) { check_string(class) if (!inherits(act$val, "R6")) { - return(fail(sprintf("%s is not an R6 object", act$lab))) + return(fail(sprintf("%s is not an R6 object.", act$lab))) } if (!inherits(act$val, class)) { diff --git a/tests/testthat/_snaps/expect-inheritance.md b/tests/testthat/_snaps/expect-inheritance.md index eee9dbb33..765388642 100644 --- a/tests/testthat/_snaps/expect-inheritance.md +++ b/tests/testthat/_snaps/expect-inheritance.md @@ -49,7 +49,7 @@ # expect_r6_class generates useful failures - `x` is not an R6 object + `x` is not an R6 object. # expect_r6_class validates its inputs