diff --git a/.Rbuildignore b/.Rbuildignore index 97c33e19..d6aa1b4b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,6 +18,7 @@ ^compile_commands\.json$ ^\.cache$ ^\.vscode$ +^\.mcp-console$ ^revdep$ ^[.]?air[.]toml$ ^\.claude$ diff --git a/.github/workflows/test-ggplot2.yaml b/.github/workflows/test-ggplot2.yaml new file mode 100644 index 00000000..e6b52193 --- /dev/null +++ b/.github/workflows/test-ggplot2.yaml @@ -0,0 +1,55 @@ +on: + push: + branches: [main, master] + pull_request: + +name: test-ggplot2.yaml + +permissions: read-all + +jobs: + ggplot2: + runs-on: ubuntu-latest + name: ggplot2 (release) + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v6 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + dependencies: '"hard"' + extra-packages: any::ggplot2, local::. + install-pandoc: false + + - name: Test ggplot2 compatibility + run: | + library(S7) + library(ggplot2) + + output <- tempfile(fileext = ".png") + grDevices::png(filename = output) + + plot <- ggplot( + data = mtcars, + mapping = aes(wt, mpg, colour = factor(cyl)) + ) + + geom_point() + + theme(legend.key.spacing = grid::unit(1, "cm")) + built <- ggplot_build(plot) + grob <- ggplotGrob(plot) + print(plot) + invisible(grDevices::dev.off()) + + stopifnot( + inherits(plot, "ggplot"), + inherits(built, "ggplot_built"), + inherits(grob, "gtable"), + file.size(output) > 0 + ) + shell: Rscript {0} diff --git a/.gitignore b/.gitignore index 49abcdd5..7dd6efff 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ compile_commands.json .cache .vscode .claude/worktrees +.mcp-console/ diff --git a/NEWS.md b/NEWS.md index 8614a11a..f520cfcb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -49,7 +49,7 @@ * `S7_dispatch()` now gives a clear error when called from a function that is not an S7 generic, e.g. `unclass(generic)()`, instead of failing with a confusing message (#684). * `S7_class()` now returns a class specification for any R object, not just S7 objects. It returns the matching `class_*` for base types, a `new_S3_class()` wrapper for S3 objects, and the S4 class for S4 objects, so the result can be passed directly to `method()` or other S7 dispatch helpers (#559). * `S7_class_desc()` is a new exported helper that formats a class specification as a short human-readable string (#594). -* `S7_data()` now preserves the S3 class when the S7 class inherits from an S3 class, so e.g. `S7_data()` on a data.frame subclass now returns a data.frame (#380). +* `S7_data()` now preserves the S3 class when the S7 class inherits from a concrete S3 class, so e.g. `S7_data()` on a data.frame subclass now returns a data.frame (#380). * `S7_data<-()` now preserves attributes (like `names` or `dim`) from the replacement data instead of carrying over the originals, so resizing the underlying data works correctly (#478). * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556). diff --git a/R/S3.R b/R/S3.R index e8c4f3b4..2df5c4c4 100644 --- a/R/S3.R +++ b/R/S3.R @@ -112,6 +112,8 @@ new_S3_class <- function(class, constructor = NULL, validator = NULL) { validator = validator, abstract = abstract ) + # This tracks the class representation, not the S7 package version. + attr(out, "_version") <- 1L class(out) <- "S7_S3_class" out } @@ -148,6 +150,21 @@ is_S3_class <- function(x) { inherits(x, "S7_S3_class") } +# Detect the stub constructor emitted before S3 class definitions recorded +# whether they were abstract or had an explicit representation version. Used +# only for unversioned class definitions. +is_S3_stub_constructor <- function(constructor) { + if (!is.function(constructor)) { + return(FALSE) + } + call <- find_call(body(constructor), quote(sprintf)) + if (is.null(call)) { + return(FALSE) + } + fmt <- call[[2]] + is.character(fmt) && grepl("doesn't have a constructor", fmt, fixed = TRUE) +} + # ------------------------------------------------------------------------- # Pull out validation functions so hit by code coverage diff --git a/R/class-spec.R b/R/class-spec.R index 1952b2ff..96a3ab88 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -326,10 +326,16 @@ class_inherits <- function(x, what) { missing = FALSE, any = TRUE, S4 = methods::is(x, what), - S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), + # Class-vector-only objects have no stored class for `has_S7_class()`. + S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = some(what$classes, class_inherits, x = x), - S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), + S7_S3 = !isS4(x) && + class_dispatch_inherits( + what$class, + class(x), + version = attr(what, "_version", exact = TRUE) + ), S7_external = inherits(x, "S7_object") && inherits(x, what$class_name), ) } @@ -373,6 +379,12 @@ class_extends <- function(child, parent) { } else if (is_external_class(parent)) { parent <- resolve_external_class_req(parent) class_extends(child, parent) + } else if (is_S3_class(child) && is_S3_class(parent)) { + class_dispatch_inherits( + parent$class, + child$class, + version = attr(parent, "_version", exact = TRUE) + ) } else if (is_S4_class(child) || is_S4_class(parent)) { child <- class_extends_S4_name(child) parent <- class_extends_S4_name(parent) @@ -431,6 +443,37 @@ obj_dispatch <- function(x) { # helpers ----------------------------------------------------------------- +# Does `child`'s S3 dispatch inherit from `parent`'s? +# +# ggplot2 4.0.x relies on the S7 0.2.2 behavior where an S3 class +# specification can match before shared trailing classes (#747), e.g. `"Coord"` +# in c("CoordCartesian", "Coord", "ggproto", "gg"). Unversioned definitions +# preserve that behavior for backward compatibility. Current definitions and +# downcasts use strict tail matching. +# S7 wrappers of base/S3 types append "S7_object", which we ignore. +class_dispatch_inherits <- function(parent, child, version) { + if (!is.null(version)) { + return(class_dispatch_extends(parent, child)) + } + + parent <- drop_S7_object(parent) + child <- drop_S7_object(child) + n <- length(parent) + if (length(child) < n) { + return(FALSE) + } + if (n == 1L) { + return(parent[[1L]] %in% child) + } + + for (start in seq_len(length(child) - n + 1L)) { + if (identical(child[seq.int(start, length.out = n)], parent)) { + return(TRUE) + } + } + FALSE +} + # Does `child`'s dispatch extend `parent`'s? Subclassing only ever prepends # more specific classes, so `parent`'s classes must form the tail of `child`'s. # S7 wrappers of base/S3 types append "S7_object", which we ignore. diff --git a/R/class.R b/R/class.R index 390e59eb..112a0d85 100644 --- a/R/class.R +++ b/R/class.R @@ -335,7 +335,11 @@ class_is_abstract <- function(class) { if (is_class(class)) { attr(class, "abstract", TRUE) # called on construction } else if (is_S3_class(class)) { - class$abstract %||% is_default_constructor(class$constructor) + class$abstract %||% + is_default_constructor( + class$constructor, + legacy_S3 = is.null(attr(class, "_version", exact = TRUE)) + ) } else { FALSE } diff --git a/R/constructor.R b/R/constructor.R index a87af997..9bd91ebf 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -234,9 +234,11 @@ constructor_args <- function( # helpers ----------------------------------------------------------------- -# Was this constructor generated by S7 or supplied by the user? -is_default_constructor <- function(constructor) { - inherits(constructor, "S7_constructor") +# Was this constructor generated by S7 or supplied by the user? Before S7 +# constructors were tagged, abstract S3 classes used a recognisable stub. +is_default_constructor <- function(constructor, legacy_S3 = FALSE) { + inherits(constructor, "S7_constructor") || + (legacy_S3 && is_S3_stub_constructor(constructor)) } #' @export diff --git a/R/data.R b/R/data.R index da59eaf8..649d812e 100644 --- a/R/data.R +++ b/R/data.R @@ -2,9 +2,10 @@ #' #' When an S7 class inherits from an existing base type, it can be useful #' to work with the underlying object, i.e. the S7 object stripped of its -#' S7 class and properties. If the class inherits from an S3 class, -#' `S7_data()` preserves the S3 class so the result remains a valid -#' object of that type. +#' S7 class and properties. If the class inherits from a concrete S3 class, +#' `S7_data()` preserves the S3 class so the result remains a valid object of +#' that type. Abstract S3 marker classes are stripped because they cannot +#' represent valid standalone objects. #' #' @inheritParams prop #' @param value Object used to replace the underlying data. @@ -34,7 +35,7 @@ S7_data <- function(object) { ) base <- base_parent(S7_class(object)) - if (is_S3_class(base)) { + if (is_S3_class(base) && !class_is_abstract(base)) { class(out) <- base$class } out diff --git a/man/S7_data.Rd b/man/S7_data.Rd index e3343aaf..14947d7e 100644 --- a/man/S7_data.Rd +++ b/man/S7_data.Rd @@ -25,9 +25,10 @@ invisibly. \description{ When an S7 class inherits from an existing base type, it can be useful to work with the underlying object, i.e. the S7 object stripped of its -S7 class and properties. If the class inherits from an S3 class, -\code{S7_data()} preserves the S3 class so the result remains a valid -object of that type. +S7 class and properties. If the class inherits from a concrete S3 class, +\code{S7_data()} preserves the S3 class so the result remains a valid object of +that type. Abstract S3 marker classes are stripped because they cannot +represent valid standalone objects. } \examples{ Text := new_class(parent = class_character) diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 9fb56fa6..00e4ed9c 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -107,6 +107,17 @@ Error in `new_class()`: ! `validator` must be function(self), not function(). +# inheritance uses strict matching for current S3 classes + + Code + Child := new_class(parent = Parent, package = NULL, properties = list( + coordinates = new_S3_class(c("CoordCartesian", "Coord", "ggproto", "gg")))) + Condition + Error in `new_class()`: + ! @coordinates must narrow @coordinates. + - @coordinates is S3. + - @coordinates is S3. + # inheritance doesn't let child properties widen or change the parent's type Code @@ -197,6 +208,14 @@ Error in `new_object()`: ! `_parent` must be an instance of , not . +# new_object() validates legacy concrete S3 parents + + Code + Foo(list()) + Condition + Error in `new_object()`: + ! `_parent` must be an instance of S3, not . + # new_object() errors if `_parent` is supplied but class has no parent Code diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index 8a97da1f..5108f1f4 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -181,6 +181,15 @@ Error in `@S7_union`: ! @S7_union must be or , not +# current S3 properties use strict class matching + + Code + Plot(coordinates = coord) + Condition + Error in `Plot()`: + ! object properties are invalid: + - @coordinates must be S3, not S3 + # as_properties() gives useful error messages Code diff --git a/tests/testthat/test-S3.R b/tests/testthat/test-S3.R index b2f5a29b..e4f42844 100644 --- a/tests/testthat/test-S3.R +++ b/tests/testthat/test-S3.R @@ -2,6 +2,13 @@ test_that("new_S3_class has a print method", { expect_snapshot(new_S3_class(c("ordered", "factor"))) }) +test_that("new_S3_class() records its representation version", { + expect_identical( + attr(new_S3_class("foo"), "_version", exact = TRUE), + 1L + ) +}) + test_that("can construct objects that extend S3 classes", { ordered2 := new_class(parent = class_factor, package = NULL) x <- ordered2(c(1L, 2L, 1L), letters[1:3]) diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 869b0b26..3c28b6b7 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -105,6 +105,47 @@ test_that("inheritance lets child properties narrow the parent's type", { )) }) +test_that("inheritance supports legacy S3 classes with shared base classes", { + coord <- new_S3_class("Coord") + attr(coord, "_version") <- NULL + Parent := new_class( + package = NULL, + properties = list(coordinates = coord) + ) + + expect_no_error({ + Child := new_class( + parent = Parent, + package = NULL, + properties = list( + coordinates = new_S3_class( + c("CoordCartesian", "Coord", "ggproto", "gg") + ) + ) + ) + }) +}) + +test_that("inheritance uses strict matching for current S3 classes", { + Parent := new_class( + package = NULL, + properties = list(coordinates = new_S3_class("Coord")) + ) + + expect_snapshot( + Child := new_class( + parent = Parent, + package = NULL, + properties = list( + coordinates = new_S3_class( + c("CoordCartesian", "Coord", "ggproto", "gg") + ) + ) + ), + error = TRUE + ) +}) + test_that("inheritance lets child properties narrow with S4 inheritance", { local_S4_classes() S4PropertyParent <- setClass("S4PropertyParent", slots = c(x = "numeric")) @@ -422,13 +463,49 @@ test_that("new_object() allows arbitrary placeholder for abstract S3 parents (#6 expect_no_error(Concrete(list(1, "A"))) }) -test_that("new_object() has fallback for S3 classes created by older S7 (#686)", { - old_s3 <- class_POSIXt - old_s3$abstract <- NULL - Foo := new_class(parent = old_s3, constructor = \(x) new_object(x)) +test_that("new_object() supports legacy abstract S3 classes (#686, #747)", { + old_s3 <- structure( + list( + class = "POSIXt", + constructor = local({ + class <- "POSIXt" + function(.data) { + stop( + sprintf("S3 class <%s> doesn't have a constructor", class[[1]]), + call. = FALSE + ) + } + }), + validator = NULL + ), + class = "S7_S3_class" + ) + Foo := new_class( + parent = old_s3, + package = NULL, + constructor = \(x) new_object(x) + ) expect_no_error(Foo(list(1, "A"))) }) +test_that("new_object() validates legacy concrete S3 parents", { + old_s3 <- structure( + list( + class = "foo", + constructor = function(.data) structure(.data, class = "foo"), + validator = NULL + ), + class = "S7_S3_class" + ) + Foo := new_class( + parent = old_s3, + package = NULL, + constructor = \(x) new_object(x) + ) + + expect_snapshot(Foo(list()), error = TRUE) +}) + test_that("new_object() errors if `_parent` is supplied but class has no parent", { NoParent := new_class( package = NULL, diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index b339ea37..5752fa7b 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -51,6 +51,20 @@ test_that("S7_data preserves S7 properties when setting data", { expect_equal(names(x), "z") }) +test_that("S7_data strips abstract S3 parents", { + marker <- new_S3_class("marker") + Wrapper := new_class( + parent = marker, + package = NULL, + constructor = \(x = list()) new_object(x) + ) + + expect_identical( + S7_data(Wrapper(x = list(a = 1))), + list(a = 1) + ) +}) + test_that("S7_data preserves S3 class from parent (#380)", { text := new_class(class_character) mydf := new_class(class_data.frame) diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index b45ead5d..f5b57fe4 100644 --- a/tests/testthat/test-inherits.R +++ b/tests/testthat/test-inherits.R @@ -22,6 +22,13 @@ test_that("has_S7_class() recognises objects that don't store a class", { expect_false(has_S7_class(NULL)) }) +test_that("S7_inherits() matches class-vector-only objects to S7 classes", { + foo := new_class(parent = class_list, package = NULL) + x <- structure(list(), class = class(foo())) + + expect_identical(S7_inherits(x, foo), TRUE) +}) + test_that("accepts any class specification (#556)", { # base expect_true(S7_inherits(1L, class_integer)) diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index 74936731..f95cd530 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -497,6 +497,34 @@ test_that("properties can be base, S3, S4, S7, or S7 union", { }) }) +test_that("legacy S3 properties accept subclasses with shared base classes (#747)", { + coord_class <- new_S3_class("Coord") + attr(coord_class, "_version") <- NULL + Plot := new_class( + package = NULL, + properties = list(coordinates = coord_class) + ) + coord <- structure( + list(), + class = c("CoordCartesian", "Coord", "ggproto", "gg") + ) + + expect_no_error(Plot(coordinates = coord)) +}) + +test_that("current S3 properties use strict class matching", { + Plot := new_class( + package = NULL, + properties = list(coordinates = new_S3_class("Coord")) + ) + coord <- structure( + list(), + class = c("CoordCartesian", "Coord", "ggproto", "gg") + ) + + expect_snapshot(Plot(coordinates = coord), error = TRUE) +}) + test_that("as_properties normalises properties", { expect_equal(as_properties(NULL), list()) expect_equal(