Checks for register_theme_element(element_tree)

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

R/theme-elements.R

@@ -415,6 +415,8 @@
   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 @@
   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

tests/testthat/_snaps/theme.md

@@ -56,6 +56,19 @@
 
     The `blablabla` theme element must be a <element_text> 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

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)