Enable user-defined theme elements by making element tree part of the theme.

NAMESPACE

@@ -299,10 +299,12 @@ export(draw_key_timeseries)
 export(draw_key_vline)
 export(draw_key_vpath)
 export(dup_axis)
+export(el_def)
 export(element_blank)
 export(element_grob)
 export(element_line)
 export(element_rect)
+export(element_render)
 export(element_text)
 export(enexpr)
 export(enexprs)

NEWS.md

@@ -20,6 +20,10 @@
 * `Geom` now gains a `setup_params()` method in line with the other ggproto
   classes (@thomasp85, #3509)
 
+* Themes can now modify the theme element tree, via the
+  `element_tree` argument. This allows extension packages to add functionality that
+  alters the element tree (@clauswilke, #2540).
+
 * `element_text()` now issues a warning when vectorized arguments are provided, as in
   `colour = c("red", "green", "blue")`. Such use is discouraged and not officially supported
    (@clauswilke, #3492).

R/theme-current.R

@@ -104,5 +104,17 @@ theme_replace <- function(...) {
 
   # Can't use modifyList here since it works recursively and drops NULLs
   e1[names(e2)] <- e2
+
+  # Merge element trees if provided
+  attr(e1, "element_tree") <- defaults(
+    attr(e2, "element_tree", exact = TRUE),
+    attr(e1, "element_tree", exact = TRUE)
+  )
+
+  # comment by @clauswilke:
+  # `complete` and `validate` are currently ignored,
+  # which means they are taken from e1. Is this correct?
+  # I'm not sure how `%+replace%` should handle them.
+
   e1
 }

R/theme-elements.r

@@ -10,7 +10,7 @@
 #'   - `element_text`: text.
 #'
 #' `rel()` is used to specify sizes relative to the parent,
-#' `margins()` is used to specify the margins of elements.
+#' `margin()` is used to specify the margins of elements.
 #'
 #' @param fill Fill colour.
 #' @param colour,color Line/border colour. Color is an alias for colour.
@@ -154,13 +154,22 @@ print.rel <- function(x, ...) print(noquote(paste(x, " *", sep = "")))
 #' @keywords internal
 is.rel <- function(x) inherits(x, "rel")
 
-# Given a theme object and element name, return a grob for the element
+#' Render a specified theme element into a grob
+#'
+#' Given a theme object and element name, returns a grob for the element.
+#' Uses [`element_grob()`] to generate the grob.
+#' @param theme The theme object
+#' @param element The element name given as character vector
+#' @param ... Other arguments provided to [`element_grob()`]
+#' @param name Character vector added to the name of the grob
+#' @keywords internal
+#' @export
 element_render <- function(theme, element, ..., name = NULL) {
 
   # Get the element from the theme, calculating inheritance
   el <- calc_element(element, theme)
   if (is.null(el)) {
-    message("Theme element ", element, " missing")
+    message("Theme element `", element, "` missing")
     return(zeroGrob())
   }
 
@@ -263,13 +272,51 @@ element_grob.element_line <- function(element, x = 0:1, y = 0:1,
 
 
 
-# Define an element's class and what other elements it inherits from
-#
-# @param class The name of class (like "element_line", "element_text",
-#  or the reserved "character", which means a character vector (not
-#  "character" class)
-# @param inherit A vector of strings, naming the elements that this
-#  element inherits from.
+#' Define new elements for a theme's element tree
+#'
+#' Each theme has an element tree that defines which theme elements inherit
+#' theme parameters from which other elements. The function `el_def()` can be used
+#' to define new or modified elements for this tree.
+#'
+#' @param class The name of the element class. Examples are "element_line" or
+#'  "element_text" or "unit", or one of the two reserved keywords "character" or
+#'  "margin". The reserved keyword "character" implies a character
+#'  or numeric vector, not a class called "character". The keyword
+#'  "margin" implies a unit vector of length 4, as created by [margin()].
+#' @param inherit A vector of strings, naming the elements that this
+#'  element inherits from.
+#' @param description An optional character vector providing a description
+#'  for the element.
+#' @examples
+#' # define a new coord that includes a panel annotation
+#' coord_annotate <- function(label = "panel annotation") {
+#'   ggproto(NULL, CoordCartesian,
+#'     limits = list(x = NULL, y = NULL),
+#'     expand = TRUE,
+#'     default = FALSE,
+#'     clip = "on",
+#'     render_fg = function(panel_params, theme) {
+#'       element_render(theme, "panel.annotation", label = label)
+#'     }
+#'   )
+#' }
+#'
+#' # update the default theme by adding a new `panel.annotation`
+#' # theme element
+#' old <- theme_update(
+#'   panel.annotation = element_text(color = "blue", hjust = 0.95, vjust = 0.05),
+#'   element_tree = list(panel.annotation = el_def("element_text", "text"))
+#' )
+#'
+#' df <- data.frame(x = 1:3, y = 1:3)
+#' ggplot(df, aes(x, y)) +
+#'   geom_point() +
+#'   coord_annotate("annotation in blue")
+#'
+#' # revert to original default theme
+#' theme_set(old)
+#' @keywords internal
+#' @export
 el_def <- function(class = NULL, inherit = NULL, description = NULL) {
   list(class = class, inherit = inherit, description = description)
 }
@@ -393,11 +440,12 @@ ggplot_global$element_tree <- .element_tree
 #
 # @param el an element
 # @param elname the name of the element
-validate_element <- function(el, elname) {
-  eldef <- ggplot_global$element_tree[[elname]]
+# @param element_tree the element tree to validate against
+validate_element <- function(el, elname, element_tree) {
+  eldef <- element_tree[[elname]]
 
   if (is.null(eldef)) {
-    stop('"', elname, '" is not a valid theme element name.')
+    stop("Theme element `", elname, "` is not defined in the element hierarchy.", call. = FALSE)
   }
 
   # NULL values for elements are OK
@@ -407,12 +455,12 @@ validate_element <- function(el, elname) {
     # Need to be a bit looser here since sometimes it's a string like "top"
     # but sometimes its a vector like c(0,0)
     if (!is.character(el) && !is.numeric(el))
-      stop("Element ", elname, " must be a string or numeric vector.")
+      stop("Theme element `", elname, "` must be a string or numeric vector.", call. = FALSE)
   } else if (eldef$class == "margin") {
     if (!is.unit(el) && length(el) == 4)
-      stop("Element ", elname, " must be a unit vector of length 4.")
+      stop("Theme element `", elname, "` must be a unit vector of length 4.", call. = FALSE)
   } else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) {
-      stop("Element ", elname, " must be a ", eldef$class, " object.")
+      stop("Theme element `", elname, "` must be an `", eldef$class, "` object.", call. = FALSE)
   }
   invisible()
 }

R/theme.r

@@ -9,7 +9,7 @@
 #' about theme inheritance below.
 #'
 #' @section Theme inheritance:
-#' Theme elements inherit properties from other theme elements heirarchically.
+#' Theme elements inherit properties from other theme elements hierarchically.
 #' For example, `axis.title.x.bottom` inherits from `axis.title.x` which inherits
 #' from `axis.title`, which in turn inherits from `text`. All text elements inherit
 #' directly or indirectly from `text`; all lines inherit from
@@ -164,6 +164,10 @@
 #'   `complete = TRUE` all elements will be set to inherit from blank
 #'   elements.
 #' @param validate `TRUE` to run `validate_element()`, `FALSE` to bypass checks.
+#' @param element_tree optional addition or modification to the element tree,
+#'   which specifies the inheritance relationship of the theme elements. The element
+#'   tree should be provided as a list of named element definitions created with
+#'   [`el_def()`]. See [`el_def()`] for more details.
 #'
 #' @seealso
 #'   [+.gg()] and \code{\link{\%+replace\%}},
@@ -358,9 +362,10 @@ theme <- function(line,
                   strip.switch.pad.wrap,
                   ...,
                   complete = FALSE,
-                  validate = TRUE
+                  validate = TRUE,
+                  element_tree = NULL
                   ) {
-  elements <- find_args(..., complete = NULL, validate = NULL)
+  elements <- find_args(..., complete = NULL, validate = NULL, element_tree = NULL)
 
   if (!is.null(elements$axis.ticks.margin)) {
     warning("`axis.ticks.margin` is deprecated. Please set `margin` property ",
@@ -392,11 +397,6 @@ theme <- function(line,
     elements$legend.margin <- margin()
   }
 
-  # Check that all elements have the correct class (element_text, unit, etc)
-  if (validate) {
-    mapply(validate_element, elements, names(elements))
-  }
-
   # If complete theme set all non-blank elements to inherit from blanks
   if (complete) {
     elements <- lapply(elements, function(el) {
@@ -410,21 +410,69 @@ theme <- function(line,
     elements,
     class = c("theme", "gg"),
     complete = complete,
-    validate = validate
+    validate = validate,
+    element_tree = element_tree
   )
 }
 
-is_theme_complete <- function(x) isTRUE(attr(x, "complete"))
+# check whether theme is complete
+is_theme_complete <- function(x) isTRUE(attr(x, "complete", exact = TRUE))
 
+# check whether theme should be validated
+is_theme_validate <- function(x) {
+  validate <- attr(x, "validate", exact = TRUE)
+  if (is.null(validate))
+    TRUE # we validate by default
+  else
+    isTRUE(validate)
+}
+
+# obtain the full element tree from a theme,
+# substituting the defaults if needed
+complete_element_tree <- function(theme) {
+  element_tree <- attr(theme, "element_tree", exact = TRUE)
+
+  # we fill in the element tree first from the current default theme,
+  # and then from the internal element tree if necessary
+  # this makes it easy for extension packages to provide modified
+  # default element trees
+  defaults(
+    defaults(
+      element_tree,
+      attr(theme_get(), "element_tree", exact = TRUE)
+    ),
+    ggplot_global$element_tree
+  )
+}
 
 # Combine plot defaults with current theme to get complete theme for a plot
 plot_theme <- function(x, default = theme_get()) {
   theme <- x$theme
+
+  # apply theme defaults appropriately if needed
   if (is_theme_complete(theme)) {
-    theme
+    # for complete themes, we fill in missing elements but don't do any element merging
+    # can't use `defaults()` because it strips attributes
+    missing <- setdiff(names(default), names(theme))
+    theme[missing] <- default[missing]
   } else {
-    defaults(theme, default)
+    # otherwise, we can just add the theme to the default theme
+    theme <- default + theme
   }
+
+  # complete the element tree and save back to the theme
+  element_tree <- complete_element_tree(theme)
+  attr(theme, "element_tree") <- element_tree
+
+  # Check that all elements have the correct class (element_text, unit, etc)
+  if (is_theme_validate(theme)) {
+    mapply(
+      validate_element, theme, names(theme),
+      MoreArgs = list(element_tree = element_tree)
+    )
+  }
+
+  theme
 }
 
 #' Modify properties of an element in a theme object
@@ -435,7 +483,7 @@ plot_theme <- function(x, default = theme_get()) {
 #'   informative error messages.
 #' @keywords internal
 add_theme <- function(t1, t2, t2name) {
-  if (!is.theme(t2)) {
+  if (!is.list(t2)) { # in various places in the code base, simple lists are used as themes
     stop("Can't add `", t2name, "` to a theme object.",
       call. = FALSE)
   }
@@ -457,6 +505,17 @@ add_theme <- function(t1, t2, t2name) {
   # make sure the "complete" attribute is set; this can be missing
   # when t1 is an empty list
   attr(t1, "complete") <- is_theme_complete(t1)
+
+  # Only validate if both themes should be validated
+  attr(t1, "validate") <-
+    is_theme_validate(t1) && is_theme_validate(t2)
+
+  # Merge element trees if provided
+  attr(t1, "element_tree") <- defaults(
+    attr(t2, "element_tree", exact = TRUE),
+    attr(t1, "element_tree", exact = TRUE)
+  )
+
   t1
 }
 
@@ -484,30 +543,31 @@ add_theme <- function(t1, t2, t2name) {
 calc_element <- function(element, theme, verbose = FALSE) {
   if (verbose) message(element, " --> ", appendLF = FALSE)
 
-  # if theme is not complete, merge element with theme defaults,
-  # otherwise take it as is. This fills in theme defaults if no
-  # explicit theme is set for the plot.
-  if (!is_theme_complete(theme)) {
-    el_out <- merge_element(theme[[element]], theme_get()[[element]])
-  } else {
-    el_out <- theme[[element]]
-  }
+  el_out <- theme[[element]]
 
   # If result is element_blank, don't inherit anything from parents
   if (inherits(el_out, "element_blank")) {
     if (verbose) message("element_blank (no inheritance)")
     return(el_out)
   }
 
+  # Obtain the element tree and check that the element is in it
+  # If not, try to retrieve the complete element tree. This is
+  # needed for backwards compatibility and certain unit tests.
+  element_tree <- attr(theme, "element_tree", exact = TRUE)
+  if (!element %in% names(element_tree)) {
+    element_tree <- complete_element_tree(theme)
+  }
+
   # If the element is defined (and not just inherited), check that
-  # it is of the class specified in .element_tree
+  # it is of the class specified in element_tree
   if (!is.null(el_out) &&
-      !inherits(el_out, ggplot_global$element_tree[[element]]$class)) {
-    stop(element, " should have class ", ggplot_global$element_tree[[element]]$class)
+      !inherits(el_out, element_tree[[element]]$class)) {
+    stop(element, " should have class ", element_tree[[element]]$class)
   }
 
   # Get the names of parents from the inheritance tree
-  pnames <- ggplot_global$element_tree[[element]]$inherit
+  pnames <- element_tree[[element]]$inherit
 
   # If no parents, this is a "root" node. Just return this element.
   if (is.null(pnames)) {