diff --git a/NEWS.md b/NEWS.md index dd574ac1aa..c288e7c6cc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ggplot2 (development version) +* Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) * `guide_*()` can now accept two inside legend theme elements: `legend.position.inside` and `legend.justification.inside`, allowing inside legends to be placed at different positions. Only inside legends with the same diff --git a/R/theme-elements.R b/R/theme-elements.R index 947e4e0af3..f7a82b1930 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 fa7237d37d..d104aa0ca8 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 ef358b10b6..9a80cd72ce 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)