From ce735f4efba92079bc7062728eb77fad5278e2d7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 25 Aug 2026 21:57:30 -0400 Subject: [PATCH 01/11] ignore console logs --- .gitignore | 1 + 1 file changed, 1 insertion(+) 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/ From befc295e0157c72da4bd3a7e2f4b9b57cfb4613e Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 25 Aug 2026 22:11:22 -0400 Subject: [PATCH 02/11] Restore legacy abstract S3 class detection --- R/S3.R | 15 +++++++++++++++ R/class.R | 4 +++- tests/testthat/test-class.R | 11 ++++++++++- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/R/S3.R b/R/S3.R index e8c4f3b4..194cd921 100644 --- a/R/S3.R +++ b/R/S3.R @@ -148,6 +148,21 @@ is_S3_class <- function(x) { inherits(x, "S7_S3_class") } +# Detect the stub constructor that `new_S3_class()` inserted before abstract +# S3 classes had explicit metadata. Needed for class definitions serialized by +# older versions of S7. +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.R b/R/class.R index 390e59eb..75f22cbf 100644 --- a/R/class.R +++ b/R/class.R @@ -335,7 +335,9 @@ 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) || + is_S3_stub_constructor(class$constructor)) } else { FALSE } diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 869b0b26..599688bd 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -422,9 +422,18 @@ 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)", { +test_that("new_object() supports legacy abstract S3 classes (#686, #747)", { old_s3 <- class_POSIXt old_s3$abstract <- NULL + old_s3$constructor <- local({ + class <- old_s3$class + function(.data) { + stop( + sprintf("S3 class <%s> doesn't have a constructor", class[[1]]), + call. = FALSE + ) + } + }) Foo := new_class(parent = old_s3, constructor = \(x) new_object(x)) expect_no_error(Foo(list(1, "A"))) }) From 9d3823946cc8e08e68843c60cabc45412e590aab Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 27 Aug 2026 09:38:38 -0400 Subject: [PATCH 03/11] Accept S3 parents within class vectors --- R/class-spec.R | 27 ++++++++++++++++++++++++++- tests/testthat/test-class.R | 19 +++++++++++++++++++ tests/testthat/test-property.R | 13 +++++++++++++ 3 files changed, 58 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 1952b2ff..05c8f746 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -329,7 +329,7 @@ class_inherits <- function(x, what) { S7 = has_S7_class(x) && 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)), S7_external = inherits(x, "S7_object") && inherits(x, what$class_name), ) } @@ -373,6 +373,8 @@ 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) } else if (is_S4_class(child) || is_S4_class(parent)) { child <- class_extends_S4_name(child) parent <- class_extends_S4_name(parent) @@ -431,6 +433,29 @@ obj_dispatch <- function(x) { # helpers ----------------------------------------------------------------- +# Does `child`'s S3 dispatch inherit from `parent`'s? S3 systems may prepend +# more specific classes and append shared base classes, so `parent` must appear +# as a contiguous, ordered run in `child`. +# S7 wrappers of base/S3 types append "S7_object", which we ignore. +class_dispatch_inherits <- function(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/tests/testthat/test-class.R b/tests/testthat/test-class.R index 599688bd..c178ec72 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -105,6 +105,25 @@ test_that("inheritance lets child properties narrow the parent's type", { )) }) +test_that("inheritance lets S3 child properties retain shared base classes", { + Parent := new_class( + package = NULL, + properties = list(coordinates = new_S3_class("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 lets child properties narrow with S4 inheritance", { local_S4_classes() S4PropertyParent <- setClass("S4PropertyParent", slots = c(x = "numeric")) diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index 74936731..cb98b56a 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -497,6 +497,19 @@ test_that("properties can be base, S3, S4, S7, or S7 union", { }) }) +test_that("S3 properties accept subclasses with shared base classes (#747)", { + Plot := new_class( + package = NULL, + properties = list(coordinates = new_S3_class("Coord")) + ) + coord <- structure( + list(), + class = c("CoordCartesian", "Coord", "ggproto", "gg") + ) + + expect_no_error(Plot(coordinates = coord)) +}) + test_that("as_properties normalises properties", { expect_equal(as_properties(NULL), list()) expect_equal( From 93409927978c02d4995f31f2563d3d99587dc475 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 27 Aug 2026 10:39:03 -0400 Subject: [PATCH 04/11] Strip abstract S3 classes from S7_data --- NEWS.md | 2 +- R/data.R | 9 +++++---- man/S7_data.Rd | 7 ++++--- tests/testthat/test-data.R | 14 ++++++++++++++ 4 files changed, 24 insertions(+), 8 deletions(-) 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/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/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) From 562fe568a6c7ce7c2459ba388b921f5265d7527f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 27 Aug 2026 10:42:43 -0400 Subject: [PATCH 05/11] Recognize class-vector-only S7 objects --- R/class-spec.R | 2 +- tests/testthat/test-inherits.R | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 05c8f746..dceafaa7 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -326,7 +326,7 @@ 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)), + 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_inherits(what$class, class(x)), diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index b45ead5d..c7dc432e 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() recognises class-vector-only S7 objects", { + 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)) From 3bacebc7866204a420c0a4c73dc38c96bd5c7d34 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 31 Aug 2026 13:01:31 -0400 Subject: [PATCH 06/11] Record S3 representation versions New S3 class definitions now carry a representation version. Limit legacy abstract-class detection to unversioned definitions while retaining the older inheritance match needed by ggplot2. --- R/S3.R | 8 ++++-- R/class-spec.R | 11 ++++++-- R/class.R | 2 +- tests/testthat/_snaps/class.md | 8 ++++++ tests/testthat/test-S3.R | 7 +++++ tests/testthat/test-class.R | 51 ++++++++++++++++++++++++++-------- 6 files changed, 68 insertions(+), 19 deletions(-) diff --git a/R/S3.R b/R/S3.R index 194cd921..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,9 +150,9 @@ is_S3_class <- function(x) { inherits(x, "S7_S3_class") } -# Detect the stub constructor that `new_S3_class()` inserted before abstract -# S3 classes had explicit metadata. Needed for class definitions serialized by -# older versions of S7. +# 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) diff --git a/R/class-spec.R b/R/class-spec.R index dceafaa7..6e0a8dbe 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -433,9 +433,14 @@ obj_dispatch <- function(x) { # helpers ----------------------------------------------------------------- -# Does `child`'s S3 dispatch inherit from `parent`'s? S3 systems may prepend -# more specific classes and append shared base classes, so `parent` must appear -# as a contiguous, ordered run in `child`. +# 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"). Preserve that behavior for +# backward compatibility, while requiring multi-class specifications to be +# contiguous and ordered. `class_dispatch_extends()` remains tail-only for +# downcasts. # S7 wrappers of base/S3 types append "S7_object", which we ignore. class_dispatch_inherits <- function(parent, child) { parent <- drop_S7_object(parent) diff --git a/R/class.R b/R/class.R index 75f22cbf..d0fb6c0e 100644 --- a/R/class.R +++ b/R/class.R @@ -336,7 +336,7 @@ class_is_abstract <- function(class) { attr(class, "abstract", TRUE) # called on construction } else if (is_S3_class(class)) { class$abstract %||% - (is_default_constructor(class$constructor) || + (is.null(attr(class, "_version", exact = TRUE)) && is_S3_stub_constructor(class$constructor)) } else { FALSE diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 9fb56fa6..56822cce 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -197,6 +197,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/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 c178ec72..667c5074 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -442,21 +442,48 @@ test_that("new_object() allows arbitrary placeholder for abstract S3 parents (#6 }) test_that("new_object() supports legacy abstract S3 classes (#686, #747)", { - old_s3 <- class_POSIXt - old_s3$abstract <- NULL - old_s3$constructor <- local({ - class <- old_s3$class - function(.data) { - stop( - sprintf("S3 class <%s> doesn't have a constructor", class[[1]]), - call. = FALSE - ) - } - }) - Foo := new_class(parent = old_s3, constructor = \(x) new_object(x)) + 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, From 876afd70d714992d50e3adadddbbac6826bbafa7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 31 Aug 2026 13:01:46 -0400 Subject: [PATCH 07/11] Exercise ggplot2 drawing in CI Add a release-R job that builds and prints a ggplot2 plot on a temporary PNG device without adding ggplot2 to Suggests. --- .github/workflows/R-CMD-check.yaml | 42 ++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 0ac7d7d6..0744fea9 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -55,3 +55,45 @@ jobs: with: upload-snapshots: true build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' + + 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() + + geom_point(data = mtcars, mapping = aes(wt, mpg)) + 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} From 0a7108502ab96062cb2a1c2e4d80495bdeabad3a Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Sep 2026 12:07:06 -0400 Subject: [PATCH 08/11] Move ggplot2 compatibility test to a dedicated workflow Keep R-CMD-check focused on package checks and run the ggplot2 compatibility test in test-ggplot2.yaml on pushes and pull requests. --- .github/workflows/R-CMD-check.yaml | 42 ------------------------ .github/workflows/test-ggplot2.yaml | 51 +++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 42 deletions(-) create mode 100644 .github/workflows/test-ggplot2.yaml diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 0744fea9..0ac7d7d6 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -55,45 +55,3 @@ jobs: with: upload-snapshots: true build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' - - 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() + - geom_point(data = mtcars, mapping = aes(wt, mpg)) - 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/.github/workflows/test-ggplot2.yaml b/.github/workflows/test-ggplot2.yaml new file mode 100644 index 00000000..e7f9005b --- /dev/null +++ b/.github/workflows/test-ggplot2.yaml @@ -0,0 +1,51 @@ +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() + + geom_point(data = mtcars, mapping = aes(wt, mpg)) + 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} From d2179aa2f67d73728cdcff29096bae1a37312f81 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Sep 2026 14:12:45 -0400 Subject: [PATCH 09/11] Limit legacy S3 compatibility shims --- R/class-spec.R | 27 ++++++++++++++++++++------- R/class.R | 6 ++++-- R/constructor.R | 8 +++++--- tests/testthat/_snaps/class.md | 11 +++++++++++ tests/testthat/_snaps/property.md | 9 +++++++++ tests/testthat/test-class.R | 26 ++++++++++++++++++++++++-- tests/testthat/test-inherits.R | 2 +- tests/testthat/test-property.R | 19 +++++++++++++++++-- 8 files changed, 91 insertions(+), 17 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 6e0a8dbe..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), + # 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_inherits(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), ) } @@ -374,7 +380,11 @@ class_extends <- function(child, 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) + 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) @@ -437,12 +447,15 @@ obj_dispatch <- function(x) { # # 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"). Preserve that behavior for -# backward compatibility, while requiring multi-class specifications to be -# contiguous and ordered. `class_dispatch_extends()` remains tail-only for -# downcasts. +# 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) { +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) diff --git a/R/class.R b/R/class.R index d0fb6c0e..112a0d85 100644 --- a/R/class.R +++ b/R/class.R @@ -336,8 +336,10 @@ class_is_abstract <- function(class) { attr(class, "abstract", TRUE) # called on construction } else if (is_S3_class(class)) { class$abstract %||% - (is.null(attr(class, "_version", exact = TRUE)) && - is_S3_stub_constructor(class$constructor)) + 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/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 56822cce..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 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-class.R b/tests/testthat/test-class.R index 667c5074..3c28b6b7 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -105,10 +105,12 @@ test_that("inheritance lets child properties narrow the parent's type", { )) }) -test_that("inheritance lets S3 child properties retain shared base classes", { +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 = new_S3_class("Coord")) + properties = list(coordinates = coord) ) expect_no_error({ @@ -124,6 +126,26 @@ test_that("inheritance lets S3 child properties retain shared base classes", { }) }) +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")) diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index c7dc432e..f5b57fe4 100644 --- a/tests/testthat/test-inherits.R +++ b/tests/testthat/test-inherits.R @@ -22,7 +22,7 @@ test_that("has_S7_class() recognises objects that don't store a class", { expect_false(has_S7_class(NULL)) }) -test_that("S7_inherits() recognises class-vector-only S7 objects", { +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())) diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index cb98b56a..f95cd530 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -497,10 +497,12 @@ test_that("properties can be base, S3, S4, S7, or S7 union", { }) }) -test_that("S3 properties accept subclasses with shared base classes (#747)", { +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 = new_S3_class("Coord")) + properties = list(coordinates = coord_class) ) coord <- structure( list(), @@ -510,6 +512,19 @@ test_that("S3 properties accept subclasses with shared base classes (#747)", { 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( From 2e694b75efebc3eec932b0034c6c0509b81afb37 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Sep 2026 14:12:45 -0400 Subject: [PATCH 10/11] Exercise ggplot2 margin compatibility in CI --- .github/workflows/test-ggplot2.yaml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test-ggplot2.yaml b/.github/workflows/test-ggplot2.yaml index e7f9005b..e6b52193 100644 --- a/.github/workflows/test-ggplot2.yaml +++ b/.github/workflows/test-ggplot2.yaml @@ -35,8 +35,12 @@ jobs: output <- tempfile(fileext = ".png") grDevices::png(filename = output) - plot <- ggplot() + - geom_point(data = mtcars, mapping = aes(wt, mpg)) + 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) From 9c33bd003a0420d9f49fba3c98372b53fd87b45e Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Sep 2026 14:23:13 -0400 Subject: [PATCH 11/11] Exclude mcp-console state from package builds --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) 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$