diff --git a/NEWS.md b/NEWS.md index 17460ec814..0e7da857a4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,6 @@ # ggplot2 (development version) + +* Updates for compatibility with S7 > 0.2.2. * Faceting by a named vector no longer partially matches the `names` attribute in place of the `n` attribute (@taekop, #6891). diff --git a/R/all-classes.R b/R/all-classes.R index 65fc0b0704..d64e1fcc7b 100644 --- a/R/all-classes.R +++ b/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, diff --git a/R/plot-build.R b/R/plot-build.R index e0b4aad558..54731c543e 100644 --- a/R/plot-build.R +++ b/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 diff --git a/R/plot.R b/R/plot.R index 80bd6bb980..455b3185a4 100644 --- a/R/plot.R +++ b/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 diff --git a/R/theme-elements.R b/R/theme-elements.R index 917cd7402a..0fa5236475 100644 --- a/R/theme-elements.R +++ b/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 } ) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index f004ed9758..1461b03d68 100644 --- a/tests/testthat/test-aes.R +++ b/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)) +}) diff --git a/tests/testthat/test-plot-build.R b/tests/testthat/test-plot-build.R index 3e232d798c..88b3c8c4c2 100644 --- a/tests/testthat/test-plot-build.R +++ b/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]) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 0435510c04..192c153464 100644 --- a/tests/testthat/test-plot.R +++ b/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)) diff --git a/tests/testthat/test-theme-elements.R b/tests/testthat/test-theme-elements.R index 578a41b881..576f92c58a 100644 --- a/tests/testthat/test-theme-elements.R +++ b/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(