User-defined theme elements

DESCRIPTION

@@ -61,6 +61,7 @@ BugReports: https://github.com/tidyverse/ggplot2/issues
 LazyData: true
 Collate: 
     'ggproto.r'
+    'ggplot-global.R'
     'aaa-.r'
     'aes-calculated.r'
     'aes-colour-fill-alpha.r'

R/aaa-.r

@@ -1,3 +1,4 @@
+#' @include ggplot-global.R
 #' @include ggproto.r
 NULL
 

R/aes.r

@@ -1,27 +1,6 @@
 #' @include utilities.r
 NULL
 
-.all_aesthetics <- c("adj", "alpha", "angle", "bg", "cex", "col", "color",
-  "colour", "fg", "fill", "group", "hjust", "label", "linetype", "lower",
-  "lty", "lwd", "max", "middle", "min", "pch", "radius", "sample", "shape",
-  "size", "srt", "upper", "vjust", "weight", "width", "x", "xend", "xmax",
-  "xmin", "xintercept", "y", "yend", "ymax", "ymin", "yintercept", "z")
-
-.base_to_ggplot <- c(
-  "col"   = "colour",
-  "color" = "colour",
-  "pch"   = "shape",
-  "cex"   = "size",
-  "lty"   = "linetype",
-  "lwd"   = "size",
-  "srt"   = "angle",
-  "adj"   = "hjust",
-  "bg"    = "fill",
-  "fg"    = "colour",
-  "min"   = "ymin",
-  "max"   = "ymax"
-)
-
 #' Construct aesthetic mappings
 #'
 #' Aesthetic mappings describe how variables in the data are mapped to visual
