Convert stat$inform_defaults to stat$compute_defaults

Author: hadley

R/layer.r

@@ -105,17 +105,17 @@ Layer <- ggproto("Layer", NULL,
   },
 
 
-  calc_statistic = function(self, data, scales) {
+  calc_statistic = function(self, data, scales, params) {
     if (empty(data))
       return(data.frame())
 
     check_required_aesthetics(
       self$stat$required_aes,
-      c(names(data), names(self$stat_params)),
+      c(names(data), names(params)),
       snake_class(self$stat)
     )
 
-    args <- c(list(data = quote(data), scales = quote(scales)), self$stat_params)
+    args <- c(list(data = quote(data), scales = quote(scales)), params)
     tryCatch(do.call(self$stat$calculate_groups, args), error = function(e) {
       warning("Computation failed in `", snake_class(self$stat), "()`:\n",
         e$message, call. = FALSE)
@@ -160,7 +160,9 @@ Layer <- ggproto("Layer", NULL,
 
 
   adjust_position = function(self, data) {
+    if (empty(data)) return(data.frame())
     params <- self$position$compute_defaults(data)
+
     plyr::ddply(data, "PANEL", function(data) {
       if (empty(data)) return(data.frame())
 

R/panel.r

@@ -188,11 +188,11 @@ calculate_stats <- function(panel, data, layers) {
     d <- data[[i]]
     l <- layers[[i]]
 
-    l$stat$inform_defaults(d, l$stat_params)
+    params <- l$stat$compute_defaults(d, l$stat_params)
 
     plyr::ddply(d, "PANEL", function(panel_data) {
       scales <- panel_scales(panel, panel_data$PANEL[1])
-      l$calc_statistic(panel_data, scales)
+      l$calc_statistic(panel_data, scales, params)
     })
   })
 }

R/stat-.r

@@ -13,9 +13,9 @@
 #'   \item \code{calculate}: Calculates a stat for a single group of data.
 #'   \item \code{calculate_groups}: Calculates stat for all groups. The method
 #'     typically calls \code{calculate} for each group.
-#'   \item \code{inform_defaults(data, params)}: called once for each layer.
-#'      Used to inform the user how important parameter choices are made
-#'      by default.
+#'   \item \code{compute_defaults(data, params)}: called once for each layer.
+#'      Used to compute defaults that need to complete dataset, and to inform
+#'      the user of important choices.
 #'   \item \code{required_aes}: A character vector of aesthetics needed to
 #'     render the geom.
 #'   \item \code{default_aes}: A list (generated by \code{\link{aes}()} of
@@ -39,7 +39,8 @@ Stat <- ggproto("Stat",
     data
   },
 
-  inform_defaults = function(data, params) {
+  compute_defaults = function(data, params) {
+    params
   },
 
   calculate_groups = function(self, data, scales, ...) {

R/stat-bin.r

@@ -48,14 +48,16 @@ stat_bin <- function(mapping = NULL, data = NULL, geom = "bar",
 #' @usage NULL
 #' @export
 StatBin <- ggproto("StatBin", Stat,
-  inform_defaults = function(data, params) {
+  compute_defaults = function(data, params) {
     if (!is.null(data$y) || !is.null(params$y)) {
       warning("stat_bin() ignores y aesthetic.", call. = FALSE)
     }
 
     if (is.null(params$breaks) && is.null(params$binwidth) && is.null(params$bins)) {
       message("`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.")
     }
+
+    params
   },
 
   calculate = function(self, data, scales, binwidth = NULL, bins = NULL,

R/stat-bindot.r

@@ -3,10 +3,11 @@
 #' @usage NULL
 #' @export
 StatBindot <- ggproto("StatBindot", Stat,
-  inform_defaults = function(data, params) {
+  compute_defaults = function(data, params) {
     if (is.null(params$breaks) && is.null(params$binwidth)) {
       message("`stat_bindot()` using `bins = 30`. Pick better value with `binwidth`.")
     }
+    params
   },
 
   calculate_groups = function(self, data, na.rm = FALSE, binwidth = NULL,

R/stat-boxplot.r

@@ -43,20 +43,18 @@ stat_boxplot <- function(mapping = NULL, data = NULL, geom = "boxplot",
 StatBoxplot <- ggproto("StatBoxplot", Stat,
   required_aes = c("x", "y"),
 
-  calculate_groups = function(self, data, na.rm = FALSE, width = NULL, ...)
-  {
-    data <- remove_missing(data, na.rm, c("x", "y", "weight"), name = "stat_boxplot",
-      finite = TRUE)
-    data$weight <- data$weight %||% 1
-    width <- width %||%  resolution(data$x) * 0.75
-
-    ggproto_parent(Stat, self)$calculate_groups(data, na.rm = na.rm,
-      width = width, ...)
+  compute_defaults = function(data, params) {
+    params$width <- params$width %||% resolution(data$x) * 0.75
+    params
   },
 
   calculate = function(data, scales, width = NULL, na.rm = FALSE, coef = 1.5, ...) {
     qs <- c(0, 0.25, 0.5, 0.75, 1)
-    if (length(unique(data$weight)) != 1) {
+
+    data <- remove_missing(data, na.rm, c("x", "y", "weight"), name = "stat_boxplot",
+      finite = TRUE)
+
+    if (!is.null(data$weight)) {
       mod <- quantreg::rq(y ~ 1, weights = weight, data = data, tau = qs)
       stats <- as.numeric(stats::coef(mod))
     } else {

R/stat-smooth.r

@@ -56,45 +56,31 @@ stat_smooth <- function(mapping = NULL, data = NULL, geom = "smooth",
 #' @export
 StatSmooth <- ggproto("StatSmooth", Stat,
 
-  inform_defaults = function(data, params) {
+  compute_defaults = function(data, params) {
+    # Figure out what type of smoothing to do: loess for small datasets,
+    # gam with a cubic regression basis for large data
+    # This is based on the size of the _largest_ group.
     if (identical(params$method, "auto")) {
       message(
         '`geom_smooth()`: For groups with <1000 observations, using ',
         '`method = "loess"` with `span = 0.75`,\n otherwise ',
         '`method = "gam"` with `formula = y ~ s(x, bs = "cs")`.'
       )
-    }
-  },
-
-  calculate_groups = function(self, data, scales, method = "auto",
-    formula = y ~ x, ...) {
-    rows <- plyr::daply(data, "group", function(df) length(unique(df$x)))
 
-    if (all(rows == 1) && length(rows) > 1) {
-      message("geom_smooth: Only one unique x value each group.",
-        "Maybe you want aes(group = 1)?")
-      return(data.frame())
-    }
-
-    # Figure out what type of smoothing to do: loess for small datasets,
-    # gam with a cubic regression basis for large data
-    # This is based on the size of the _largest_ group.
-    if (identical(method, "auto")) {
-      groups <- plyr::count(data, "group")
+      max_group <- max(table(data$group))
 
-      if (max(groups$freq) < 1000) {
-        method <- "loess"
+      if (max_group < 1000) {
+        params$method <- "loess"
       } else {
-        method <- "gam"
-        formula <- y ~ s(x, bs = "cs")
+        params$method <- "gam"
+        params$formula <- y ~ s(x, bs = "cs")
       }
     }
-    if (identical(method, "gam")) {
-      method <- mgcv::gam
+    if (identical(params$method, "gam")) {
+      params$method <- mgcv::gam
     }
 
-    ggproto_parent(Stat, self)$calculate_groups(data, scales, method = method,
-      formula = formula, ...)
+    params
   },
 
   calculate = function(data, scales, method = "auto", formula = y~x,

man/ggplot2-ggproto.Rd

@@ -196,9 +196,9 @@ implement one or more of the following:
   \item \code{calculate}: Calculates a stat for a single group of data.
   \item \code{calculate_groups}: Calculates stat for all groups. The method
     typically calls \code{calculate} for each group.
-  \item \code{inform_defaults(data, params)}: called once for each layer.
-     Used to inform the user how important parameter choices are made
-     by default.
+  \item \code{compute_defaults(data, params)}: called once for each layer.
+     Used to compute defaults that need to complete dataset, and to inform
+     the user of important choices.
   \item \code{required_aes}: A character vector of aesthetics needed to
     render the geom.
   \item \code{default_aes}: A list (generated by \code{\link{aes}()} of

tests/testthat/test-stats-function.r

@@ -5,7 +5,7 @@ test_stat_scale <- function(stat, scale) {
   stat$data <- transform(stat$data, PANEL = 1)
   dat <- stat$compute_aesthetics(stat$data, ggplot())
   dat <- add_group(dat)
-  stat$calc_statistic(dat, scale)
+  stat$calc_statistic(dat, scale, stat$stat_params)
 }
 
 test_that("stat-function", {

tests/testthat/test-stats.r

@@ -18,7 +18,7 @@ test_stat <- function(stat) {
   stat$data <- transform(stat$data, PANEL = 1)
   dat <- stat$compute_aesthetics(stat$data, ggplot())
   dat <- add_group(dat)
-  stat$calc_statistic(dat, NULL)
+  stat$calc_statistic(dat, NULL, stat$stat_params)
 }
 
 context("stat-bin")
@@ -93,7 +93,7 @@ test_stat_scale <- function(stat, scale) {
   stat$data <- transform(stat$data, PANEL = 1)
   dat <- stat$compute_aesthetics(stat$data, ggplot())
   dat <- add_group(dat)
-  stat$calc_statistic(dat, scale)
+  stat$calc_statistic(dat, scale, stat$stat_params)
 }
 
 context("stat-bin2d")