diff --git a/R/geom-.R b/R/geom-.R index 50bdeb66a6..74efe6cec6 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -133,7 +133,7 @@ Geom <- ggproto("Geom", # Fill in missing aesthetics with their defaults missing_aes <- setdiff(names(default_aes), names(data)) default_aes <- default_aes[missing_aes] - themed_defaults <- eval_from_theme(default_aes, theme) + themed_defaults <- eval_from_theme(default_aes, theme, class(self)) default_aes[names(themed_defaults)] <- themed_defaults # Mark staged/scaled defaults as modifier (#6135) @@ -243,13 +243,33 @@ Geom <- ggproto("Geom", #' @rdname is_tests is.geom <- function(x) inherits(x, "Geom") -eval_from_theme <- function(aesthetics, theme) { +eval_from_theme <- function(aesthetics, theme, class = NULL) { themed <- is_themed_aes(aesthetics) if (!any(themed)) { return(aesthetics) } - settings <- calc_element("geom", theme) %||% .default_geom_element - lapply(aesthetics[themed], eval_tidy, data = settings) + + element <- calc_element("geom", theme) %||% .default_geom_element + class <- setdiff(class, c("Geom", "ggproto", "gg")) + + if (length(class) > 0) { + + # CamelCase to dot.case + class <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1.\\2\\3", class) + class <- gsub("([a-z])([A-Z])", "\\1.\\2", class) + class <- to_lower_ascii(class) + + class <- class[class %in% names(theme)] + + # Inherit up to parent geom class + if (length(class) > 0) { + for (cls in rev(class)) { + element <- combine_elements(theme[[cls]], element) + } + } + } + + lapply(aesthetics[themed], eval_tidy, data = element) } #' Graphical units diff --git a/R/theme.R b/R/theme.R index 2ebd892f62..9e5eb278d0 100644 --- a/R/theme.R +++ b/R/theme.R @@ -565,8 +565,11 @@ validate_theme <- function(theme, tree = get_element_tree(), call = caller_env() if (!is_theme_validate(theme)) { return() } + elnames <- names(theme) + elnames[startsWith(elnames, "geom.")] <- "geom" + mapply( - validate_element, theme, names(theme), + validate_element, theme, elnames, MoreArgs = list(element_tree = tree, call = call) ) } @@ -630,7 +633,10 @@ plot_theme <- function(x, default = get_theme()) { validate_theme(theme) # Remove elements that are not registered - theme[setdiff(names(theme), names(get_element_tree()))] <- NULL + # We accept unregistered `geom.*` elements + remove <- setdiff(names(theme), names(get_element_tree())) + remove <- remove[!startsWith(remove, "geom.")] + theme[remove] <- NULL theme } diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index ef358b10b6..f4804d727e 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -673,6 +673,26 @@ test_that("margin_part() mechanics work as expected", { expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) }) +test_that("geom elements are inherited correctly", { + + GeomFoo <- ggproto("GeomFoo", GeomPoint) + GeomBar <- ggproto("GeomBar", GeomFoo) + + p <- ggplot(data.frame(x = 1), aes(x, x)) + + stat_identity(geom = GeomBar) + + theme( + geom = element_geom(pointshape = 15), + geom.point = element_geom(borderwidth = 2, ink = "blue"), + geom.foo = element_geom(pointsize = 2), + geom.bar = element_geom(ink = "red") + ) + p <- layer_data(p) + expect_equal(p$shape, 15) + expect_equal(p$stroke, 2) + expect_equal(p$size, 2) + expect_equal(p$colour, "red") +}) + # Visual tests ------------------------------------------------------------ test_that("aspect ratio is honored", {