From 6f5ffea70e80ce3aa076fb9da8a6b0ec7ebfbc51 Mon Sep 17 00:00:00 2001
From: Claus Wilke <wilke@austin.utexas.edu>
Date: Tue, 22 Oct 2019 22:57:14 -0500
Subject: [PATCH] Clean up theme addition (#3570)

* clean up and simplify theme addition. fixes #3039

* more theme cleanup; simplify merging; correctly pull in theme defaults

* add news item, one more unit test

* cache theme_grey() so we don't have to rebuild it every time we need to look something up
---
 NEWS.md                     |   4 ++
 R/plot-construction.r       |   2 +-
 R/theme-current.R           |   2 +-
 R/theme.r                   | 140 +++++++++++++++++-------------------
 R/zzz.r                     |   4 +-
 tests/testthat/test-theme.r |  40 +++++++++--
 6 files changed, 109 insertions(+), 83 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index a6daad8503..847f615320 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -18,6 +18,10 @@
   `colour = c("red", "green", "blue")`. Such use is discouraged and not officially supported
    (@clauswilke, #3492).
 
+* Addition of partial themes to plots has been made more predictable;
+  stepwise addition of individual partial themes is now equivalent to
+  addition of multple theme elements at once (@clauswilke, #3039).
+
 * stacking text when calculating the labels and the y axis with
   `stat_summary()` now works (@ikosmidis, #2709)
 
diff --git a/R/plot-construction.r b/R/plot-construction.r
index 4f49d9d16b..1c6b07d8ea 100644
--- a/R/plot-construction.r
+++ b/R/plot-construction.r
@@ -101,7 +101,7 @@ ggplot_add.data.frame <- function(object, plot, object_name) {
 }
 #' @export
 ggplot_add.theme <- function(object, plot, object_name) {
-  plot$theme <- update_theme(plot$theme, object)
+  plot$theme <- add_theme(plot$theme, object)
   plot
 }
 #' @export
diff --git a/R/theme-current.R b/R/theme-current.R
index ac860f9371..392633fada 100644
--- a/R/theme-current.R
+++ b/R/theme-current.R
@@ -72,7 +72,7 @@ theme_get <- function() {
 #' @param new new theme (a list of theme elements)
 #' @export
 theme_set <- function(new) {
-  missing <- setdiff(names(theme_gray()), names(new))
+  missing <- setdiff(names(ggplot_global$theme_grey), names(new))
   if (length(missing) > 0) {
     warning("New theme missing the following elements: ",
       paste(missing, collapse = ", "), call. = FALSE)
diff --git a/R/theme.r b/R/theme.r
index 4feab4116d..f9d21f9487 100644
--- a/R/theme.r
+++ b/R/theme.r
@@ -436,26 +436,17 @@ plot_theme <- function(x, default = theme_get()) {
 #' @keywords internal
 add_theme <- function(t1, t2, t2name) {
   if (!is.theme(t2)) {
-    stop("Don't know how to add RHS to a theme object",
+    stop("Don't know how to add ", t2name, " to a theme object",
       call. = FALSE)
   }
 
+  # If t2 is a complete theme or t1 is NULL, just return t2
+  if (is_theme_complete(t2) || is.null(t1))
+    return(t2)
+
   # Iterate over the elements that are to be updated
   for (item in names(t2)) {
-    x <- t1[[item]]
-    y <- t2[[item]]
-
-    if (is.null(x) || inherits(x, "element_blank")) {
-      # If x is NULL or element_blank, then just assign it y
-      x <- y
-    } else if (is.null(y) || is.character(y) || is.numeric(y) || is.unit(y) ||
-               is.logical(y) || inherits(y, "element_blank")) {
-      # 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 merge into y
-      x <- merge_element(y, x)
-    }
+    x <- merge_element(t2[[item]], t1[[item]])
 
     # Assign it back to t1
     # This is like doing t1[[item]] <- x, except that it preserves NULLs.
@@ -463,59 +454,13 @@ add_theme <- function(t1, t2, t2name) {
     t1[item] <- list(x)
   }
 
-  # If either theme is complete, then the combined theme is complete
-  attr(t1, "complete") <- is_theme_complete(t1) || is_theme_complete(t2)
+  # make sure the "complete" attribute is set; this can be missing
+  # when t1 is an empty list
+  attr(t1, "complete") <- is_theme_complete(t1)
   t1
 }
 
 
-# Update a theme from a plot object
-#
-# This is called from add_ggplot.
-#
-# If newtheme is a *complete* theme, then it is meant to replace
-# oldtheme; this function just returns newtheme.
-#
-# Otherwise, it adds elements from newtheme to oldtheme:
-# If oldtheme doesn't already contain those elements,
-# it searches the current default theme, grabs the elements with the
-# same name as those from newtheme, and puts them in oldtheme. Then
-# it adds elements from newtheme to oldtheme.
-# This makes it possible to do things like:
-#   ggplot(data.frame(x = 1:3, y = 1:3)) +
-#   geom_point() + theme(text = element_text(colour = 'red'))
-# and have 'text' keep properties from the default theme. Otherwise
-# you would have to set all the element properties, like family, size,
-# etc.
-#
-# @param oldtheme an existing theme, usually from a plot object, like
-#   plot$theme. This could be an empty list.
-# @param newtheme a new theme object to add to the existing theme
-update_theme <- function(oldtheme, newtheme) {
-  # If the newtheme is a complete one, don't bother searching
-  # the default theme -- just replace everything with newtheme
-  if (is_theme_complete(newtheme))
-    return(newtheme)
-
-  # These are elements in newtheme that aren't already set in oldtheme.
-  # They will be pulled from the default theme.
-  newitems <- !names(newtheme) %in% names(oldtheme)
-  newitem_names <- names(newtheme)[newitems]
-  oldtheme[newitem_names] <- theme_get()[newitem_names]
-
-  # Update the theme elements with the things from newtheme
-  # Turn the 'theme' list into a proper theme object first, and preserve
-  # the 'complete' attribute. It's possible that oldtheme is an empty
-  # list, and in that case, set complete to FALSE.
-  old.validate <- isTRUE(attr(oldtheme, "validate"))
-  new.validate <- isTRUE(attr(newtheme, "validate"))
-  oldtheme <- do.call(theme, c(oldtheme,
-    complete = isTRUE(attr(oldtheme, "complete")),
-    validate = old.validate & new.validate))
-
-  oldtheme + newtheme
-}
-
 #' Calculate the element properties, by inheriting properties from its parents
 #'
 #' @param element The name of the theme element to calculate
@@ -539,16 +484,25 @@ update_theme <- function(oldtheme, newtheme) {
 calc_element <- function(element, theme, verbose = FALSE) {
   if (verbose) message(element, " --> ", appendLF = FALSE)
 
-  # If this is element_blank, don't inherit anything from parents
-  if (inherits(theme[[element]], "element_blank")) {
+  # 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]]
+  }
+
+  # 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(theme[[element]])
+    return(el_out)
   }
 
   # If the element is defined (and not just inherited), check that
   # it is of the class specified in .element_tree
-  if (!is.null(theme[[element]]) &&
-      !inherits(theme[[element]], ggplot_global$element_tree[[element]]$class)) {
+  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)
   }
 
@@ -557,15 +511,23 @@ calc_element <- function(element, theme, verbose = FALSE) {
 
   # If no parents, this is a "root" node. Just return this element.
   if (is.null(pnames)) {
+    if (verbose) message("nothing (top level)")
+
     # Check that all the properties of this element are non-NULL
-    nullprops <- vapply(theme[[element]], is.null, logical(1))
-    if (any(nullprops)) {
-      stop("Theme element '", element, "' has NULL property: ",
-        paste(names(nullprops)[nullprops], collapse = ", "))
+    nullprops <- vapply(el_out, is.null, logical(1))
+    if (!any(nullprops)) {
+      return(el_out) # no null properties, return element as is
     }
 
-    if (verbose) message("nothing (top level)")
-    return(theme[[element]])
+    # if we have null properties, try to fill in from theme_grey()
+    el_out <- combine_elements(el_out, ggplot_global$theme_grey[[element]])
+    nullprops <- vapply(el_out, is.null, logical(1))
+    if (!any(nullprops)) {
+      return(el_out) # no null properties remaining, return element
+    }
+
+    stop("Theme element '", element, "' has NULL property without default: ",
+         paste(names(nullprops)[nullprops], collapse = ", "))
   }
 
   # Calculate the parent objects' inheritance
@@ -573,7 +535,7 @@ calc_element <- function(element, theme, verbose = FALSE) {
   parents <- lapply(pnames, calc_element, theme, verbose)
 
   # Combine the properties of this element with all parents
-  Reduce(combine_elements, parents, theme[[element]])
+  Reduce(combine_elements, parents, el_out)
 }
 
 #' Merge a parent element into a child element
@@ -597,17 +559,43 @@ calc_element <- function(element, theme, verbose = FALSE) {
 merge_element <- function(new, old) {
   UseMethod("merge_element")
 }
+
 #' @rdname merge_element
 #' @export
 merge_element.default <- function(new, old) {
+  if (is.null(old) || inherits(old, "element_blank")) {
+    # If old is NULL or element_blank, then just return new
+    return(new)
+  } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) ||
+             is.logical(new)) {
+    # If new is NULL, or a string, numeric vector, unit, or logical, just return it
+    return(new)
+  }
+
+  # otherwise we can't merge
   stop("No method for merging ", class(new)[1], " into ", class(old)[1], call. = FALSE)
 }
+
+#' @rdname merge_element
+#' @export
+merge_element.element_blank <- function(new, old) {
+  # If new is element_blank, just return it
+  new
+}
+
 #' @rdname merge_element
 #' @export
 merge_element.element <- function(new, old) {
+  if (is.null(old) || inherits(old, "element_blank")) {
+    # If old is NULL or element_blank, then just return new
+    return(new)
+  }
+
+  # actual merging can only happen if classes match
   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))
diff --git a/R/zzz.r b/R/zzz.r
index 698322aa6c..fb8a1a4b6b 100644
--- a/R/zzz.r
+++ b/R/zzz.r
@@ -33,7 +33,9 @@ pathGrob <- NULL
 
   .zeroGrob <<- grob(cl = "zeroGrob", name = "NULL")
 
-  ggplot_global$theme_current <- theme_gray()
+  # create default theme, store for later use, and set as current theme
+  ggplot_global$theme_grey <- theme_grey()
+  ggplot_global$theme_current <- ggplot_global$theme_grey
 
   # Used by rbind_dfs
   date <- Sys.Date()
diff --git a/tests/testthat/test-theme.r b/tests/testthat/test-theme.r
index 1e2d12fcda..7d45fab7fa 100644
--- a/tests/testthat/test-theme.r
+++ b/tests/testthat/test-theme.r
@@ -42,8 +42,8 @@ test_that("modifying theme element properties with + operator works", {
 })
 
 test_that("adding theme object to ggplot object with + operator works", {
-
-  p <- qplot(1:3, 1:3)
+  ## test with complete theme
+  p <- qplot(1:3, 1:3) + theme_grey()
   p <- p + theme(axis.title = element_text(size = 20))
   expect_true(p$theme$axis.title$size == 20)
 
@@ -55,6 +55,36 @@ test_that("adding theme object to ggplot object with + operator works", {
   expect_true(tt$inherit.blank)
   tt$inherit.blank <- FALSE
   expect_identical(p$theme$text, tt)
+
+  ## test without complete theme
+  p <- qplot(1:3, 1:3)
+  p <- p + theme(axis.title = element_text(size = 20))
+  expect_true(p$theme$axis.title$size == 20)
+
+  # Should update specified properties, but not reset other properties
+  p <- p + theme(text = element_text(colour = 'red'))
+  expect_true(p$theme$text$colour == 'red')
+  expect_null(p$theme$text$family)
+  expect_null(p$theme$text$face)
+  expect_null(p$theme$text$size)
+  expect_null(p$theme$text$hjust)
+  expect_null(p$theme$text$vjust)
+  expect_null(p$theme$text$angle)
+  expect_null(p$theme$text$lineheight)
+  expect_null(p$theme$text$margin)
+  expect_null(p$theme$text$debug)
+
+  ## stepwise addition of partial themes is identical to one-step addition
+  p <- qplot(1:3, 1:3)
+  p1 <- p + theme_light() +
+    theme(axis.line.x = element_line(color = "blue")) +
+    theme(axis.ticks.x = element_line(color = "red"))
+
+  p2 <- p + theme_light() +
+    theme(axis.line.x = element_line(color = "blue"),
+          axis.ticks.x = element_line(color = "red"))
+
+  expect_identical(p1$theme, p2$theme)
 })
 
 test_that("replacing theme elements with %+replace% operator works", {
@@ -112,14 +142,16 @@ test_that("calculating theme element inheritance works", {
     "panel.background",
     theme(
       rect = element_rect(fill = "white", colour = "black", size = 0.5, linetype = 1),
-      panel.background = element_dummyrect(dummy = 5))
+      panel.background = element_dummyrect(dummy = 5),
+      complete = TRUE # need to prevent pulling in default theme
+    )
   )
 
   expect_identical(
     e,
     structure(list(
       fill = "white", colour = "black", dummy = 5, size = 0.5, linetype = 1,
-      inherit.blank = FALSE
+      inherit.blank = TRUE # this is true because we're requesting a complete theme
     ), class = c("element_dummyrect", "element_rect", "element"))
   )
 })