From 5f41a461f729823b2310c00d6577a2791c32ce86 Mon Sep 17 00:00:00 2001 From: Joe Thorley Date: Sun, 30 Aug 2026 13:10:21 +0100 Subject: [PATCH 1/3] Create `chk_r6_class()` (#253) Checks inherits from R6 class using ```r inherits(x, "R6") && inherits(x, class) ``` Co-Authored-By: Claude Opus 5 (1M context) --- NAMESPACE | 2 + R/chk-r6-class.R | 66 ++++++++++++++++++++++++ _pkgdown.yml | 1 + man/chk_class.Rd | 1 + man/chk_data.Rd | 1 + man/chk_is.Rd | 1 + man/chk_r6_class.Rd | 68 +++++++++++++++++++++++++ man/chk_s3_class.Rd | 1 + man/chk_s3_class_strict.Rd | 1 + man/chk_s4_class.Rd | 1 + tests/testthat/test-chk-r6-class.R | 82 ++++++++++++++++++++++++++++++ vignettes/chk-families.Rmd | 3 +- 12 files changed, 227 insertions(+), 1 deletion(-) create mode 100644 R/chk-r6-class.R create mode 100644 man/chk_r6_class.Rd create mode 100644 tests/testthat/test-chk-r6-class.R diff --git a/NAMESPACE b/NAMESPACE index 8ff83ca1..d3bd5cf7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -76,6 +76,7 @@ export(chk_off) export(chk_on) export(chk_orderset) export(chk_proportion) +export(chk_r6_class) export(chk_range) export(chk_raw) export(chk_s3_class) @@ -167,6 +168,7 @@ export(vld_null) export(vld_number) export(vld_numeric) export(vld_orderset) +export(vld_r6_class) export(vld_range) export(vld_raw) export(vld_s3_class) diff --git a/R/chk-r6-class.R b/R/chk-r6-class.R new file mode 100644 index 00000000..60a5cfa2 --- /dev/null +++ b/R/chk-r6-class.R @@ -0,0 +1,66 @@ +#' Check Inherits from R6 Class +#' +#' @description +#' Checks inherits from R6 class using +#' +#' `inherits(x, "R6") && inherits(x, class)` +#' +#' @details +#' All R6 objects inherit from the class `'R6'`, so `chk_r6_class(x, "R6")` +#' checks that `x` is an R6 object of any class. +#' R6 class generators (as returned by [R6::R6Class()]) are not themselves +#' R6 objects. +#' +#' @inheritParams params +#' @inherit params return +#' +#' @family id_checkers +#' +#' @seealso [inherits()] +#' @seealso For more details about the use of this function, +#' please read the article +#' `vignette("chk-families")`. +#' +#' @examplesIf requireNamespace("R6", quietly = TRUE) +#' # chk_r6_class +#' chk_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class") +#' try(chk_r6_class(1, "numeric")) +#' @export +chk_r6_class <- function(x, class, x_name = NULL) { + if (vld_r6_class(x, class)) { + return(invisible(x)) + } + if (is.null(x_name)) { + x_name <- deparse_backtick_chk(substitute(x)) + } + .class <- cc(class, conj = " or ", chk = FALSE) + abort_chk( + x_name, + " must inherit from R6 class", + if (length(class) == 1) " " else "es ", + .class, + ", not ", + if (vld_s4_class(x, class(x))) { + "S4" + } else if (inherits(x, "R6")) { + "R6" + } else { + "S3" + }, + " class", + if (length(class(x)) == 1) " " else "es ", + cc(class(x), conj = " and "), + ".", + x = x, + .class = .class + ) +} + +#' @describeIn chk_r6_class Validate Inherits from R6 Class +#' +#' @examplesIf requireNamespace("R6", quietly = TRUE) +#' # vld_r6_class +#' vld_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class") +#' vld_r6_class(1, "numeric") +#' @export +vld_r6_class <- function(x, class) inherits(x, "R6") && inherits(x, class) diff --git a/_pkgdown.yml b/_pkgdown.yml index 374f0d26..ed796e94 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -126,6 +126,7 @@ reference: contents: - chk_is - chk_class + - chk_r6_class - chk_s3_class - chk_s3_class_strict - chk_s4_class diff --git a/man/chk_class.Rd b/man/chk_class.Rd index cc5f1983..71cafd02 100644 --- a/man/chk_class.Rd +++ b/man/chk_class.Rd @@ -50,6 +50,7 @@ please read the article Other id_checkers: \code{\link[=chk_data]{chk_data()}}, \code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, \code{\link[=chk_s4_class]{chk_s4_class()}} diff --git a/man/chk_data.Rd b/man/chk_data.Rd index 22c64fd3..35cfdbf2 100644 --- a/man/chk_data.Rd +++ b/man/chk_data.Rd @@ -52,6 +52,7 @@ please read the article Other id_checkers: \code{\link[=chk_class]{chk_class()}}, \code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, \code{\link[=chk_s4_class]{chk_s4_class()}} diff --git a/man/chk_is.Rd b/man/chk_is.Rd index 8ba6e966..d13b9bd7 100644 --- a/man/chk_is.Rd +++ b/man/chk_is.Rd @@ -50,6 +50,7 @@ please read the article Other id_checkers: \code{\link[=chk_class]{chk_class()}}, \code{\link[=chk_data]{chk_data()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, \code{\link[=chk_s4_class]{chk_s4_class()}} diff --git a/man/chk_r6_class.Rd b/man/chk_r6_class.Rd new file mode 100644 index 00000000..ceb72248 --- /dev/null +++ b/man/chk_r6_class.Rd @@ -0,0 +1,68 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/chk-r6-class.R +\name{chk_r6_class} +\alias{chk_r6_class} +\alias{vld_r6_class} +\title{Check Inherits from R6 Class} +\usage{ +chk_r6_class(x, class, x_name = NULL) + +vld_r6_class(x, class) +} +\arguments{ +\item{x}{The object to check.} + +\item{class}{A character vector specifying the possible class values.} + +\item{x_name}{A string of the name of object x or NULL.} +} +\value{ +The \code{chk_} function throws an informative error if the test fails or +returns the original object if successful so it can used in pipes. + +The \code{vld_} function returns a flag indicating whether the test was met. +} +\description{ +Checks inherits from R6 class using + +\code{inherits(x, "R6") && inherits(x, class)} +} +\details{ +All R6 objects inherit from the class \code{'R6'}, so \code{chk_r6_class(x, "R6")} +checks that \code{x} is an R6 object of any class. +R6 class generators (as returned by \code{\link[R6:R6Class]{R6::R6Class()}}) are not themselves +R6 objects. +} +\section{Functions}{ +\itemize{ +\item \code{vld_r6_class()}: Validate Inherits from R6 Class + +}} +\examples{ +\dontshow{if (requireNamespace("R6", quietly = TRUE)) withAutoprint(\{ # examplesIf} +# chk_r6_class +chk_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class") +try(chk_r6_class(1, "numeric")) +\dontshow{\}) # examplesIf} +\dontshow{if (requireNamespace("R6", quietly = TRUE)) withAutoprint(\{ # examplesIf} +# vld_r6_class +vld_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class") +vld_r6_class(1, "numeric") +\dontshow{\}) # examplesIf} +} +\seealso{ +\code{\link[=inherits]{inherits()}} + +For more details about the use of this function, +please read the article +\code{vignette("chk-families")}. + +Other id_checkers: +\code{\link[=chk_class]{chk_class()}}, +\code{\link[=chk_data]{chk_data()}}, +\code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_s3_class]{chk_s3_class()}}, +\code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, +\code{\link[=chk_s4_class]{chk_s4_class()}} +} +\concept{id_checkers} diff --git a/man/chk_s3_class.Rd b/man/chk_s3_class.Rd index aade8fe7..a2a6c56e 100644 --- a/man/chk_s3_class.Rd +++ b/man/chk_s3_class.Rd @@ -58,6 +58,7 @@ Other id_checkers: \code{\link[=chk_class]{chk_class()}}, \code{\link[=chk_data]{chk_data()}}, \code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, \code{\link[=chk_s4_class]{chk_s4_class()}} } diff --git a/man/chk_s3_class_strict.Rd b/man/chk_s3_class_strict.Rd index 6c984650..19e8c3c8 100644 --- a/man/chk_s3_class_strict.Rd +++ b/man/chk_s3_class_strict.Rd @@ -52,6 +52,7 @@ Other id_checkers: \code{\link[=chk_class]{chk_class()}}, \code{\link[=chk_data]{chk_data()}}, \code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s4_class]{chk_s4_class()}} } diff --git a/man/chk_s4_class.Rd b/man/chk_s4_class.Rd index db7784ab..8c704e5b 100644 --- a/man/chk_s4_class.Rd +++ b/man/chk_s4_class.Rd @@ -51,6 +51,7 @@ Other id_checkers: \code{\link[=chk_class]{chk_class()}}, \code{\link[=chk_data]{chk_data()}}, \code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}} } diff --git a/tests/testthat/test-chk-r6-class.R b/tests/testthat/test-chk-r6-class.R new file mode 100644 index 00000000..ce769551 --- /dev/null +++ b/tests/testthat/test-chk-r6-class.R @@ -0,0 +1,82 @@ +skip_if_not_installed("R6") + +test_that("vld_r6_class", { + x <- R6::R6Class("exampleR6class")$new() + expect_true(vld_r6_class(x, "exampleR6class")) + expect_true(vld_r6_class(x, "R6")) + expect_false(vld_r6_class(x, "otherR6class")) +}) + +test_that("vld_r6_class is FALSE for non-R6 objects", { + expect_false(vld_r6_class(1, "numeric")) + expect_false(vld_r6_class(factor(1), "factor")) + expect_false(vld_r6_class( + getClass("MethodDefinition"), + "classRepresentation" + )) +}) + +test_that("vld_r6_class is FALSE for an R6 class generator", { + generator <- R6::R6Class("exampleR6class") + expect_false(R6::is.R6(generator)) + expect_false(vld_r6_class(generator, "R6ClassGenerator")) +}) + +test_that("vld_r6_class recognises inherited R6 classes", { + parent <- R6::R6Class("parentR6class") + child <- R6::R6Class("childR6class", inherit = parent) + x <- child$new() + expect_true(vld_r6_class(x, "childR6class")) + expect_true(vld_r6_class(x, "parentR6class")) +}) + +test_that("vld_r6_class matches any of multiple classes", { + x <- R6::R6Class("exampleR6class")$new() + expect_true(vld_r6_class(x, c("otherR6class", "exampleR6class"))) + expect_false(vld_r6_class(x, c("otherR6class", "anotherR6class"))) +}) + +test_that("chk_r6_class returns x invisibly", { + x <- R6::R6Class("exampleR6class")$new() + expect_identical(chk_r6_class(x, "exampleR6class"), x) + expect_invisible(chk_r6_class(x, "exampleR6class")) +}) + +test_that("chk_r6_class errors informatively", { + expect_chk_error( + chk_r6_class(1, "numeric"), + "^`1` must inherit from R6 class 'numeric', not S3 class 'numeric'\\.$" + ) + expect_chk_error( + chk_r6_class(matrix(1), "numeric"), + paste0( + "^`matrix\\(1\\)` must inherit from R6 class 'numeric', ", + "not S3 classes 'matrix' and 'array'\\.$" + ) + ) + expect_chk_error( + chk_r6_class(getClass("MethodDefinition"), "numeric"), + paste0( + "^`getClass\\(\"MethodDefinition\"\\)` must inherit from R6 class ", + "'numeric', not S4 class 'classRepresentation'\\.$" + ) + ) +}) + +test_that("chk_r6_class errors informatively for an R6 object", { + x <- R6::R6Class("exampleR6class")$new() + expect_chk_error( + chk_r6_class(x, c("a", "b")), + paste0( + "^`x` must inherit from R6 classes 'a' or 'b', ", + "not R6 classes 'exampleR6class' and 'R6'\\.$" + ) + ) +}) + +test_that("chk_r6_class respects x_name", { + expect_chk_error( + chk_r6_class(1, "numeric", x_name = "`foo`"), + "^`foo` must inherit from R6 class 'numeric', not S3 class 'numeric'\\.$" + ) +}) diff --git a/vignettes/chk-families.Rmd b/vignettes/chk-families.Rmd index 37d32b37..930b81ad 100644 --- a/vignettes/chk-families.Rmd +++ b/vignettes/chk-families.Rmd @@ -487,12 +487,13 @@ vld_orderset(c("A", "C"), c("A", "B", "C", "D")) # TRUE ### Class Checkers Check if the function input belongs to a class or type. -These functions check if `x` is an S3 or S4 object of the specified class. +These functions check if `x` is an S3, S4 or R6 object of the specified class. Function | Code :- | :--- `chk_s3_class(x, class)` | `!isS4(x) && inherits(x, class)` `chk_s4_class(x, class)` | `isS4(x) && methods::is(x, class)` +`chk_r6_class(x, class)` | `inherits(x, "R6") && inherits(x, class)` `chk_is()` checks if x inherits from a specified class, regardless of whether it is an S3 or S4 object. From 4eb7741a091b5e5ddaf82c8a22876b4a0b6abe62 Mon Sep 17 00:00:00 2001 From: Joe Thorley Date: Mon, 31 Aug 2026 03:04:20 -0700 Subject: [PATCH 2/3] Extract `object_type()` internal helper Removes the S4/R6/S3 object-type expression triplicated across `chk_s3_class()`, `chk_s4_class()` and `chk_r6_class()`. No change to error messages. Co-Authored-By: Claude Opus 5 (1M context) --- R/chk-r6-class.R | 8 +------- R/chk-s3-class.R | 8 +++++--- R/chk-s4-class.R | 12 ++++++++---- R/internal.R | 12 ++++++++++++ tests/testthat/test-internal.R | 22 ++++++++++++++++++++++ 5 files changed, 48 insertions(+), 14 deletions(-) diff --git a/R/chk-r6-class.R b/R/chk-r6-class.R index 60a5cfa2..511a23d3 100644 --- a/R/chk-r6-class.R +++ b/R/chk-r6-class.R @@ -40,13 +40,7 @@ chk_r6_class <- function(x, class, x_name = NULL) { if (length(class) == 1) " " else "es ", .class, ", not ", - if (vld_s4_class(x, class(x))) { - "S4" - } else if (inherits(x, "R6")) { - "R6" - } else { - "S3" - }, + object_type(x), " class", if (length(class(x)) == 1) " " else "es ", cc(class(x), conj = " and "), diff --git a/R/chk-s3-class.R b/R/chk-s3-class.R index 2aa854ec..e702dddb 100644 --- a/R/chk-s3-class.R +++ b/R/chk-s3-class.R @@ -36,11 +36,13 @@ chk_s3_class <- function(x, class, x_name = NULL) { .class <- cc(class, conj = " or ", chk = FALSE) abort_chk( x_name, - " must inherit from S3 class", if (length(class) == 1) " " else "es ", + " must inherit from S3 class", + if (length(class) == 1) " " else "es ", .class, ", not ", - if (vld_s4_class(x, class(x))) "S4" else if (inherits(x, "R6")) "R6" else "S3", - " class", if (length(class(x)) == 1) " " else "es ", + object_type(x), + " class", + if (length(class(x)) == 1) " " else "es ", cc(class(x), conj = " and "), ".", x = x, diff --git a/R/chk-s4-class.R b/R/chk-s4-class.R index 752c0c2b..86521f51 100644 --- a/R/chk-s4-class.R +++ b/R/chk-s4-class.R @@ -30,11 +30,13 @@ chk_s4_class <- function(x, class, x_name = NULL) { .class <- cc(class, conj = " or ", chk = FALSE) abort_chk( x_name, - " must inherit from S4 class", if (length(class) == 1) " " else "es ", + " must inherit from S4 class", + if (length(class) == 1) " " else "es ", .class, ", not ", - if (vld_s4_class(x, class(x))) "S4" else if (inherits(x, "R6")) "R6" else "S3", - " class", if (length(class(x)) == 1) " " else "es ", + object_type(x), + " class", + if (length(class(x)) == 1) " " else "es ", cc(class(x), conj = " and "), ".", x = x, @@ -49,4 +51,6 @@ chk_s4_class <- function(x, class, x_name = NULL) { #' vld_s4_class(numeric(0), "numeric") #' vld_s4_class(getClass("MethodDefinition"), "classRepresentation") #' @export -vld_s4_class <- function(x, class) isS4(x) && any(sapply(class, \(.c) methods::is(x, .c))) +vld_s4_class <- function(x, class) { + isS4(x) && any(sapply(class, \(.c) methods::is(x, .c))) +} diff --git a/R/internal.R b/R/internal.R index 47a52116..77055b31 100644 --- a/R/internal.R +++ b/R/internal.R @@ -16,3 +16,15 @@ anyDuplicated(x) } + +# the class system an object belongs to, for reporting in error messages +# R5 reference classes count as S4; base objects and S7 classes count as S3 +object_type <- function(x) { + if (vld_s4_class(x, class(x))) { + "S4" + } else if (inherits(x, "R6")) { + "R6" + } else { + "S3" + } +} diff --git a/tests/testthat/test-internal.R b/tests/testthat/test-internal.R index 0298623e..eac81561 100644 --- a/tests/testthat/test-internal.R +++ b/tests/testthat/test-internal.R @@ -4,3 +4,25 @@ test_that("test if incomparables implemented in anyDuplicated.data.frame", { "^argument 'incomparables != FALSE' is not used [(]yet[)]$" ) }) + +test_that("object_type identifies S3 objects", { + expect_identical(object_type(1), "S3") + expect_identical(object_type(matrix(1)), "S3") + expect_identical(object_type(factor(1)), "S3") + expect_identical(object_type(data.frame()), "S3") +}) + +test_that("object_type identifies S4 objects", { + expect_identical(object_type(getClass("MethodDefinition")), "S4") + expect_identical( + object_type(setRefClass("exampleRefClass", fields = "value")$new()), + "S4" + ) +}) + +test_that("object_type identifies R6 objects", { + skip_if_not_installed("R6") + expect_identical(object_type(R6::R6Class("exampleR6class")$new()), "R6") + # a generator is not an R6 object + expect_identical(object_type(R6::R6Class("exampleR6class")), "S3") +}) From fcbc01b77a36024ff1fc63200db69dfcb39aaa60 Mon Sep 17 00:00:00 2001 From: Joe Thorley Date: Mon, 31 Aug 2026 03:53:50 -0700 Subject: [PATCH 3/3] Create `chk_s7_class()` (#254) Checks inherits from S7 class using ```r inherits(x, "S7_object") && inherits(x, class) ``` `object_type()` now reports S7 objects as `'S7'` rather than `'S3'`, which changes the object type named in the error messages of `chk_s3_class()`, `chk_s4_class()` and `chk_r6_class()` when they are given an S7 object. Co-Authored-By: Claude Opus 5 (1M context) --- NAMESPACE | 2 + R/chk-s7-class.R | 72 +++++++++++++++++++++++ R/internal.R | 4 +- _pkgdown.yml | 1 + man/chk_class.Rd | 3 +- man/chk_data.Rd | 3 +- man/chk_is.Rd | 3 +- man/chk_r6_class.Rd | 3 +- man/chk_s3_class.Rd | 3 +- man/chk_s3_class_strict.Rd | 3 +- man/chk_s4_class.Rd | 3 +- man/chk_s7_class.Rd | 79 +++++++++++++++++++++++++ tests/testthat/test-chk-s7-class.R | 93 ++++++++++++++++++++++++++++++ tests/testthat/test-internal.R | 7 +++ vignettes/chk-families.Rmd | 3 +- 15 files changed, 273 insertions(+), 9 deletions(-) create mode 100644 R/chk-s7-class.R create mode 100644 man/chk_s7_class.Rd create mode 100644 tests/testthat/test-chk-s7-class.R diff --git a/NAMESPACE b/NAMESPACE index d3bd5cf7..8b0e05af 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -82,6 +82,7 @@ export(chk_raw) export(chk_s3_class) export(chk_s3_class_strict) export(chk_s4_class) +export(chk_s7_class) export(chk_scalar) export(chk_setequal) export(chk_sorted) @@ -174,6 +175,7 @@ export(vld_raw) export(vld_s3_class) export(vld_s3_class_strict) export(vld_s4_class) +export(vld_s7_class) export(vld_scalar) export(vld_setequal) export(vld_sorted) diff --git a/R/chk-s7-class.R b/R/chk-s7-class.R new file mode 100644 index 00000000..15a69789 --- /dev/null +++ b/R/chk-s7-class.R @@ -0,0 +1,72 @@ +#' Check Inherits from S7 Class +#' +#' @description +#' Checks inherits from S7 class using +#' +#' `inherits(x, "S7_object") && inherits(x, class)` +#' +#' @details +#' All S7 objects inherit from the class `'S7_object'`, so +#' `chk_s7_class(x, "S7_object")` checks that `x` is an S7 object of any class. +#' +#' S7 is self-describing, so an S7 class generator (as returned by +#' [S7::new_class()]) is itself an S7 object, of class `'S7_class'`. +#' It is not an object of the class it generates. +#' +#' `class` is a character vector of class names matching those in `class(x)`. +#' S7 qualifies class names with the package they are defined in, so an S7 +#' class defined in package `foo` is matched by `'foo::ClassName'` and not by +#' `'ClassName'`. +#' S7 class objects are not accepted as `class`. +#' +#' @inheritParams params +#' @inherit params return +#' +#' @family id_checkers +#' +#' @seealso [inherits()] +#' @seealso For more details about the use of this function, +#' please read the article +#' `vignette("chk-families")`. +#' +#' @examplesIf requireNamespace("S7", quietly = TRUE) +#' # chk_s7_class +#' Foo <- S7::new_class("Foo", package = "mypkg") +#' chk_s7_class(Foo(), "mypkg::Foo") +#' try(chk_s7_class(1, "numeric")) +#' @export +chk_s7_class <- function(x, class, x_name = NULL) { + if (vld_s7_class(x, class)) { + return(invisible(x)) + } + if (is.null(x_name)) { + x_name <- deparse_backtick_chk(substitute(x)) + } + .class <- cc(class, conj = " or ", chk = FALSE) + abort_chk( + x_name, + " must inherit from S7 class", + if (length(class) == 1) " " else "es ", + .class, + ", not ", + object_type(x), + " class", + if (length(class(x)) == 1) " " else "es ", + cc(class(x), conj = " and "), + ".", + x = x, + .class = .class + ) +} + +#' @describeIn chk_s7_class Validate Inherits from S7 Class +#' +#' @examplesIf requireNamespace("S7", quietly = TRUE) +#' # vld_s7_class +#' Foo <- S7::new_class("Foo", package = "mypkg") +#' vld_s7_class(Foo(), "mypkg::Foo") +#' vld_s7_class(1, "numeric") +#' @export +vld_s7_class <- function(x, class) { + inherits(x, "S7_object") && inherits(x, class) +} diff --git a/R/internal.R b/R/internal.R index 77055b31..e3a35635 100644 --- a/R/internal.R +++ b/R/internal.R @@ -18,12 +18,14 @@ } # the class system an object belongs to, for reporting in error messages -# R5 reference classes count as S4; base objects and S7 classes count as S3 +# R5 reference classes count as S4; base objects count as S3 object_type <- function(x) { if (vld_s4_class(x, class(x))) { "S4" } else if (inherits(x, "R6")) { "R6" + } else if (inherits(x, "S7_object")) { + "S7" } else { "S3" } diff --git a/_pkgdown.yml b/_pkgdown.yml index ed796e94..2ce9a23a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -130,6 +130,7 @@ reference: - chk_s3_class - chk_s3_class_strict - chk_s4_class + - chk_s7_class - title: REGEX Checker desc: Check if the function input matches a REGEX contents: diff --git a/man/chk_class.Rd b/man/chk_class.Rd index 71cafd02..a30c7fb4 100644 --- a/man/chk_class.Rd +++ b/man/chk_class.Rd @@ -53,6 +53,7 @@ Other id_checkers: \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_data.Rd b/man/chk_data.Rd index 35cfdbf2..03fa1326 100644 --- a/man/chk_data.Rd +++ b/man/chk_data.Rd @@ -55,6 +55,7 @@ Other id_checkers: \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_is.Rd b/man/chk_is.Rd index d13b9bd7..15d44790 100644 --- a/man/chk_is.Rd +++ b/man/chk_is.Rd @@ -53,6 +53,7 @@ Other id_checkers: \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_r6_class.Rd b/man/chk_r6_class.Rd index ceb72248..7c3cf759 100644 --- a/man/chk_r6_class.Rd +++ b/man/chk_r6_class.Rd @@ -63,6 +63,7 @@ Other id_checkers: \code{\link[=chk_is]{chk_is()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_s3_class.Rd b/man/chk_s3_class.Rd index a2a6c56e..30bcd003 100644 --- a/man/chk_s3_class.Rd +++ b/man/chk_s3_class.Rd @@ -60,6 +60,7 @@ Other id_checkers: \code{\link[=chk_is]{chk_is()}}, \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_s3_class_strict.Rd b/man/chk_s3_class_strict.Rd index 19e8c3c8..7152420f 100644 --- a/man/chk_s3_class_strict.Rd +++ b/man/chk_s3_class_strict.Rd @@ -54,6 +54,7 @@ Other id_checkers: \code{\link[=chk_is]{chk_is()}}, \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, -\code{\link[=chk_s4_class]{chk_s4_class()}} +\code{\link[=chk_s4_class]{chk_s4_class()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_s4_class.Rd b/man/chk_s4_class.Rd index 8c704e5b..d301fbfd 100644 --- a/man/chk_s4_class.Rd +++ b/man/chk_s4_class.Rd @@ -53,6 +53,7 @@ Other id_checkers: \code{\link[=chk_is]{chk_is()}}, \code{\link[=chk_r6_class]{chk_r6_class()}}, \code{\link[=chk_s3_class]{chk_s3_class()}}, -\code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}} +\code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, +\code{\link[=chk_s7_class]{chk_s7_class()}} } \concept{id_checkers} diff --git a/man/chk_s7_class.Rd b/man/chk_s7_class.Rd new file mode 100644 index 00000000..b1606b00 --- /dev/null +++ b/man/chk_s7_class.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/chk-s7-class.R +\name{chk_s7_class} +\alias{chk_s7_class} +\alias{vld_s7_class} +\title{Check Inherits from S7 Class} +\usage{ +chk_s7_class(x, class, x_name = NULL) + +vld_s7_class(x, class) +} +\arguments{ +\item{x}{The object to check.} + +\item{class}{A character vector specifying the possible class values.} + +\item{x_name}{A string of the name of object x or NULL.} +} +\value{ +The \code{chk_} function throws an informative error if the test fails or +returns the original object if successful so it can used in pipes. + +The \code{vld_} function returns a flag indicating whether the test was met. +} +\description{ +Checks inherits from S7 class using + +\code{inherits(x, "S7_object") && inherits(x, class)} +} +\details{ +All S7 objects inherit from the class \code{'S7_object'}, so +\code{chk_s7_class(x, "S7_object")} checks that \code{x} is an S7 object of any class. + +S7 is self-describing, so an S7 class generator (as returned by +\code{\link[S7:new_class]{S7::new_class()}}) is itself an S7 object, of class \code{'S7_class'}. +It is not an object of the class it generates. + +\code{class} is a character vector of class names matching those in \code{class(x)}. +S7 qualifies class names with the package they are defined in, so an S7 +class defined in package \code{foo} is matched by \code{'foo::ClassName'} and not by +\code{'ClassName'}. +S7 class objects are not accepted as \code{class}. +} +\section{Functions}{ +\itemize{ +\item \code{vld_s7_class()}: Validate Inherits from S7 Class + +}} +\examples{ +\dontshow{if (requireNamespace("S7", quietly = TRUE)) withAutoprint(\{ # examplesIf} +# chk_s7_class +Foo <- S7::new_class("Foo", package = "mypkg") +chk_s7_class(Foo(), "mypkg::Foo") +try(chk_s7_class(1, "numeric")) +\dontshow{\}) # examplesIf} +\dontshow{if (requireNamespace("S7", quietly = TRUE)) withAutoprint(\{ # examplesIf} +# vld_s7_class +Foo <- S7::new_class("Foo", package = "mypkg") +vld_s7_class(Foo(), "mypkg::Foo") +vld_s7_class(1, "numeric") +\dontshow{\}) # examplesIf} +} +\seealso{ +\code{\link[=inherits]{inherits()}} + +For more details about the use of this function, +please read the article +\code{vignette("chk-families")}. + +Other id_checkers: +\code{\link[=chk_class]{chk_class()}}, +\code{\link[=chk_data]{chk_data()}}, +\code{\link[=chk_is]{chk_is()}}, +\code{\link[=chk_r6_class]{chk_r6_class()}}, +\code{\link[=chk_s3_class]{chk_s3_class()}}, +\code{\link[=chk_s3_class_strict]{chk_s3_class_strict()}}, +\code{\link[=chk_s4_class]{chk_s4_class()}} +} +\concept{id_checkers} diff --git a/tests/testthat/test-chk-s7-class.R b/tests/testthat/test-chk-s7-class.R new file mode 100644 index 00000000..f64510d6 --- /dev/null +++ b/tests/testthat/test-chk-s7-class.R @@ -0,0 +1,93 @@ +skip_if_not_installed("S7") + +test_that("vld_s7_class", { + x <- S7::new_class("exampleS7class", package = "mypkg")() + expect_true(vld_s7_class(x, "mypkg::exampleS7class")) + expect_true(vld_s7_class(x, "S7_object")) + expect_false(vld_s7_class(x, "mypkg::otherS7class")) +}) + +test_that("vld_s7_class matches the package qualified class name", { + x <- S7::new_class("exampleS7class", package = "mypkg")() + expect_identical(class(x), c("mypkg::exampleS7class", "S7_object")) + expect_false(vld_s7_class(x, "exampleS7class")) +}) + +test_that("vld_s7_class is FALSE for non-S7 objects", { + expect_false(vld_s7_class(1, "numeric")) + expect_false(vld_s7_class(factor(1), "factor")) + expect_false(vld_s7_class( + getClass("MethodDefinition"), + "classRepresentation" + )) + skip_if_not_installed("R6") + expect_false(vld_s7_class(R6::R6Class("exampleR6class")$new(), "R6")) +}) + +test_that("vld_s7_class recognises inherited S7 classes", { + parent <- S7::new_class("ParentS7class", package = "mypkg") + child <- S7::new_class("ChildS7class", parent = parent, package = "mypkg") + x <- child() + expect_true(vld_s7_class(x, "mypkg::ChildS7class")) + expect_true(vld_s7_class(x, "mypkg::ParentS7class")) +}) + +test_that("vld_s7_class matches any of multiple classes", { + x <- S7::new_class("exampleS7class", package = "mypkg")() + expect_true(vld_s7_class(x, c("mypkg::other", "mypkg::exampleS7class"))) + expect_false(vld_s7_class(x, c("mypkg::other", "mypkg::another"))) +}) + +test_that("an S7 class generator is itself an S7 object", { + generator <- S7::new_class("exampleS7class", package = "mypkg") + # unlike R6, S7 is self-describing, so a generator is an S7 object, + # but only of class 'S7_class' and not of the class it generates + expect_identical(class(generator), c("S7_class", "S7_object")) + expect_true(vld_s7_class(generator, "S7_class")) + expect_false(vld_s7_class(generator, "mypkg::exampleS7class")) +}) + +test_that("chk_s7_class returns x invisibly", { + x <- S7::new_class("exampleS7class", package = "mypkg")() + expect_identical(chk_s7_class(x, "mypkg::exampleS7class"), x) + expect_invisible(chk_s7_class(x, "mypkg::exampleS7class")) +}) + +test_that("chk_s7_class errors informatively", { + expect_chk_error( + chk_s7_class(1, "numeric"), + "^`1` must inherit from S7 class 'numeric', not S3 class 'numeric'\\.$" + ) + expect_chk_error( + chk_s7_class(matrix(1), "numeric"), + paste0( + "^`matrix\\(1\\)` must inherit from S7 class 'numeric', ", + "not S3 classes 'matrix' and 'array'\\.$" + ) + ) + expect_chk_error( + chk_s7_class(getClass("MethodDefinition"), "numeric"), + paste0( + "^`getClass\\(\"MethodDefinition\"\\)` must inherit from S7 class ", + "'numeric', not S4 class 'classRepresentation'\\.$" + ) + ) +}) + +test_that("chk_s7_class errors informatively for an S7 object", { + x <- S7::new_class("exampleS7class", package = "mypkg")() + expect_chk_error( + chk_s7_class(x, c("a", "b")), + paste0( + "^`x` must inherit from S7 classes 'a' or 'b', ", + "not S7 classes 'mypkg::exampleS7class' and 'S7_object'\\.$" + ) + ) +}) + +test_that("chk_s7_class respects x_name", { + expect_chk_error( + chk_s7_class(1, "numeric", x_name = "`foo`"), + "^`foo` must inherit from S7 class 'numeric', not S3 class 'numeric'\\.$" + ) +}) diff --git a/tests/testthat/test-internal.R b/tests/testthat/test-internal.R index eac81561..9c1830fc 100644 --- a/tests/testthat/test-internal.R +++ b/tests/testthat/test-internal.R @@ -26,3 +26,10 @@ test_that("object_type identifies R6 objects", { # a generator is not an R6 object expect_identical(object_type(R6::R6Class("exampleR6class")), "S3") }) + +test_that("object_type identifies S7 objects", { + skip_if_not_installed("S7") + expect_identical(object_type(S7::new_class("exampleS7class")()), "S7") + # a generator is itself an S7 object + expect_identical(object_type(S7::new_class("exampleS7class")), "S7") +}) diff --git a/vignettes/chk-families.Rmd b/vignettes/chk-families.Rmd index 930b81ad..b40c1982 100644 --- a/vignettes/chk-families.Rmd +++ b/vignettes/chk-families.Rmd @@ -487,13 +487,14 @@ vld_orderset(c("A", "C"), c("A", "B", "C", "D")) # TRUE ### Class Checkers Check if the function input belongs to a class or type. -These functions check if `x` is an S3, S4 or R6 object of the specified class. +These functions check if `x` is an S3, S4, R6 or S7 object of the specified class. Function | Code :- | :--- `chk_s3_class(x, class)` | `!isS4(x) && inherits(x, class)` `chk_s4_class(x, class)` | `isS4(x) && methods::is(x, class)` `chk_r6_class(x, class)` | `inherits(x, "R6") && inherits(x, class)` +`chk_s7_class(x, class)` | `inherits(x, "S7_object") && inherits(x, class)` `chk_is()` checks if x inherits from a specified class, regardless of whether it is an S3 or S4 object.