Check for dropped aesthetics

NEWS.md

@@ -1,5 +1,10 @@
 # ggplot2 (development version)
 
+* ggplot now checks during statistical transformations whether any data 
+  columns were dropped and warns about this. If stats intend to drop
+  data columns they can declare them in the new field `dropped_aes`.
+  (@clauswilke, #3250)
+
 * Use `rlang::hash()` instead of `digest::digest()`. This update may lead to 
   changes in the automatic sorting of legends. In order to enforce a specific
   legend order use the `order` argument in the guide. (@thomasp85, #4458)

R/stat-.r

@@ -61,6 +61,11 @@ Stat <- ggproto("Stat",
 
   non_missing_aes = character(),
 
+  # Any aesthetics that are dropped from the data frame during the
+  # statistical transformation should be listed here to suppress a
+  # warning about dropped aesthetics
+  dropped_aes = character(),
+
   optional_aes = character(),
 
   setup_params = function(data, params) {
@@ -122,7 +127,20 @@ Stat <- ggproto("Stat",
       )
     }, stats, groups, SIMPLIFY = FALSE)
 
-    rbind_dfs(stats)
+    data_new <- rbind_dfs(stats)
+
+    # The above code will drop columns that are not constant within groups and not
+    # carried over/recreated by the stat. This can produce unexpected results,
+    # and hence we warn about it.
+    dropped <- base::setdiff(names(data), base::union(self$dropped_aes, names(data_new)))
+    if (length(dropped) > 0) {
+      cli::cli_warn(c(
+        "The following aesthetics were dropped during statistical transformation: {.field {glue_collapse(dropped, sep = ', ')}}",
+        "i" = "This can happen when ggplot fails to infer the correct grouping structure in the data.",
+        "i" = "Did you forget to specify a {.code group} aesthetic or to convert a numerical variable into a factor?"
+      ))
+    }
+    data_new
   },
 
   compute_group = function(self, data, scales) {

R/stat-bin.r

@@ -167,6 +167,8 @@ StatBin <- ggproto("StatBin", Stat,
 
   default_aes = aes(x = after_stat(count), y = after_stat(count), weight = 1),
 
-  required_aes = "x|y"
+  required_aes = "x|y",
+
+  dropped_aes = "weight" # after statistical transformation, weights are no longer available
 )
 

R/stat-bindot.r

@@ -6,6 +6,7 @@ StatBindot <- ggproto("StatBindot", Stat,
   required_aes = "x",
   non_missing_aes = "weight",
   default_aes = aes(y = after_stat(count)),
+  dropped_aes = c("bin", "bincenter"), # these are temporary variables that are created and then removed by the stat
 
   setup_params = function(data, params) {
     if (is.null(params$binwidth)) {

R/stat-boxplot.r

@@ -47,6 +47,9 @@ stat_boxplot <- function(mapping = NULL, data = NULL,
 StatBoxplot <- ggproto("StatBoxplot", Stat,
   required_aes = c("y|x"),
   non_missing_aes = "weight",
+  # either the x or y aesthetic will get dropped during
+  # statistical transformation, depending on the orientation
+  dropped_aes = c("x", "y"),
   setup_data = function(self, data, params) {
     data <- flip_data(data, params$flipped_aes)
     data$x <- data$x %||% 0

R/stat-contour.r

@@ -83,6 +83,7 @@ StatContour <- ggproto("StatContour", Stat,
 
   required_aes = c("x", "y", "z"),
   default_aes = aes(order = after_stat(level)),
+  dropped_aes = "z", # z gets dropped during statistical transformation
 
   setup_params = function(data, params) {
     params$z.range <- range(data$z, na.rm = TRUE, finite = TRUE)
@@ -112,6 +113,7 @@ StatContourFilled <- ggproto("StatContourFilled", Stat,
 
   required_aes = c("x", "y", "z"),
   default_aes = aes(order = after_stat(level), fill = after_stat(level)),
+  dropped_aes = "z", # z gets dropped during statistical transformation
 
   setup_params = function(data, params) {
     params$z.range <- range(data$z, na.rm = TRUE, finite = TRUE)

R/stat-density-2d.r

@@ -115,6 +115,10 @@ StatDensity2d <- ggproto("StatDensity2d", Stat,
   default_aes = aes(colour = "#3366FF", size = 0.5),
 
   required_aes = c("x", "y"),
+  # because of the chained calculation in compute_panel(),
+  # which calls compute_panel() of a different stat, we declare
+  # dropped aesthetics there
+  dropped_aes = character(0),
 
   extra_params = c(
     "na.rm", "contour", "contour_var",
@@ -149,6 +153,8 @@ StatDensity2d <- ggproto("StatDensity2d", Stat,
     } else { # lines is the default
       contour_stat <- StatContour
     }
+    # update dropped aes
+    contour_stat$dropped_aes <- c(contour_stat$dropped_aes, "density", "ndensity", "count")
 
     args <- c(list(data = quote(data), scales = quote(scales)), params)
     dapply(data, "PANEL", function(data) {

R/stat-summary-2d.r

@@ -85,6 +85,7 @@ StatSummary2d <- ggproto("StatSummary2d", Stat,
   default_aes = aes(fill = after_stat(value)),
 
   required_aes = c("x", "y", "z"),
+  dropped_aes = "z", # z gets dropped during statistical transformation
 
   compute_group = function(data, scales, binwidth = NULL, bins = 30,
                            breaks = NULL, origin = NULL, drop = TRUE,

R/stat-summary-hex.r

@@ -41,6 +41,8 @@ StatSummaryHex <- ggproto("StatSummaryHex", Stat,
 
   required_aes = c("x", "y", "z"),
 
+  dropped_aes = "z", # z gets dropped during statistical transformation
+
   compute_group = function(data, scales, binwidth = NULL, bins = 30, drop = TRUE,
                            fun = "mean", fun.args = list()) {
     check_installed("hexbin", reason = "for `stat_summary_hex()`")

tests/testthat/test-stats.r

@@ -19,3 +19,16 @@ test_that("error message is thrown when aesthetics are missing", {
   p <- ggplot(mtcars) + stat_sum()
   expect_error(ggplot_build(p), "x and y$")
 })
+
+test_that("erroneously dropped aesthetics are found and issue a warning", {
+  df <- data_frame(
+    x = c( # arbitrary random numbers
+      0.42986445,  1.11153170, -1.22318013,  0.90982003,
+      0.46454276, -0.42300004, -1.76139834, -0.75060412,
+      0.01635474, -0.63202159
+    ),
+    g = rep(1:2, each = 5)
+  )
+  p <- ggplot(df, aes(x, fill = g)) + geom_density()
+  expect_warning(ggplot_build(p), "aesthetics were dropped")
+})