Refactoring of use_defaults

DESCRIPTION

@@ -49,6 +49,7 @@ Collate:
     'aes-group-order.r'
     'aes-linetype-size-shape.r'
     'aes-position.r'
+    'utilities.r'
     'aes.r'
     'legend-draw.r'
     'geom-.r'
@@ -208,7 +209,6 @@ Collate:
     'utilities-matrix.r'
     'utilities-resolution.r'
     'utilities-table.r'
-    'utilities.r'
     'zxx.r'
     'zzz.r'
 VignetteBuilder: knitr

R/aes.r

@@ -1,3 +1,6 @@
+#' @include utilities.r
+NULL
+
 # all_aes <- function(y) c(names(y$default_aes()), y$required_aes)
 # geom_aes <- unlist(lapply(Geom$find_all(), all_aes))
 # stat_aes <- unlist(lapply(Stat$find_all(), all_aes))
@@ -232,49 +235,3 @@ aes_auto <- function(data = NULL, ...) {
 
   structure(rename_aes(aes), class = "uneval")
 }
-
-
-use_defaults <- function(geom, data, params) {
-  df <- aesdefaults(data, geom$default_aes)
-
-  # Override mappings with atomic parameters
-  gp <- intersect(c(names(df), geom$required_aes), names(params))
-  gp <- gp[unlist(lapply(params[gp], is.atomic))]
-
-  # Check that mappings are compatible length: either 1 or the same length
-  # as the data
-  param_lengths <- vapply(params[gp], length, numeric(1))
-  bad <- param_lengths != 1L & param_lengths != nrow(df)
-  if (any(bad)) {
-    stop("Incompatible lengths for set aesthetics: ",
-      paste(names(bad), collapse = ", "), call. = FALSE)
-  }
-
-  df[gp] <- params[gp]
-  df
-}
-
-
-# Aesthetic defaults
-# Convenience method for setting aesthetic defaults
-#
-# @param data values from aesthetic mappings
-# @param y. defaults
-# @param params. user specified values
-# @value a data.frame, with all factors converted to character strings
-aesdefaults <- function(data, y.) {
-  cols <- plyr::tryapply(defaults(data, y.), function(x) eval(x, data, globalenv()))
-
-  # Need to be careful here because stat_boxplot uses a list-column to store
-  # a vector of outliers
-
-  cols <- Filter(function(x) is.atomic(x) || is.list(x), cols)
-  list_vars <- sapply(cols, is.list)
-  cols[list_vars] <- lapply(cols[list_vars], I)
-
-  df <- data.frame(cols, stringsAsFactors = FALSE)
-
-  factors <- sapply(df, is.factor)
-  df[factors] <- lapply(df[factors], as.character)
-  df
-}

R/annotation-custom.r

@@ -78,5 +78,5 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom,
     editGrob(grob, vp = vp)
   },
 
-  default_aes = aes(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf)
+  default_aes = aes_(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf)
 )

R/geom-.r

