Merge branch 'main' into colourbar_alpha

NEWS.md

@@ -2,6 +2,15 @@
 
 * `guide_colourbar()` and `guide_coloursteps()` gain an `alpha` argument to
  set the transparency of the bar (#5085).
+
+* `stat_count()` treats `x` as unique in the same manner `unique()` does 
+ (#4609).
+
+* `position_stack()` no longer silently removes missing data, which is now
+ handled by the geom instead of position (#3532).
+
+* Legend keys that can draw arrows have their size adjusted for arrows.
+
 * The `trans` argument in scales and secondary axes has been renamed to 
  `transform`. The `trans` argument itself is deprecated. To access the
  transformation from the scale, a new `get_transformation()` method is 

R/legend-draw.R

@@ -160,8 +160,7 @@ draw_key_path <- function(data, params, size) {
  } else {
  data$linetype[is.na(data$linetype)] <- 0
  }
-
- segmentsGrob(0.1, 0.5, 0.9, 0.5,
+ grob <- segmentsGrob(0.1, 0.5, 0.9, 0.5,
  gp = gpar(
  col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
  fill = alpha(params$arrow.fill %||% data$colour
@@ -172,12 +171,19 @@ draw_key_path <- function(data, params, size) {
  ),
  arrow = params$arrow
  )
+ if (!is.null(params$arrow)) {
+ angle <- deg2rad(params$arrow$angle)
+ length <- convertUnit(params$arrow$length, "cm", valueOnly = TRUE)
+ attr(grob, "width") <- cos(angle) * length * 1.25
+ attr(grob, "height") <- sin(angle) * length * 2
+ }
+ grob
 }
 
 #' @export
 #' @rdname draw_key
 draw_key_vpath <- function(data, params, size) {
- segmentsGrob(0.5, 0.1, 0.5, 0.9,
+ grob <- segmentsGrob(0.5, 0.1, 0.5, 0.9,
  gp = gpar(
  col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
  lwd = (data$linewidth %||% 0.5) * .pt,
@@ -186,6 +192,13 @@ draw_key_vpath <- function(data, params, size) {
  ),
  arrow = params$arrow
  )
+ if (!is.null(params$arrow)) {
+ angle <- deg2rad(params$arrow$angle)
+ length <- convertUnit(params$arrow$length, "cm", valueOnly = TRUE)
+ attr(grob, "width") <- sin(angle) * length * 2
+ attr(grob, "height") <- cos(angle) * length * 1.25
+ }
+ grob
 }
 
 #' @export
@@ -215,10 +228,14 @@ draw_key_linerange <- function(data, params, size) {
 #' @export
 #' @rdname draw_key
 draw_key_pointrange <- function(data, params, size) {
- grobTree(
- draw_key_linerange(data, params, size),
+ linerange <- draw_key_linerange(data, params, size)
+ grob <- grobTree(
+ linerange,
  draw_key_point(transform(data, size = (data$size %||% 1.5) * 4), params)
  )
+ attr(grob, "width") <- attr(linerange, "width")
+ attr(grob, "height") <- attr(linerange, "height")
+ grob
 }
 
 #' @export
@@ -227,10 +244,15 @@ draw_key_smooth <- function(data, params, size) {
  data$fill <- alpha(data$fill %||% "grey60", data$alpha)
  data$alpha <- 1
 
- grobTree(
+ path <- draw_key_path(data, params, size)
+
+ grob <- grobTree(
  if (isTRUE(params$se)) rectGrob(gp = gpar(col = NA, fill = data$fill)),
- draw_key_path(data, params, size)
+ path
  )
+ attr(grob, "width") <- attr(path, "width")
+ attr(grob, "height") <- attr(path, "height")
+ grob
 }
 
 #' @export

R/position-stack.R

@@ -175,11 +175,10 @@ PositionStack <- ggproto("PositionStack", Position,
  ymax = as.numeric(ifelse(data$ymax == 0, data$ymin, data$ymax))
  )
 
- data <- remove_missing(
- data,
- vars = c("x", "xmin", "xmax", "y"),
- name = "position_stack"
- )
+ vars <- intersect(c("x", "xmin", "xmax", "y"), names(data))
+ missing <- detect_missing(data, vars)
+ data[missing, vars] <- NA
+
  flip_data(data, params$flipped_aes)
  },
 

R/stat-count.R

@@ -75,8 +75,7 @@ StatCount <- ggproto("StatCount", Stat,
  x <- data$x
  weight <- data$weight %||% rep(1, length(x))
 
- count <- as.numeric(tapply(weight, x, sum, na.rm = TRUE))
- count[is.na(count)] <- 0
+ count <- as.vector(rowsum(weight, x, na.rm = TRUE))
 
  bars <- data_frame0(
  count = count,

tests/testthat/test-geom-col.R

@@ -7,8 +7,8 @@ test_that("geom_col removes columns with parts outside the plot limits", {
  ggplotGrob(p + ylim(0.5, 4)),
  "Removed 3 rows containing missing values or values outside the scale range"
  )
- expect_warning( # warning created at build stage
- ggplot_build(p + ylim(0, 2.5)),
+ expect_warning( # warning created at render stage
+ ggplotGrob(p + ylim(0, 2.5)),
  "Removed 1 row containing missing values or values outside the scale range"
  )
 })

tests/testthat/test-scales.R

@@ -111,10 +111,14 @@ test_that("oob affects position values", {
  }
  base + scale_y_continuous(limits = c(-0,5))
 
- expect_warning(low_censor <- cdata(base + y_scale(c(0, 5), censor)),
+ low_censor <- cdata(base + y_scale(c(0, 5), censor))
+ mid_censor <- cdata(base + y_scale(c(3, 7), censor))
+ handle <- GeomBar$handle_na
+
+ expect_warning(low_censor[[1]] <- handle(low_censor[[1]], list(na.rm = FALSE)),
  "Removed 1 row containing missing values or values outside the scale range")
- expect_warning(mid_censor <- cdata(base + y_scale(c(3, 7), censor)),
- "Removed 2 rows containing missing values or values outside the scale range")
+ expect_warning(mid_censor[[1]] <- handle(mid_censor[[1]], list(na.rm = FALSE)),
+ "Removed 3 rows containing missing values or values outside the scale range")
 
  low_squish <- cdata(base + y_scale(c(0, 5), squish))
  mid_squish <- cdata(base + y_scale(c(3, 7), squish))
@@ -127,7 +131,7 @@ test_that("oob affects position values", {
 
  # Bars depend on limits and oob
  expect_equal(low_censor[[1]]$y, c(0.2, 1))
- expect_equal(mid_censor[[1]]$y, c(0.5))
+ expect_equal(mid_censor[[1]]$y, numeric(0))
  expect_equal(low_squish[[1]]$y, c(0.2, 1, 1))
  expect_equal(mid_squish[[1]]$y, c(0, 0.5, 1))
 })

tests/testthat/test-stat-count.R

@@ -4,3 +4,14 @@ test_that("stat_count() checks the aesthetics", {
  p <- ggplot(mtcars) + stat_count(aes(factor(gear), mpg))
  expect_snapshot_error(ggplot_build(p))
 })
+
+test_that("stat_count() respects uniqueness of `x`", {
+ # For #4609, converting x to factor loses smallest digits, so here we test
+ # if they are retained
+ df <- data_frame0(x = c(1, 2, 1, 2) + rep(c(0, 1.01 * .Machine$double.eps), each = 2))
+ p <- ggplot(df, aes(x)) + stat_count(position = "identity")
+ data <- layer_data(p)
+
+ expect_length(vec_unique(df$x), 4)
+ expect_equal(data$y, rep(1, 4))
+})