diff --git a/NEWS.md b/NEWS.md index 6bf14d4615..a15a099b5c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 (development version) +* In the theme element hierarchy, parent elements that are a strict subclass + of child elements now confer their subclass upon the children (#5457). + * `ggsave()` no longer sometimes creates new directories, which is now controlled by the new `create.dir` argument (#5489). diff --git a/R/theme.R b/R/theme.R index fd4a445e32..e07fd29214 100644 --- a/R/theme.R +++ b/R/theme.R @@ -783,9 +783,21 @@ combine_elements <- function(e1, e2) { e1$linewidth <- e2$linewidth * unclass(e1$linewidth) } + # If e2 is 'richer' than e1, fill e2 with e1 parameters + if (is.subclass(e2, e1)) { + new <- defaults(e1, e2) + e2[names(new)] <- new + return(e2) + } + e1 } +is.subclass <- function(x, y) { + inheritance <- inherits(x, class(y), which = TRUE) + !any(inheritance == 0) && length(setdiff(class(x), class(y))) > 0 +} + #' Reports whether x is a theme object #' @param x An object to test #' @export diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index e6e6cfdb55..10773ab176 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -509,6 +509,50 @@ test_that("Theme validation behaves as expected", { expect_snapshot_error(validate_element("A", "aspect.ratio", tree)) }) +test_that("Element subclasses are inherited", { + + # `rich` is subclass of `poor` + poor <- element_line(colour = "red", linetype = 3) + rich <- element_line(linetype = 2, linewidth = 2) + class(rich) <- c("element_rich", class(rich)) + + # `poor` should acquire `rich` + test <- combine_elements(poor, rich) + expect_s3_class(test, "element_rich") + expect_equal( + test[c("colour", "linetype", "linewidth")], + list(colour = "red", linetype = 3, linewidth = 2) + ) + + # `rich` should stay `rich` + test <- combine_elements(rich, poor) + expect_s3_class(test, "element_rich") + expect_equal( + test[c("colour", "linetype", "linewidth")], + list(colour = "red", linetype = 2, linewidth = 2) + ) + + # `sibling` is not strict subclass of `rich` + sibling <- poor + class(sibling) <- c("element_sibling", class(sibling)) + + # `sibling` should stay `sibling` + test <- combine_elements(sibling, rich) + expect_s3_class(test, "element_sibling") + expect_equal( + test[c("colour", "linetype", "linewidth")], + list(colour = "red", linetype = 3, linewidth = 2) + ) + + # `rich` should stay `rich` + test <- combine_elements(rich, sibling) + expect_s3_class(test, "element_rich") + expect_equal( + test[c("colour", "linetype", "linewidth")], + list(colour = "red", linetype = 2, linewidth = 2) + ) +}) + test_that("Minor tick length supports biparental inheritance", { my_theme <- theme_gray() + theme( axis.ticks.length = unit(1, "cm"),