Restore compatibility with release ggplot2

.Rbuildignore

@@ -18,6 +18,7 @@
 ^compile_commands\.json$
 ^\.cache$
 ^\.vscode$
+^\.mcp-console$
 ^revdep$
 ^[.]?air[.]toml$
 ^\.claude$

.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}

.gitignore

@@ -7,3 +7,4 @@ compile_commands.json
 .cache
 .vscode
 .claude/worktrees
+.mcp-console/

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).

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
 

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.

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
   }

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

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

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()`:
+      ! <Child>@coordinates must narrow <Parent>@coordinates.
+      - <Parent>@coordinates is S3<Coord>.
+      - <Child>@coordinates is S3<CoordCartesian/Coord/ggproto/gg>.
+
 # 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 <integer>, not <character>.
 
+# new_object() validates legacy concrete S3 parents
+
+    Code
+      Foo(list())
+    Condition
+      Error in `new_object()`:
+      ! `_parent` must be an instance of S3<foo>, not <list>.
+
 # new_object() errors if `_parent` is supplied but class has no parent
 
     Code

tests/testthat/_snaps/property.md

@@ -181,6 +181,15 @@
       Error in `<my_class>@S7_union`:
       ! <my_class>@S7_union must be <integer> or <logical>, not <character>
 
+# current S3 properties use strict class matching
+
+    Code
+      Plot(coordinates = coord)
+    Condition
+      Error in `Plot()`:
+      ! <Plot> object properties are invalid:
+      - @coordinates must be S3<Coord>, not S3<CoordCartesian/Coord/ggproto/gg>
+
 # as_properties() gives useful error messages
 
     Code

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])