Drop non-constant aesthetics more thoroughly

R/stat-.r

@@ -120,13 +120,21 @@ Stat <- ggproto("Stat",
       self$compute_group(data = group, scales = scales, ...)
     })
 
+    # record dropped columns
+    dropped <- character(0)
     stats <- mapply(function(new, old) {
       if (empty(new)) return(data_frame0())
-      unique <- uniquecols(old)
-      missing <- !(names(unique) %in% names(new))
+
+      # ignore the columns that will be overwritten by `new`
+      old <- old[, !(names(old) %in% names(new)), drop = FALSE]
+
+      # drop columns that are not constant within group
+      unique_idx <- vapply(old, function(x) length(unique0(x)) == 1, logical(1L))
+      dropped <<- c(dropped, names(old)[!unique_idx])
+
       vec_cbind(
         new,
-        unique[rep(1, nrow(new)), missing,drop = FALSE]
+        old[rep(1, nrow(new)), unique_idx, drop = FALSE]
       )
     }, stats, groups, SIMPLIFY = FALSE)
 
@@ -135,15 +143,16 @@ Stat <- ggproto("Stat",
     # 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)))
+    dropped <- unique0(dropped)
+    dropped <- dropped[!dropped %in% self$dropped_aes]
     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
+    data_new[, !names(data_new) %in% dropped, drop = FALSE]
   },
 
   compute_group = function(self, data, scales) {

tests/testthat/test-stats.r

@@ -21,14 +21,59 @@ test_that("error message is thrown when aesthetics are missing", {
 })
 
 test_that("erroneously dropped aesthetics are found and issue a warning", {
-  df <- data_frame(
+
+  # case 1) dropped completely
+
+  df1 <- 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")
+  p1 <- ggplot(df1, aes(x, fill = g)) + geom_density()
+  expect_warning(ggplot_build(p1), "aesthetics were dropped")
+
+  # case 2-1) dropped partially
+
+  df2 <- data_frame(
+    id     = c("a", "a", "b", "b", "c"),
+    colour = c(  0,   1,  10,  10,  20),   # a should be dropped
+    fill   = c(  0,   0,  10,  11,  20)    # b should be dropped
+  )
+
+  p2 <- ggplot(df2, aes(id, colour = colour, fill = fill)) + geom_bar()
+  expect_warning(
+    b2 <- ggplot_build(p2),
+    "The following aesthetics were dropped during statistical transformation: .*colour.*, .*fill.*"
+  )
+
+  # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA)
+  expect_true(all(is.na(b2$data[[1]]$colour)))
+  # fill is dropped because group b's fill is not constant
+  expect_true(all(b2$data[[1]]$fill == GeomBar$default_aes$fill))
+
+  # case 2-1) dropped partially with NA
+
+  df3 <- data_frame(
+    id     = c("a", "a", "b", "b", "c"),
+    colour = c(  0,  NA,  10,  10,  20),   # a should be dropped
+    fill   = c( NA,  NA,  10,  10,  20)    # a should not be dropped
+  )
+
+  p3 <- ggplot(df3, aes(id, colour = colour, fill = fill)) + geom_bar() +
+    scale_fill_continuous(na.value = "#123")
+  expect_warning(
+    b3 <- ggplot_build(p3),
+    "The following aesthetics were dropped during statistical transformation: .*colour.*"
+  )
+
+  # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA)
+  expect_true(all(is.na(b3$data[[1]]$colour)))
+  # fill is NOT dropped. Group a's fill is na.value, but others are mapped.
+  expect_equal(
+    b3$data[[1]]$fill == "#123",
+    c(TRUE, FALSE, FALSE)
+  )
 })