Keep element subclasses when adding (#2063)

* Use child element as base when merging theme elements

* Add the correct element

* Add merge_element generic and methods for all base classes

* Check for direct inheritance

* Add unit tests

* Update news

* Update roxygen

* Only display most specific class in error message

* dispatch on element class

* Reformat line

* More code formatting

Author: thomasp85

NAMESPACE

@@ -65,6 +65,8 @@ S3method(limits,factor)
 S3method(limits,numeric)
 S3method(makeContent,labelgrob)
 S3method(makeContext,dotstackGrob)
+S3method(merge_element,default)
+S3method(merge_element,element)
 S3method(plot,ggplot)
 S3method(predictdf,default)
 S3method(predictdf,glm)
@@ -347,6 +349,7 @@ export(mean_cl_normal)
 export(mean_sdl)
 export(mean_se)
 export(median_hilow)
+export(merge_element)
 export(panel_cols)
 export(panel_rows)
 export(position_dodge)

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 2.2.1.9000
 
+* Theme elements can now be subclassed. Add a `merge_element` method to control
+  how properties are inherited from parent element. Add `element_grob` method
+  to define how elements are rendered into grobs (@thomasp85, #1981).
+
 * Theme functions now have the optional parameters `base_line_size` and
   `base_rect_size` to control the default sizes of line and rectangle elements
   (@karawoo, #2176).

R/theme.r

@@ -409,14 +409,8 @@ add_theme <- function(t1, t2, t2name) {
       # If y is NULL, or a string or numeric vector, or is element_blank, just replace x
       x <- y
     } else {
-      # If x is not NULL, then copy over the non-NULL properties from y
-      # Get logical vector of non-NULL properties in y
-      idx <- !vapply(y, is.null, logical(1))
-      # Get the names of TRUE items
-      idx <- names(idx[idx])
-
-      # Update non-NULL items
-      x[idx] <- y[idx]
+      # If x is not NULL, then merge into y
+      x <- merge_element(y, x)
     }
 
     # Assign it back to t1
@@ -538,6 +532,49 @@ calc_element <- function(element, theme, verbose = FALSE) {
   Reduce(combine_elements, parents, theme[[element]])
 }
 
+#' Merge a parent element into a child element
+#'
+#' This is a generic and element classes must provide an implementation of this
+#' method
+#'
+#' @param new The child element in the theme hierarchy
+#' @param old The parent element in the theme hierarchy
+#' @return A modified version of \code{new} updated with the properties of
+#' \code{old}
+#' @keywords internal
+#' @export
+#' @examples
+#' new <- element_text(colour = "red")
+#' old <- element_text(colour = "blue", size = 10)
+#'
+#' # Adopt size but ignore colour
+#' merge_element(new, old)
+#'
+merge_element <- function(new, old) {
+  UseMethod("merge_element")
+}
+#' @rdname merge_element
+#' @export
+merge_element.default <- function(new, old) {
+  stop("No method for merging ", class(new)[1], " into ", class(old)[1], call. = FALSE)
+}
+#' @rdname merge_element
+#' @export
+merge_element.element <- function(new, old) {
+  if (!inherits(new, class(old)[1])) {
+    stop("Only elements of the same class can be merged", call. = FALSE)
+  }
+  # Override NULL properties of new with the values in old
+  # Get logical vector of NULL properties in new
+  idx <- vapply(new, is.null, logical(1))
+  # Get the names of TRUE items
+  idx <- names(idx[idx])
+
+  # Update non-NULL items
+  new[idx] <- old[idx]
+
+  new
+}
 
 # Combine the properties of two elements
 #

man/merge_element.Rd

@@ -202,6 +202,28 @@ test_that("All elements in complete themes have inherit.blank=TRUE", {
   expect_true(inherit_blanks(theme_void()))
 })
 
+test_that("Elements can be merged", {
+  text_base <- element_text(colour = "red", size = 10)
+  expect_equal(
+    merge_element(element_text(colour = "blue"), text_base),
+    element_text(colour = "blue", size = 10)
+  )
+  rect_base <- element_rect(colour = "red", size = 10)
+  expect_equal(
+    merge_element(element_rect(colour = "blue"), rect_base),
+    element_rect(colour = "blue", size = 10)
+  )
+  line_base <- element_line(colour = "red", size = 10)
+  expect_equal(
+    merge_element(element_line(colour = "blue"), line_base),
+    element_line(colour = "blue", size = 10)
+  )
+  expect_error(
+    merge_element(text_base, rect_base),
+    "Only elements of the same class can be merged"
+  )
+})
+
 
 # Visual tests ------------------------------------------------------------