Merge branch 'main' into guide_data3

NEWS.md

@@ -3,6 +3,24 @@
 * The `get_guide_data()` function can be used to extract position and label
   information from the plot (#5004).
 
+* When using `geom_dotplot(binaxis = "x")` with a discrete y-variable, dots are
+  now stacked from the y-position rather than from 0 (@teunbrand, #5462)
+
+* (breaking) In the `scale_{colour/fill}_gradient2()` and 
+  `scale_{colour/fill}_steps2()` functions, the `midpoint` argument is 
+  transformed by the scale transformation (#3198).
+
+* `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/geom-dotplot.R

@@ -242,12 +242,12 @@ GeomDotplot <- ggproto("GeomDotplot", Geom,
       # ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
       # Can't do bounding box per dot, because y position isn't real.
       # After position code is rewritten, each dot should have its own bounding box.
+      yoffset <- if (is_mapped_discrete(data$y)) data$y else 0
       data$xmin <- data$x - data$binwidth / 2
       data$xmax <- data$x + data$binwidth / 2
-      data$ymin <- stackaxismin
-      data$ymax <- stackaxismax
-      data$y    <- 0
-
+      data$ymin <- stackaxismin + yoffset
+      data$ymax <- stackaxismax + yoffset
+      data$y <- yoffset
     } else if (params$binaxis == "y") {
       # ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
       # Can't do bounding box per dot, because x position isn't real.

R/guide-colorbar.R

@@ -21,6 +21,9 @@ NULL
 #'   raster object. If `FALSE` then the colourbar is rendered as a set of
 #'   rectangles. Note that not all graphics devices are capable of rendering
 #'   raster image.
+#' @param alpha A numeric between 0 and 1 setting the colour transparency of
+#'   the bar. Use `NA` to preserve the alpha encoded in the colour itself
+#'   (default).
 #' @param draw.ulim A logical specifying if the upper limit tick marks should
 #'   be visible.
 #' @param draw.llim A logical specifying if the lower limit tick marks should
@@ -107,6 +110,7 @@ guide_colourbar <- function(
   theme = NULL,
   nbin = 300,
   raster = TRUE,
+  alpha = NA,
   draw.ulim = TRUE,
   draw.llim = TRUE,
   position = NULL,
@@ -121,12 +125,14 @@ guide_colourbar <- function(
   if (!is.null(position)) {
     position <- arg_match0(position, c(.trbl, "inside"))
   }
+  check_number_decimal(alpha, min = 0, max = 1, allow_na = TRUE)
 
   new_guide(
     title = title,
     theme = theme,
     nbin = nbin,
     raster = raster,
+    alpha = alpha,
     draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)),
     position = position,
     direction = direction,
@@ -162,6 +168,7 @@ GuideColourbar <- ggproto(
     # bar
     nbin = 300,
     raster = TRUE,
+    alpha = NA,
 
     draw_lim = c(TRUE, TRUE),
 
@@ -204,15 +211,15 @@ GuideColourbar <- ggproto(
     Guide$extract_key(scale, aesthetic, ...)
   },
 
-  extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, ...) {
+  extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, alpha = NA, ...) {
 
     limits <- scale$get_limits()
     bar <- seq(limits[1], limits[2], length.out = nbin)
     if (length(bar) == 0) {
       bar <- unique0(limits)
     }
     bar <- data_frame0(
-      colour = scale$map(bar),
+      colour = alpha(scale$map(bar), alpha),
       value  = bar,
       .size  = length(bar)
     )

R/guide-colorsteps.R

@@ -46,6 +46,7 @@
 guide_coloursteps <- function(
   title = waiver(),
   theme = NULL,
+  alpha = NA,
   even.steps  = TRUE,
   show.limits = NULL,
   direction = NULL,
@@ -56,10 +57,12 @@ guide_coloursteps <- function(
 ) {
 
   theme <- deprecated_guide_args(theme, ...)
+  check_number_decimal(alpha, min = 0, max = 1, allow_na = TRUE)
 
   new_guide(
     title = title,
     theme = theme,
+    alpha = alpha,
     even.steps  = even.steps,
     show.limits = show.limits,
     direction = direction,
@@ -120,11 +123,11 @@ GuideColoursteps <- ggproto(
 
   extract_decor = function(scale, aesthetic, key,
                            reverse = FALSE, even.steps = TRUE,
-                           nbin = 100, ...) {
+                           nbin = 100, alpha = NA,...) {
     if (even.steps) {
       bin_at <- attr(key, "bin_at", TRUE)
       bar <- data_frame0(
-        colour = scale$map(bin_at),
+        colour = alpha(scale$map(bin_at), alpha),
         min    = seq_along(bin_at) - 1,
         max    = seq_along(bin_at),
         .size  = length(bin_at)
@@ -134,7 +137,7 @@ GuideColoursteps <- ggproto(
       n <- length(breaks)
       bin_at <- (breaks[-1] + breaks[-n]) / 2
       bar <- data_frame0(
-        colour = scale$map(bin_at),
+        colour = alpha(scale$map(bin_at), alpha),
         min    = head(breaks, -1),
         max    = tail(breaks, -1),
         .size  = length(bin_at)

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/scale-.R

@@ -609,7 +609,7 @@ check_breaks_labels <- function(breaks, labels, call = NULL) {
 default_transform <- function(self, x) {
   transformation <- self$get_transformation()
   new_x <- transformation$transform(x)
-  check_transformation(x, new_x, self$transformation$name, self$call)
+  check_transformation(x, new_x, self$transformation$name, call = self$call)
   new_x
 }
 
@@ -1329,13 +1329,17 @@ scale_flip_position <- function(scale) {
   invisible()
 }
 
-check_transformation <- function(x, transformed, name, call = NULL) {
-  if (any(is.finite(x) != is.finite(transformed))) {
-    cli::cli_warn(
-      "{.field {name}} transformation introduced infinite values.",
-      call = call
-    )
+check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) {
+  if (!any(is.finite(x) != is.finite(transformed))) {
+    return(invisible())
+  }
+  if (is.null(arg)) {
+    end <- "."
+  } else {
+    end <- paste0(" in {.arg {arg}}.")
   }
+  msg <- paste0("{.field {name}} transformation introduced infinite values", end)
+  cli::cli_warn(msg, call = call)
 }
 
 trans_support_nbreaks <- function(trans) {

R/scale-gradient.R

@@ -90,37 +90,47 @@ scale_fill_gradient <- function(..., low = "#132B43", high = "#56B1F7", space =
 }
 
 #' @inheritParams scales::pal_div_gradient
+#' @inheritParams continuous_scale
 #' @param midpoint The midpoint (in data value) of the diverging scale.
 #'   Defaults to 0.
 #' @rdname scale_gradient
 #' @export
 scale_colour_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
-                                   midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar",
+                                   midpoint = 0, space = "Lab", na.value = "grey50",
+                                   transform = "identity", guide = "colourbar",
                                    aesthetics = "colour") {
   continuous_scale(
     aesthetics,
-    palette = pal_div_gradient(low, mid, high, space),
-    na.value = na.value, guide = guide, ...,
-    rescaler = mid_rescaler(mid = midpoint)
+    palette = div_gradient_pal(low, mid, high, space),
+    na.value = na.value, transform = transform, guide = guide, ...,
+    rescaler = mid_rescaler(mid = midpoint, transform = transform)
   )
 }
 
 #' @rdname scale_gradient
 #' @export
 scale_fill_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
-                                 midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar",
+                                 midpoint = 0, space = "Lab", na.value = "grey50",
+                                 transform = "identity", guide = "colourbar",
                                  aesthetics = "fill") {
   continuous_scale(
     aesthetics,
-    palette = pal_div_gradient(low, mid, high, space),
-    na.value = na.value, guide = guide, ...,
-    rescaler = mid_rescaler(mid = midpoint)
+    palette = div_gradient_pal(low, mid, high, space),
+    na.value = na.value, transform = transform, guide = guide, ...,
+    rescaler = mid_rescaler(mid = midpoint, transform = transform)
   )
 }
 
-mid_rescaler <- function(mid) {
+mid_rescaler <- function(mid, transform = "identity",
+                         arg = caller_arg(mid), call = caller_env()) {
+  transform <- as.trans(transform)
+  trans_mid <- transform$transform(mid)
+  check_transformation(
+    mid, trans_mid, transform$name,
+    arg = arg, call = call
+  )
   function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) {
-    rescale_mid(x, to, from, mid)
+    rescale_mid(x, to, from, trans_mid)
   }
 }
 

R/scale-steps.R

@@ -52,10 +52,13 @@ scale_colour_steps <- function(..., low = "#132B43", high = "#56B1F7", space = "
 #' @rdname scale_steps
 #' @export
 scale_colour_steps2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
-                                midpoint = 0, space = "Lab", na.value = "grey50", guide = "coloursteps",
+                                midpoint = 0, space = "Lab", na.value = "grey50",
+                                transform = "identity", guide = "coloursteps",
                                 aesthetics = "colour") {
-  binned_scale(aesthetics, palette = pal_div_gradient(low, mid, high, space),
-               na.value = na.value, guide = guide, rescaler = mid_rescaler(mid = midpoint), ...)
+  binned_scale(aesthetics, palette = div_gradient_pal(low, mid, high, space),
+               na.value = na.value, transform = transform, guide = guide,
+               rescaler = mid_rescaler(mid = midpoint, transform = transform),
+               ...)
 }
 #' @rdname scale_steps
 #' @export
@@ -75,10 +78,12 @@ scale_fill_steps <- function(..., low = "#132B43", high = "#56B1F7", space = "La
 #' @rdname scale_steps
 #' @export
 scale_fill_steps2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
-                              midpoint = 0, space = "Lab", na.value = "grey50", guide = "coloursteps",
+                              midpoint = 0, space = "Lab", na.value = "grey50",
+                              transform = "identity", guide = "coloursteps",
                               aesthetics = "fill") {
-  binned_scale(aesthetics, palette = pal_div_gradient(low, mid, high, space),
-               na.value = na.value, guide = guide, rescaler = mid_rescaler(mid = midpoint), ...)
+  binned_scale(aesthetics, palette = div_gradient_pal(low, mid, high, space),
+               na.value = na.value, transform = transform, guide = guide,
+               rescaler = mid_rescaler(mid = midpoint, transform = transform), ...)
 }
 #' @rdname scale_steps
 #' @export

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,