diff --git a/NEWS.md b/NEWS.md index 3d9a9f7f99..2e2d58185b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -261,6 +261,7 @@ * Added `panel.widths` and `panel.heights` to `theme()` (#5338, @teunbrand). * Standardised the calculation of `width`, which are now implemented as aesthetics (@teunbrand, #2800). +* Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) # ggplot2 3.5.1 diff --git a/R/theme-elements.R b/R/theme-elements.R index 5a6b1a43cf..b83822ed3a 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -415,6 +415,8 @@ register_theme_elements <- function(..., element_tree = NULL, complete = TRUE) { t <- theme(..., complete = complete) ggplot_global$theme_default <- ggplot_global$theme_default %+replace% t + check_element_tree(element_tree) + # Merge element trees ggplot_global$element_tree <- defaults(element_tree, ggplot_global$element_tree) @@ -460,6 +462,43 @@ get_element_tree <- function() { ggplot_global$element_tree } +check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { + check_object(x, is_bare_list, "a bare {.cls list}", arg = arg, call = call) + if (length(x) < 1) { + return(invisible(NULL)) + } + + if (!is_named(x)) { + cli::cli_abort("{.arg {arg}} must have names.", call = call) + } + + # All elements should be constructed with `el_def()` + fields <- names(el_def()) + bad_fields <- !vapply(x, function(el) all(fields %in% names(el)), logical(1)) + if (any(bad_fields)) { + bad_fields <- names(x)[bad_fields] + cli::cli_abort( + c("{.arg {arg}} must have elements constructed with {.fn el_def}.", + i = "Invalid structure: {.and {.val {bad_fields}}}"), + call = call + ) + } + + # Check element tree, prevent elements from being their own parent (#6162) + bad_parent <- unlist(Map( + function(name, el) any(name %in% el$inherit), + name = names(x), el = x + )) + if (any(bad_parent)) { + bad_parent <- names(x)[bad_parent] + cli::cli_abort( + "Invalid parent in {.arg {arg}}: {.and {.val {bad_parent}}}.", + call = call + ) + } + invisible(NULL) +} + #' @rdname register_theme_elements #' @details #' The function `el_def()` is used to define new or modified element types and diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 322cce92b7..005e1b2abd 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -56,6 +56,19 @@ The `blablabla` theme element must be a object. +--- + + `element_tree` must have names. + +--- + + `element_tree` must have elements constructed with `el_def()`. + i Invalid structure: "foo" + +--- + + Invalid parent in `element_tree`: "foo". + # elements can be merged Code diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 7477e41317..eba47a0c75 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -312,6 +312,17 @@ test_that("element tree can be modified", { p1 <- ggplot() + theme(blablabla = element_line()) expect_snapshot_error(ggplotGrob(p1)) + # Expect errors for invalid element trees + expect_snapshot_error( + register_theme_elements(element_tree = list(el_def("rect"), el_def("line"))) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = "bar")) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = el_def(inherit = "foo"))) + ) + # inheritance and final calculation of novel element works final_theme <- ggplot2:::plot_theme(p, theme_gray()) e1 <- calc_element("blablabla", final_theme)