From 3ee4cf3bdb8148390c28cf76e96c605ee1bd6fb0 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Nov 2024 09:13:14 -0600 Subject: [PATCH 1/4] Implement `expect_S7_class()` Fixes #1580. Closes #2016. --- DESCRIPTION | 1 + NAMESPACE | 1 + NEWS.md | 1 + R/expect-inheritance.R | 31 ++++++++++++++++++++- man/inheritance-expectations.Rd | 8 +++++- tests/testthat/_snaps/expect-inheritance.md | 16 +++++++++++ tests/testthat/test-expect-inheritance.R | 18 +++++++++++- 7 files changed, 73 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e3b13ebf4..4b5482089 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,6 +43,7 @@ Suggests: knitr, rmarkdown, rstudioapi, + S7, shiny, usethis, vctrs (>= 0.1.0), diff --git a/NAMESPACE b/NAMESPACE index e13d30231..0d32f52a4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -115,6 +115,7 @@ export(expect_output_file) export(expect_reference) export(expect_s3_class) export(expect_s4_class) +export(expect_s7_class) export(expect_setequal) export(expect_silent) export(expect_snapshot) diff --git a/NEWS.md b/NEWS.md index fa4c464cc..bebd66ea9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # testthat (development version) +* New `expect_s7_class()` for testing if an object is an S7 class (#1580). * `expect_setequal()` correctly identifies what is missing where (#1962). * `expect_true()` and `expect_false()` give better errors if `actual` isn't a vector (#1996). * `expect_no_*()` expectations no longer incorrectly emit a passing test result if they in fact fail (#1997). diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 2280e89cc..05d4007d4 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -8,10 +8,12 @@ #' * `expect_type(x, type)` checks that `typeof(x)` is `type`. #' * `expect_s3_class(x, class)` checks that `x` is an S3 object that #' [inherits()] from `class` -#' * `expect_s3_class(x, NA)` checks that `x` isn't an S3 object. +#' * `expect_s3_class(x, NA)` checks that `x` is an S3 object. #' * `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_s7_class(x, Class)` checks that `x` is an S7 object that +#' [S7::S7_inherits()] from `Class` #' #' See [expect_vector()] for testing properties of objects created by vctrs. #' @@ -92,6 +94,33 @@ expect_s3_class <- function(object, class, exact = FALSE) { invisible(act$val) } +#' @export +#' @rdname inheritance-expectations +expect_s7_class <- function(object, class) { + check_installed("S7") + if (!inherits(class, "S7_class")) { + stop_input_type(class, "an S7 class object") + } + + act <- quasi_label(enquo(object), arg = "object") + + if (!S7::S7_inherits(object)) { + fail(sprintf("%s is not an S7 object", act$lab)) + } else { + expect( + S7::S7_inherits(object, class), + sprintf( + "%s inherits from %s not <%s>.", + act$lab, + paste0("<", setdiff(base::class(object), "S7_object"), ">", collapse = "/"), + class@name + ) + ) + } + + invisible(act$val) +} + #' @export #' @rdname inheritance-expectations expect_s4_class <- function(object, class) { diff --git a/man/inheritance-expectations.Rd b/man/inheritance-expectations.Rd index 1b2191620..bb83e7fae 100644 --- a/man/inheritance-expectations.Rd +++ b/man/inheritance-expectations.Rd @@ -4,6 +4,7 @@ \alias{inheritance-expectations} \alias{expect_type} \alias{expect_s3_class} +\alias{expect_s7_class} \alias{expect_s4_class} \title{Does code return an object inheriting from the expected base type, S3 class, or S4 class?} @@ -12,6 +13,8 @@ expect_type(object, type) expect_s3_class(object, class, exact = FALSE) +expect_s7_class(object, class) + expect_s4_class(object, class) } \arguments{ @@ -37,10 +40,13 @@ the vocabulary used here. \item \code{expect_type(x, type)} checks that \code{typeof(x)} is \code{type}. \item \code{expect_s3_class(x, class)} checks that \code{x} is an S3 object that \code{\link[=inherits]{inherits()}} from \code{class} -\item \code{expect_s3_class(x, NA)} checks that \code{x} isn't an S3 object. +\item \code{expect_s3_class(x, NA)} checks that \code{x} is an S3 object. \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_s7_class(x, Class)} checks that \code{x} is an S7 object that +\code{\link[S7:S7_inherits]{S7::S7_inherits()}} from \code{Class} +\item \code{expect_s7_class(x, NA)} checks that \code{x} is an S7 object. } See \code{\link[=expect_vector]{expect_vector()}} for testing properties of objects created by vctrs. diff --git a/tests/testthat/_snaps/expect-inheritance.md b/tests/testthat/_snaps/expect-inheritance.md index 6bcdd9f68..44ae80a40 100644 --- a/tests/testthat/_snaps/expect-inheritance.md +++ b/tests/testthat/_snaps/expect-inheritance.md @@ -18,3 +18,19 @@ `x` inherits from 'a'/'b' not 'c'/'d'. +# checks its inputs + + Code + expect_s7_class(1, 1) + Condition + Error in `expect_s7_class()`: + ! `class` must be an S7 class object, not the number 1. + +# can check with actual class + + Foo() inherits from not . + +--- + + Baz() inherits from / not . + diff --git a/tests/testthat/test-expect-inheritance.R b/tests/testthat/test-expect-inheritance.R index 0129dc090..721b847b0 100644 --- a/tests/testthat/test-expect-inheritance.R +++ b/tests/testthat/test-expect-inheritance.R @@ -56,8 +56,24 @@ test_that("test_s3_class can request exact match", { expect_success(expect_s3_class(x, c("a", "b"), exact = TRUE)) }) - test_that("expect_s3_class allows unquoting of first argument", { f <- factor("a") expect_success(expect_s3_class(!! rlang::quo(f), "factor")) }) + + +# expect_s7_class -------------------------------------------------------- + +test_that("checks its inputs", { + expect_snapshot(expect_s7_class(1, 1), error = TRUE) +}) + +test_that("can check with actual class", { + Foo <- S7::new_class("Foo") + Bar <- S7::new_class("Bar") + expect_success(expect_s7_class(Foo(), class = Foo)) + expect_snapshot_failure(expect_s7_class(Foo(), class = Bar)) + + Baz <- S7::new_class("Baz", parent = Foo) + expect_snapshot_failure(expect_s7_class(Baz(), class = Bar)) +}) From 9d8f7f15d5c7f073994321e41c7dd54dce9def21 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Nov 2024 09:13:59 -0600 Subject: [PATCH 2/4] Revert mistake --- R/expect-inheritance.R | 2 +- man/inheritance-expectations.Rd | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 05d4007d4..401b2f79f 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -8,7 +8,7 @@ #' * `expect_type(x, type)` checks that `typeof(x)` is `type`. #' * `expect_s3_class(x, class)` checks that `x` is an S3 object that #' [inherits()] from `class` -#' * `expect_s3_class(x, NA)` checks that `x` is an S3 object. +#' * `expect_s3_class(x, NA)` checks that `x` isn't an S3 object. #' * `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. diff --git a/man/inheritance-expectations.Rd b/man/inheritance-expectations.Rd index bb83e7fae..e43b0b89e 100644 --- a/man/inheritance-expectations.Rd +++ b/man/inheritance-expectations.Rd @@ -40,13 +40,12 @@ the vocabulary used here. \item \code{expect_type(x, type)} checks that \code{typeof(x)} is \code{type}. \item \code{expect_s3_class(x, class)} checks that \code{x} is an S3 object that \code{\link[=inherits]{inherits()}} from \code{class} -\item \code{expect_s3_class(x, NA)} checks that \code{x} is an S3 object. +\item \code{expect_s3_class(x, NA)} checks that \code{x} isn't an S3 object. \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_s7_class(x, Class)} checks that \code{x} is an S7 object that \code{\link[S7:S7_inherits]{S7::S7_inherits()}} from \code{Class} -\item \code{expect_s7_class(x, NA)} checks that \code{x} is an S7 object. } See \code{\link[=expect_vector]{expect_vector()}} for testing properties of objects created by vctrs. From 55d9bfc09da7f74c2e1e34512a5c4433b67b06ab Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Nov 2024 09:29:50 -0600 Subject: [PATCH 3/4] Use attr instead of `@` --- R/expect-inheritance.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 401b2f79f..d8b118e8a 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -113,7 +113,7 @@ expect_s7_class <- function(object, class) { "%s inherits from %s not <%s>.", act$lab, paste0("<", setdiff(base::class(object), "S7_object"), ">", collapse = "/"), - class@name + attr(class, "name") ) ) } From b3ea5c2e58d50ed5b3a8656a88f3354195d515ea Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Nov 2024 10:01:40 -0600 Subject: [PATCH 4/4] Update R/expect-inheritance.R Co-authored-by: Tomasz Kalinowski --- R/expect-inheritance.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index d8b118e8a..10677a556 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -113,7 +113,7 @@ expect_s7_class <- function(object, class) { "%s inherits from %s not <%s>.", act$lab, paste0("<", setdiff(base::class(object), "S7_object"), ">", collapse = "/"), - attr(class, "name") + attr(class, "name", TRUE) ) ) }