diff --git a/R/all-classes.R b/R/all-classes.R index 9f0f0ad44c..e6c95fa77b 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -408,3 +408,34 @@ class_ggplot_built <- S7::new_class( ) } ) + +# Methods ----------------------------------------------------------------- + +#' @importFrom S7 convert +# S7 currently attaches the S3 method to the calling environment which gives `ggplot2:::as.list` +# Wrap in `local()` to provide a temp environment which throws away the attachment +local({ + list_classes <- class_mapping | class_theme | class_labels + prop_classes <- class_ggplot | class_ggplot_built + + S7::method(convert, list(from = prop_classes, to = S7::class_list)) <- + function(from, to, ...) S7::props(from) + + S7::method(convert, list(from = list_classes, to = S7::class_list)) <- + function(from, to, ...) S7::S7_data(from) + + # We're not using union classes here because of S7#510 + S7::method(as.list, class_gg) <- + S7::method(as.list, class_mapping) <- + S7::method(as.list, class_theme) <- + S7::method(as.list, class_labels) <- + function(x, ...) convert(x, S7::class_list) + + S7::method(convert, list(from = S7::class_list, to = prop_classes)) <- + function(from, to, ...) inject(to(!!!from)) + + S7::method(convert, list(from = S7::class_list, to = list_classes)) <- + function(from, to, ...) to(from) +}) + + diff --git a/R/plot.R b/R/plot.R index 1b84a1e1b2..ea6966289e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -267,16 +267,3 @@ local({ #' @export `[[<-.ggplot2::gg` <- `$<-.ggplot2::gg` - -#' @importFrom S7 convert -# S7 currently attaches the S3 method to the calling environment which gives `ggplot2:::as.list` -# Wrap in `local()` to provide a temp environment which throws away the attachment -local({ - S7::method(convert, list(from = class_ggplot, to = S7::class_list)) <- - function(from, to) { - S7::props(from) - } - - S7::method(as.list, class_ggplot) <- - function(x, ...) convert(x, S7::class_list) -}) diff --git a/R/theme-elements.R b/R/theme-elements.R index 3f69eacfb3..a2e0498651 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -408,6 +408,29 @@ local({ # deprecate_soft0("4.1.0", I("`[[i]]`"), I("`S7::prop(, i)`")) `[[`(S7::props(x), i) } + S7::method(as.list, element) <- function(x, ...) { + S7::convert(x, S7::class_list) + } + S7::method(convert, list(from = element, to = S7::class_list)) <- + function(from, to, ...) S7::props(from) + S7::method( + convert, + list( + from = S7::class_list, + to = element_geom | element_line | element_point | + element_polygon | element_rect | element_text | element_blank + ) + ) <- function(from, to, ...) { + extra <- setdiff(names(from), fn_fmls_names(to)) + if (length(extra) > 0) { + cli::cli_warn( + "Unknown {cli::qty(extra)} argument{?s} to {.fn {to@name}}: \\ + {.and {.arg {extra}}}." + ) + from <- from[setdiff(names(from), extra)] + } + inject(to(!!!from)) + } }) # Element setter methods diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 180e0563a1..8026a22228 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -153,3 +153,7 @@ [23] "axis.line.r" "complete" [25] "validate" +# theme element conversion to lists works + + Unknown arguments to `element_text()`: `italic`, `fontweight`, and `fontwidth`. + diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 3f3fb9eeb9..8145e2323f 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -791,6 +791,22 @@ test_that("theme elements are covered in `theme_sub_*()` functions", { expect_snapshot(extra_elements) }) +test_that("theme element conversion to lists works", { + + x <- element_rect(colour = "red") + expect_type(x <- as.list(x), "list") + expect_s7_class(convert(x, element_rect), element_rect) + + # For now, element_text doesn't round-trip. + # Once fontwidth/fontweight/italic are implemented, it should round-trip again + x <- as.list(element_text(colour = "red")) + expect_snapshot_warning( + convert(x, element_text) + ) + x <- x[setdiff(names(x), c("fontwidth", "fontweight", "italic"))] + expect_silent(convert(x, element_text)) +}) + # Visual tests ------------------------------------------------------------ test_that("element_polygon() can render a grob", { diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 4768bbf3da..c6e24cf702 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -218,3 +218,24 @@ test_that("summary method gives a nice summary", { expect_snapshot(summary(p)) }) + +test_that("list conversion works for ggplot classes", { + # Test list-based class round-trips + x <- aes(x = 10, y = foo) + expect_type(x <- as.list(x), "list") + expect_s7_class(x <- convert(x, class_mapping), class_mapping) + + # Mapping should still be able to evaluate + expect_equal( + eval_aesthetics(x, data = data.frame(foo = "A")), + list(x = 10, y = "A") + ) + + # Test property-based class round-trips + x <- ggplot() + expect_type(x <- as.list(x), "list") + expect_s7_class(x <- convert(x, class_ggplot), class_ggplot) + + # Plot should still be buildable + expect_s3_class(ggplotGrob(x), "gtable") +})