@@ -53,14 +53,14 @@ Geom <- ggproto("Geom",
   draw_key = draw_key_point,
 
   draw_layer = function(self, data, params, panel, coord) {
-    args <- c(list(quote(data), quote(panel_scales), quote(coord)), params)
+    data <- self$use_defaults(data, params)
 
+    args <- c(list(quote(data), quote(panel_scales), quote(coord)), params)
     plyr::dlply(data, "PANEL", function(data) {
       if (empty(data)) return(zeroGrob())
 
       panel_scales <- panel$ranges[[data$PANEL[1]]]
 
-      data <- use_defaults(self, data, params)
       do.call(self$draw_panel, args)
     }, .drop = FALSE)
   },
@@ -83,7 +83,34 @@ Geom <- ggproto("Geom",
   },
 
   setup_data = function(data, params) data,
-  setup_params = function(data, params) params
+  setup_params = function(data, params) params,
+
+  # Combine data with defaults and set aesthetics from parameters
+  use_defaults = function(self, data, params = list()) {
+    # Fill in missing aesthetics with their defaults
+    missing_aes <- setdiff(names(self$default_aes), names(data))
+    data[missing_aes] <- self$default_aes[missing_aes]
+
+    # Override mappings with atomic parameters
+    aes_params <- intersect(c(names(self$default_aes), self$required_aes), names(params))
+
+    # Check that mappings are compatible length: either 1 or the same length
+    # as the data
+    param_lengths <- vapply(params[aes_params], length, numeric(1))
+    n <- nrow(data)
+    bad <- param_lengths != 1L & param_lengths != n
+    if (any(bad)) {
+      stop(
+        "Aesthetics suppled as parameters, ", paste(names(bad), collapse = ", "),
+        ", must be either length 1 or the same as the data (", n, ")",
+        call. = FALSE
+      )
+    }
+
+    data[aes_params] <- params[aes_params]
+    data
+  }
+
 )
 
 # make_geom("point") returns GeomPoint

R/geom-dotplot.r

@@ -276,6 +276,6 @@ GeomDotplot <- ggproto("GeomDotplot", Geom,
 
   required_aes = c("x", "y"),
 
-  default_aes = aes(y = ..count.., colour = "black", fill = "black", alpha = NA)
+  default_aes = aes(colour = "black", fill = "black", alpha = NA)
 
 )

R/guide-legend.r

@@ -199,7 +199,8 @@ guide_train.legend <- function(guide, scale) {
   if (length(breaks) == 0 || all(is.na(breaks)))
     return()
 
-  key <- as.data.frame(setNames(list(scale_map(scale, breaks)), scale$aesthetics[1]))
+  key <- as.data.frame(setNames(list(scale_map(scale, breaks)), scale$aesthetics[1]),
+    stringsAsFactors = FALSE)
   key$.label <- scale_labels(scale, breaks)
 
   # this is a quick fix for #118
@@ -247,7 +248,7 @@ guide_geom.legend <- function(guide, layers, default_mapping) {
       # This layer contributes to the legend
       if (is.na(layer$show.legend) || layer$show.legend) {
         # Default is to include it
-        data <- use_defaults(layer$geom, guide$key[matched], layer$geom_params)
+        data <- layer$geom$use_defaults(guide$key[matched], layer$geom_params)
       } else {
         return(NULL)
       }
@@ -257,7 +258,7 @@ guide_geom.legend <- function(guide, layers, default_mapping) {
         # Default is to exclude it
         return(NULL)
       } else {
-        data <- use_defaults(layer$geom, NULL, layer$geom_params)[rep(1, nrow(guide$key)), ]
+        data <- layer$geom$use_defaults(NULL, layer$geom_params)[rep(1, nrow(guide$key)), ]
       }
     }
 

tests/testthat/test-aes-setting.r

@@ -5,19 +5,14 @@ test_that("Aesthetic parameters must match length of data", {
   p <- ggplot(df, aes(x, y))
 
   set_colours <- function(colours) {
-    pdf(file = NULL)
-    print(p + geom_point(colour = colours))
-    dev.off()
+    b <- ggplot_build(p + geom_point(colour = colours))
+    ggplot_gtable(b)
   }
 
   set_colours("red")
-  expect_error(set_colours(rep("red", 2)), "Incompatible lengths")
-  dev.off()  # Need to manually close device because of error
-  expect_error(set_colours(rep("red", 3)), "Incompatible lengths")
-  dev.off()
-  expect_error(set_colours(rep("red", 4)), "Incompatible lengths")
-  dev.off()
+  expect_error(set_colours(rep("red", 2)), "must be either length 1")
+  expect_error(set_colours(rep("red", 3)), "must be either length 1")
+  expect_error(set_colours(rep("red", 4)), "must be either length 1")
   set_colours(rep("red", 5))
 
-
 })