Declare compatibility names in the S7 class hierarchy

NEWS.md

@@ -1,4 +1,6 @@
 # ggplot2 (development version)
+
+* S7 subclasses now inherit the compatibility names `ggplot`, `ggplot_built`, `uneval`, and the legacy theme element names from their class definitions.
 
 * Faceting by a named vector no longer partially matches the `names` attribute
   in place of the `n` attribute (@taekop, #6891).

R/all-classes.R

@@ -56,6 +56,16 @@ NULL
 #' @keywords internal
 NULL
 
+# Compatibility function to include pre-4.0.0 S3 class names in S7 hierarchy
+legacy_parent <- function(name, parent = NULL) {
+  S7::new_class(
+    name = name,
+    parent = parent %||% S7::S7_object,
+    package = NULL,
+    abstract = TRUE
+  )
+}
+
 #' @rdname class_definitions
 #' @section S7 classes:
 #' * `class_gg` is an abstract S7 class to used invoke similar behaviour among
@@ -282,14 +292,12 @@ class_labels <- S7::new_class(
 #' @export
 class_mapping <- S7::new_class(
   "mapping",
-  parent = class_S3_gg,
+  parent = S7::new_S3_class(c("uneval", "gg")),
   constructor = function(x = list(), ..., env = globalenv()) {
     warn_dots_empty()
     check_object(x, is.list, "a {.cls list}")
     x <- lapply(x, new_aesthetic, env = env)
-    x <- S7::new_object(x)
-    class(x) <- union(c("ggplot2::mapping", "uneval"), class(x))
-    x
+    S7::new_object(x)
   }
 )
 
@@ -321,7 +329,8 @@ class_mapping <- S7::new_class(
 #' @export
 class_ggplot <- S7::new_class(
   name = "ggplot",
-  parent = class_gg,
+  # This abstract parent declares the unnamespaced S3 compatibility name.
+  parent = legacy_parent("ggplot", class_gg),
   properties = list(
     data = S7::class_any,
     layers = S7::class_list,
@@ -388,8 +397,8 @@ class_ggplot <- S7::new_class(
 #' @keywords internal
 #' @export
 class_ggplot_built <- S7::new_class(
-  "ggplot_built",
-  parent = class_gg,
+  name = "ggplot_built",
+  parent = legacy_parent("ggplot_built", class_gg),
   properties = list(
     data = S7::class_list,
     layout = class_layout,

R/plot-build.R

@@ -181,12 +181,7 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) {
   # Consolidate alt-text
   plot@labels$alt <- get_alt_text(plot)
 
-  build <- class_ggplot_built(data = data, layout = layout, plot = plot)
-  class(build) <- union(
-    c("ggplot2::ggplot_built", "ggplot_built"),
-    class(build)
-  )
-  build
+  class_ggplot_built(data = data, layout = layout, plot = plot)
 }
 
 #' @export

R/plot.R

@@ -129,7 +129,8 @@ ggplot.default <-
       mapping = mapping,
       plot_env = environment
     )
-    class(p) <- union(union(c("ggplot2::ggplot", "ggplot"), class(p)), "gg")
+    # Keep `gg` after `S7_object` so its S3 `+` method remains a fallback.
+    class(p) <- c(class(p), "gg")
 
     set_last_plot(p)
     p

R/theme-elements.R

@@ -83,20 +83,19 @@ NULL
 
 #' @export
 #' @rdname element
-element <- S7::new_class("element", abstract = TRUE)
+element <- S7::new_class(
+  name = "element",
+  parent = legacy_parent("element"),
+  abstract = TRUE
+)
 
 #' @export
 #' @rdname element
 element_blank <- S7::new_class(
-  "element_blank",
-  parent = element,
+  name = "element_blank",
+  parent = legacy_parent("element_blank", element),
   constructor = function() {
-    obj <- S7::new_object(S7::S7_object())
-    class(obj) <- union(
-      union(c("ggplot2::element_blank", "element_blank"), class(obj)),
-      "element"
-    )
-    obj
+    S7::new_object(S7::S7_object())
   }
 )
 
@@ -133,8 +132,8 @@ element_props <- list(
 #' @export
 #' @rdname element
 element_rect <- S7::new_class(
-  "element_rect",
-  parent = element,
+  name = "element_rect",
+  parent = legacy_parent("element_rect", element),
   properties = element_props[c(
     "fill",
     "colour",
@@ -159,7 +158,7 @@ element_rect <- S7::new_class(
       deprecate("3.4.0", "element_rect(size)", "element_rect(linewidth)")
       linewidth <- size
     }
-    obj <- S7::new_object(
+    S7::new_object(
       S7::S7_object(),
       fill = fill,
       colour = color %||% colour,
@@ -168,11 +167,6 @@ element_rect <- S7::new_class(
       linejoin = linejoin,
       inherit.blank = inherit.blank
     )
-    class(obj) <- union(
-      union(c("ggplot2::element_rect", "element_rect"), class(obj)),
-      "element"
-    )
-    obj
   }
 )
 
@@ -182,8 +176,8 @@ element_rect <- S7::new_class(
 #' @param lineend Line end style, one of `"round"`, `"butt"` or `"square"`.
 #' @param arrow Arrow specification, as created by [grid::arrow()]
 element_line <- S7::new_class(
-  "element_line",
-  parent = element,
+  name = "element_line",
+  parent = legacy_parent("element_line", element),
   properties = element_props[c(
     "colour",
     "linewidth",
@@ -213,7 +207,7 @@ element_line <- S7::new_class(
       linewidth <- size
     }
     colour <- color %||% colour
-    obj <- S7::new_object(
+    S7::new_object(
       S7::S7_object(),
       colour = colour,
       linewidth = linewidth,
@@ -224,11 +218,6 @@ element_line <- S7::new_class(
       arrow.fill = arrow.fill %||% colour,
       inherit.blank = inherit.blank
     )
-    class(obj) <- union(
-      union(c("ggplot2::element_line", "element_line"), class(obj)),
-      "element"
-    )
-    obj
   }
 )
 
@@ -254,8 +243,8 @@ element_line <- S7::new_class(
 #' @export
 #' @rdname element
 element_text <- S7::new_class(
-  "element_text",
-  parent = element,
+  name = "element_text",
+  parent = legacy_parent("element_text", element),
   properties = element_props[c(
     "family",
     "face",
@@ -313,7 +302,7 @@ element_text <- S7::new_class(
     }
 
     colour <- color %||% colour
-    obj <- S7::new_object(
+    S7::new_object(
       S7::S7_object(),
       family = family,
       face = face,
@@ -330,11 +319,6 @@ element_text <- S7::new_class(
       fontweight = NA_real_,
       fontwidth = NA_real_
     )
-    class(obj) <- union(
-      union(c("ggplot2::element_text", "element_text"), class(obj)),
-      "element"
-    )
-    obj
   }
 )
 

tests/testthat/test-aes.R

@@ -257,3 +257,18 @@ test_that("alpha is drawn correctly", {
       geom_point(color = I("#cc0000"), size = I(50), alpha = I(0.27))
   )
 })
+
+test_that("mapping subclasses retain legacy classes", {
+  MappingChild <- S7::new_class(
+    name = "MappingChild",
+    parent = class_mapping,
+    package = NULL
+  )
+  mapping <- aes(x = mpg)
+  child <- MappingChild(x = as.list(mapping))
+
+  expect_s7_class(child, MappingChild)
+  expect_identical(class(child)[-1], class(mapping))
+  expect_s3_class(child, "uneval")
+  expect_identical(as.list(child), as.list(mapping))
+})

tests/testthat/test-plot-build.R

@@ -1,3 +1,20 @@
+test_that("built plots retain legacy classes when converted to S7 subclasses", {
+  BuiltChild <- S7::new_class(
+    name = "BuiltChild",
+    parent = class_ggplot_built,
+    package = NULL
+  )
+  built <- ggplot_build(ggplot())
+  child <- S7::convert(built, to = BuiltChild)
+
+  expect_s7_class(child, BuiltChild)
+  expect_s7_class(child, class_gg)
+  expect_identical(class(child)[-1], class(built))
+  expect_s3_class(child, "ggplot_built")
+  expect_identical(child@data, built@data)
+  expect_s3_class(ggplot_gtable(child), "gtable")
+})
+
 # Test the complete path from plot specification to rendered data
 df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
 

tests/testthat/test-plot.R

@@ -1,3 +1,29 @@
+test_that("plot subclasses retain legacy classes and S7 dispatch", {
+  PlotChild <- S7::new_class(
+    name = "PlotChild",
+    parent = class_ggplot,
+    package = NULL
+  )
+  p <- ggplot() + geom_blank()
+  child <- PlotChild(data = p@data, layers = p@layers, mapping = p@mapping)
+
+  expect_s7_class(child, PlotChild)
+  expect_s7_class(child, class_gg)
+  expect_s3_class(child, "ggplot")
+  expect_identical(is_ggplot(child), TRUE)
+  expect_identical(child@layers, p@layers)
+  expect_s7_class(ggplot_build(child), class_ggplot_built)
+
+  S7::method(`+`, list(PlotChild, S7::class_character)) <- function(e1, e2) e2
+  expect_identical(child + "child method", "child method")
+
+  legacy_class <- function(x) UseMethod("legacy_class")
+  legacy_class.ggplot <- function(x) "ggplot"
+  legacy_class.gg <- function(x) "gg"
+  legacy_class.S7_object <- function(x) "S7_object"
+  expect_identical(legacy_class(child), "ggplot")
+})
+
 test_that("ggplot() throws informative errors", {
   expect_snapshot_error(ggplot(mapping = letters))
   expect_snapshot_error(ggplot(data))

tests/testthat/test-theme-elements.R

@@ -1,5 +1,27 @@
 skip_on_cran() # This test suite is long-running (on cran) and is skipped
 
+test_that("element subclasses retain legacy classes", {
+  for (parent in list(
+    element_blank,
+    element_rect,
+    element_line,
+    element_text
+  )) {
+    ElementChild <- S7::new_class(
+      name = "ElementChild",
+      parent = parent,
+      package = NULL
+    )
+    object <- parent()
+    child <- ElementChild()
+
+    expect_s7_class(child, ElementChild)
+    expect_s7_class(child, element)
+    expect_s3_class(child, parent@name)
+    expect_identical(S7::props(child), S7::props(object))
+  }
+})
+
 test_that("elements can be merged", {
   text_base <- element_text(colour = "red", size = 10)
   expect_equal(