@@ -167,10 +146,10 @@ print.uneval <- function(x, ...) {
 # Rename American or old-style aesthetics name
 rename_aes <- function(x) {
   # Convert prefixes to full names
-  full <- match(names(x), .all_aesthetics)
-  names(x)[!is.na(full)] <- .all_aesthetics[full[!is.na(full)]]
+  full <- match(names(x), ggplot_global$all_aesthetics)
+  names(x)[!is.na(full)] <- ggplot_global$all_aesthetics[full[!is.na(full)]]
 
-  plyr::rename(x, .base_to_ggplot, warn_missing = FALSE)
+  plyr::rename(x, ggplot_global$base_to_ggplot, warn_missing = FALSE)
 }
 
 # Look up the scale that should be used for a given aesthetic
@@ -315,7 +294,7 @@ aes_auto <- function(data = NULL, ...) {
   }
 
   # automatically detected aes
-  vars <- intersect(.all_aesthetics, vars)
+  vars <- intersect(ggplot_global$all_aesthetics, vars)
   names(vars) <- vars
   aes <- lapply(vars, function(x) parse(text = x)[[1]])
 

R/ggplot-global.R

@@ -0,0 +1,38 @@
+# Environment that holds various global variables and settings for ggplot,
+# such as the current theme. It is not exported and should not be directly
+# manipulated by other packages.
+ggplot_global <- new.env(parent = emptyenv())
+
+# The current theme. Defined here only as placeholder, and defined properly
+# in file "theme-current.R". This setup avoids circular dependencies among
+# the various source files.
+ggplot_global$theme_current <- list()
+
+# Element tree for the theme elements. Defined here only as placeholder, and
+# defined properly in file "theme-elements.r".
+ggplot_global$element_tree <- list()
+
+# List of all aesthetics known to ggplot
+ggplot_global$all_aesthetics <- c(
+  "adj", "alpha", "angle", "bg", "cex", "col", "color",
+  "colour", "fg", "fill", "group", "hjust", "label", "linetype", "lower",
+  "lty", "lwd", "max", "middle", "min", "pch", "radius", "sample", "shape",
+  "size", "srt", "upper", "vjust", "weight", "width", "x", "xend", "xmax",
+  "xmin", "xintercept", "y", "yend", "ymax", "ymin", "yintercept", "z"
+)
+
+# Aesthetic aliases
+ggplot_global$base_to_ggplot <- c(
+  "col"   = "colour",
+  "color" = "colour",
+  "pch"   = "shape",
+  "cex"   = "size",
+  "lty"   = "linetype",
+  "lwd"   = "size",
+  "srt"   = "angle",
+  "adj"   = "hjust",
+  "bg"    = "fill",
+  "fg"    = "colour",
+  "min"   = "ymin",
+  "max"   = "ymax"
+)

R/quick-plot.r

@@ -75,7 +75,7 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE,
   is_missing <- vapply(exprs, rlang::quo_is_missing, logical(1))
   # treat arguments as regular parameters if they are wrapped into I() or
   # if they don't have a name that is in the list of all aesthetics
-  is_constant <- (!names(exprs) %in% .all_aesthetics) |
+  is_constant <- (!names(exprs) %in% ggplot_global$all_aesthetics) |
     vapply(exprs, rlang::quo_is_call, logical(1), name = "I")
 
   mapping <- new_aes(exprs[!is_missing & !is_constant], env = parent.frame())

R/stat-sum.r

@@ -40,7 +40,7 @@ StatSum <- ggproto("StatSum", Stat,
   compute_panel = function(data, scales) {
     if (is.null(data$weight)) data$weight <- 1
 
-    group_by <- setdiff(intersect(names(data), .all_aesthetics), "weight")
+    group_by <- setdiff(intersect(names(data), ggplot_global$all_aesthetics), "weight")
 
     counts <- plyr::count(data, group_by, wt_var = "weight")
     counts <- plyr::rename(counts, c(freq = "n"), warn_missing = FALSE)

R/theme-current.R

@@ -1,7 +1,6 @@
 #' @include theme-defaults.r
 #' @include theme-elements.r
-theme_env <- new.env(parent = emptyenv())
-theme_env$current <- theme_gray()
+ggplot_global$theme_current <- theme_gray()
 
 #' Get, set, and modify the active theme
 #'
@@ -66,7 +65,7 @@ theme_env$current <- theme_gray()
 #' # theme_update() and theme_replace() are similar except they
 #' # apply directly to the current/active theme.
 theme_get <- function() {
-  theme_env$current
+  ggplot_global$theme_current
 }
 
 #' @rdname theme_get
@@ -79,8 +78,8 @@ theme_set <- function(new) {
       paste(missing, collapse = ", "), call. = FALSE)
   }
 
-  old <- theme_env$current
-  theme_env$current <- new
+  old <- ggplot_global$theme_current
+  ggplot_global$theme_current <- new
   invisible(old)
 }
 

R/theme-elements.r

@@ -257,7 +257,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) {
 
 # This data structure represents the theme elements and the inheritance
 # among them.
-.element_tree <- list(
+ggplot_global$element_tree <- list(
   line                = el_def("element_line"),
   rect                = el_def("element_rect"),
   text                = el_def("element_text"),
@@ -364,7 +364,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) {
 # @param el an element
 # @param elname the name of the element
 validate_element <- function(el, elname) {
-  eldef <- .element_tree[[elname]]
+  eldef <- ggplot_global$element_tree[[elname]]
 
   if (is.null(eldef)) {
     stop('"', elname, '" is not a valid theme element name.')

R/theme.r

@@ -561,12 +561,12 @@ calc_element <- function(element, theme, verbose = FALSE) {
   # 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]], .element_tree[[element]]$class)) {
-    stop(element, " should have class ", .element_tree[[element]]$class)
+      !inherits(theme[[element]], ggplot_global$element_tree[[element]]$class)) {
+    stop(element, " should have class ", ggplot_global$element_tree[[element]]$class)
   }
 
   # Get the names of parents from the inheritance tree
-  pnames <- .element_tree[[element]]$inherit
+  pnames <- ggplot_global$element_tree[[element]]$inherit
 
   # If no parents, this is a "root" node. Just return this element.
   if (is.null(pnames)) {

tests/testthat/test-guides.R

@@ -191,7 +191,8 @@ test_that("guides title and text are positioned correctly", {
       name = "value",
       guide = guide_colorbar(
         title.theme = element_text(size = 11, angle = 0, hjust = 0.5, vjust = 1),
-        label.theme = element_text(size = 0.8*11, angle = 270, hjust = 0.5, vjust = 1)
+        label.theme = element_text(size = 0.8*11, angle = 270, hjust = 0.5, vjust = 1),
+        order = 2 # set guide order to keep visual test stable
       )
     ) +
     scale_fill_continuous(
@@ -204,7 +205,8 @@ test_that("guides title and text are positioned correctly", {
         title.position = "top",
         label.position = "bottom",
         title.theme = element_text(size = 11, angle = 180, hjust = 0, vjust = 1),
-        label.theme = element_text(size = 0.8*11, angle = 90, hjust = 1, vjust = 0.5)
+        label.theme = element_text(size = 0.8*11, angle = 90, hjust = 1, vjust = 0.5),
+        order = 1
       )
     )