Merge branch 'main' into attr_stability

Author: teunbrand

DESCRIPTION

@@ -242,6 +242,7 @@ Collate:
     'scales-.R'
     'stat-align.R'
     'stat-bin.R'
+    'stat-summary-2d.R'
     'stat-bin2d.R'
     'stat-bindot.R'
     'stat-binhex.R'
@@ -263,7 +264,6 @@ Collate:
     'stat-smooth-methods.R'
     'stat-smooth.R'
     'stat-sum.R'
-    'stat-summary-2d.R'
     'stat-summary-bin.R'
     'stat-summary-hex.R'
     'stat-summary.R'

NAMESPACE

@@ -20,6 +20,8 @@ S3method(c,mapped_discrete)
 S3method(drawDetails,zeroGrob)
 S3method(element_grob,element_blank)
 S3method(element_grob,element_line)
+S3method(element_grob,element_point)
+S3method(element_grob,element_polygon)
 S3method(element_grob,element_rect)
 S3method(element_grob,element_text)
 S3method(format,ggproto)
@@ -346,6 +348,8 @@ export(element_blank)
 export(element_geom)
 export(element_grob)
 export(element_line)
+export(element_point)
+export(element_polygon)
 export(element_rect)
 export(element_render)
 export(element_text)

NEWS.md

@@ -2,6 +2,33 @@
 
 * (internal) layer data can be attenuated with parameter attributes 
   (@teunbrand, #3175).
+* Date scales silently coerce <POSIXct> to <Date> and datetime scales silently
+  coerce <Date> to <POSIXct> (@laurabrianna, #3533)
+* New parameters for `geom_label()` (@teunbrand and @steveharoz, #5365):
+  * The `linewidth` aesthetic is now applied and replaces the `label.size` 
+    argument.
+  * The `linetype` aesthetic is now applied.
+  * New `border.colour` argument to set the colour of borders.
+  * New `text.colour` argument to set the colour of text.
+* New `element_point()` and `element_polygon()` that can be given to 
+  `theme(point, polygon)` as an extension point (@teunbrand, #6248).
+* Turned off fallback for `size` to `linewidth` translation in 
+  `geom_bar()`/`geom_col()` (#4848).
+* `coord_radial()` now displays no axis instead of throwing an error when
+  a scale has no breaks (@teunbrand, #6271).
+* The `fatten` argument has been deprecated in `geom_boxplot()`, 
+  `geom_crossbar()` and `geom_pointrange()` (@teunbrand, #4881).
+* Axis labels are now preserved better when using `coord_sf(expand = TRUE)` and
+  graticule lines are straight but do not meet the edge (@teunbrand, #2985).
+* Attempt to boost detail in `coord_polar()` and `coord_radial()` near the 
+  center (@teunbrand, #5023)
+* Scale names, guide titles and aesthetic labels can now accept functions 
+  (@teunbrand, #4313)
+* Binned scales with zero-width data expand the default limits by 0.1 
+  (@teunbrand, #5066)
+* New default `geom_qq_line(geom = "abline")` for better clipping in the 
+  vertical direction. In addition, `slope` and `intercept` are new computed
+  variables in `stat_qq_line()` (@teunbrand, #6087).
 * Position adjustments can now have auxiliary aesthetics (@teunbrand).
     * `position_nudge()` gains `nudge_x` and `nudge_y` aesthetics (#3026, #5445).
     * `position_dodge()` gains `order` aesthetic (#3022, #3345)
@@ -253,7 +280,7 @@
 * The ellipsis argument is now checked in `fortify()`, `get_alt_text()`, 
   `labs()` and several guides (@teunbrand, #3196).
 * `stat_summary_bin()` no longer ignores `width` parameter (@teunbrand, #4647).
-* Added `keep.zeroes` argument to `stat_bin()` (@teunbrand, #3449)
+* Reintroduced `drop` argument to `stat_bin()` (@teunbrand, #3449)
 * (internal) removed barriers for using 2D structures as aesthetics 
   (@teunbrand, #4189).
 * `coord_sf()` no longer errors when dealing with empty graticules (@teunbrand, #6052)
@@ -270,6 +297,21 @@
   aesthetics (@teunbrand, #2800).
 * Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162)
 * Added `weight` aesthetic for `stat_ellipse()` (@teunbrand, #5272)
+* Fixed a bug where the `guide_custom(order)` wasn't working (@teunbrand, #6195)
+* All binning stats now use the `boundary`/`center` parametrisation rather
+  than `origin`, following in `stat_bin()`'s footsteps (@teunbrand).
+* `stat_summary_2d()` and `stat_bin_2d()` now deal with zero-range data
+  more elegantly (@teunbrand, #6207).
+* Munching in `coord_polar()` and `coord_radial()` now adds more detail, 
+  particularly for data-points with a low radius near the center 
+  (@teunbrand, #5023).
+* All scales now expose the `aesthetics` parameter (@teunbrand, #5841)
+* Staged expressions are handled more gracefully if legends cannot resolve them 
+  (@teunbrand, #6264).
+* New `theme(legend.key.justification)` to control the alignment of legend keys 
+  (@teunbrand, #3669). 
+* Added `scale_{x/y}_time(date_breaks, date_minor_breaks, date_labels)` 
+  (@teunbrand, #4335).
 
 # ggplot2 3.5.1
 

R/axis-secondary.R

@@ -329,7 +329,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
     scale$train(range)
     scale
   },
-  make_title = function(title) {
-    title
+  make_title = function(...) {
+    ScaleContinuous$make_title(...)
   }
 )

R/bin.R

@@ -54,19 +54,12 @@ bin_breaks <- function(breaks, closed = c("right", "left")) {
 
 bin_breaks_width <- function(x_range, width = NULL, center = NULL,
                              boundary = NULL, closed = c("right", "left")) {
-  check_length(x_range, 2L)
 
-  # binwidth seems to be the argument name supplied to width. (stat-bin and stat-bindot)
-  check_number_decimal(width, min = 0, allow_infinite = FALSE, arg = "binwidth")
-
-  if (!is.null(boundary) && !is.null(center)) {
-    cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.")
-  } else if (is.null(boundary)) {
+  if (is.null(boundary)) {
     if (is.null(center)) {
       # If neither edge nor center given, compute both using tile layer's
       # algorithm. This puts min and max of data in outer half of their bins.
       boundary <- width / 2
-
     } else {
       # If center given but not boundary, compute boundary.
       boundary <- center - width / 2
@@ -75,9 +68,6 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
 
   # Find the left side of left-most bin: inputs could be Dates or POSIXct, so
   # coerce to numeric first.
-  x_range <- as.numeric(x_range)
-  width <- as.numeric(width)
-  boundary <- as.numeric(boundary)
   shift <- floor((x_range[1] - boundary) / width)
   origin <- boundary + shift * width
 
@@ -104,9 +94,7 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
 
 bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
                             boundary = NULL, closed = c("right", "left")) {
-  check_length(x_range, 2L)
 
-  check_number_whole(bins, min = 1)
   if (zero_range(x_range)) {
     # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
     width <- 0.1
@@ -128,6 +116,56 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
 
 # Compute bins ------------------------------------------------------------
 
+compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = NULL,
+                         center = NULL, boundary = NULL,
+                         closed = c("right", "left")) {
+
+  range <- if (is.scale(scale)) scale$dimension() else range(x)
+  check_length(range, 2L)
+
+  if (!is.null(breaks)) {
+    breaks <- allow_lambda(breaks)
+    if (is.function(breaks)) {
+      breaks <- breaks(x)
+    }
+    if (is.scale(scale) && !scale$is_discrete()) {
+      breaks <- scale$transform(breaks)
+    }
+    check_numeric(breaks)
+    bins <- bin_breaks(breaks, closed)
+    return(bins)
+  }
+
+  check_number_decimal(boundary, allow_infinite = FALSE, allow_null = TRUE)
+  check_number_decimal(center, allow_infinite = FALSE, allow_null = TRUE)
+  if (!is.null(boundary) && !is.null(center)) {
+    cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.")
+  }
+
+  if (!is.null(binwidth)) {
+    binwidth <- allow_lambda(binwidth)
+    if (is.function(binwidth)) {
+      binwidth <- binwidth(x)
+    }
+    check_number_decimal(binwidth, min = 0, allow_infinite = FALSE)
+    bins <- bin_breaks_width(
+      range, binwidth,
+      center = center, boundary = boundary, closed = closed
+    )
+    return(bins)
+  }
+
+  bins <- allow_lambda(bins)
+  if (is.function(bins)) {
+    bins <- bins(x)
+  }
+  check_number_whole(bins, min = 1, allow_infinite = FALSE)
+  bin_breaks_bins(
+    range, bins,
+    center = center, boundary = boundary, closed = closed
+  )
+}
+
 bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
   check_object(bins, is_bins, "a {.cls ggplot2_bins} object")
 
@@ -141,8 +179,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
     weight[is.na(weight)] <- 0
   }
 
-  bin_idx <- cut(x, bins$fuzzy, right = bins$right_closed,
-    include.lowest = TRUE)
+  bin_idx <- bin_cut(x, bins)
   bin_count <- as.numeric(tapply(weight, bin_idx, sum, na.rm = TRUE))
   bin_count[is.na(bin_count)] <- 0
 
@@ -170,6 +207,10 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
   bin_out(bin_count, bin_x, bin_widths)
 }
 
+bin_cut <- function(x, bins) {
+  cut(x, bins$fuzzy, right = bins$right_closed, include.lowest = TRUE)
+}
+
 bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
   xmin = x - width / 2, xmax = x + width / 2) {
   density <- count / width / sum(abs(count))
@@ -186,3 +227,41 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
     .size = length(count)
   )
 }
+
+bin_loc <- function(x, id) {
+  left <- x[-length(x)]
+  right <- x[-1]
+
+  list(
+    left = left[id],
+    right = right[id],
+    mid = ((left + right) / 2)[id],
+    length = diff(x)[id]
+  )
+}
+
+fix_bin_params = function(params, fun, version) {
+
+  if (!is.null(params$origin)) {
+    args <- paste0(fun, c("(origin)", "(boundary)"))
+    deprecate_warn0(version, args[1], args[2])
+    params$boudnary <- params$origin
+    params$origin <- NULL
+  }
+
+  if (!is.null(params$right)) {
+    args <- paste0(fun, c("(right)", "(closed)"))
+    deprecate_warn0(version, args[1], args[2])
+    params$closed <- if (isTRUE(params$right)) "right" else "left"
+    params$right <- NULL
+  }
+
+  if (is.null(params$breaks %||% params$binwidth %||% params$bins)) {
+    cli::cli_inform(
+      "{.fn {fun}} using {.code bins = 30}. Pick better value {.arg binwidth}."
+    )
+    params$bins <- 30
+  }
+
+  params
+}

R/coord-polar.R

@@ -84,7 +84,7 @@ CoordPolar <- ggproto("CoordPolar", Coord,
 
   is_free = function() TRUE,
 
-  distance = function(self, x, y, details) {
+  distance = function(self, x, y, details, boost = 0.75) {
     arc <- self$start + c(0, 2 * pi)
     dir <- self$direction
     if (self$theta == "x") {
@@ -94,8 +94,8 @@ CoordPolar <- ggproto("CoordPolar", Coord,
       r <- rescale(x, from = details$r.range)
       theta <- theta_rescale_no_clip(y, details$theta.range, arc, dir)
     }
-
-    dist_polar(r, theta)
+    # The ^boost boosts detailed munching when r is small
+    dist_polar(r^boost, theta)
   },
 
   backtransform_range = function(self, panel_params) {

R/coord-radial.R

@@ -120,7 +120,7 @@ CoordRadial <- ggproto("CoordRadial", Coord,
 
   is_free = function() TRUE,
 
-  distance = function(self, x, y, details) {
+  distance = function(self, x, y, details, boost = 0.75) {
     arc <- details$arc %||% c(0, 2 * pi)
     if (self$theta == "x") {
       r <- rescale(y, from = details$r.range, to = self$inner_radius / 0.4)
@@ -129,8 +129,8 @@ CoordRadial <- ggproto("CoordRadial", Coord,
       r <- rescale(x, from = details$r.range, to = self$inner_radius / 0.4)
       theta <- theta_rescale_no_clip(y, details$theta.range, arc)
     }
-
-    dist_polar(r, theta)
+    # The ^boost boosts detailed munching when r is small
+    dist_polar(r^boost, theta)
   },
 
   backtransform_range = function(self, panel_params) {
@@ -250,11 +250,18 @@ CoordRadial <- ggproto("CoordRadial", Coord,
     names(gdefs) <- aesthetics
 
     # Train theta guide
-    for (t in intersect(c("theta", "theta.sec"), aesthetics[!empty])) {
-      gdefs[[t]] <- guides[[t]]$train(gdefs[[t]], panel_params[[t]])
-      gdefs[[t]] <- guides[[t]]$transform(gdefs[[t]], self, panel_params)
-      gdefs[[t]] <- guides[[t]]$get_layer_key(gdefs[[t]], layers)
-    }
+    t <- intersect(c("theta", "theta.sec"), aesthetics[!empty])
+    gdefs[t] <- Map(
+      function(guide, guide_param, scale) {
+        guide_param$theme_suffix <- "theta"
+        guide_param <- guide$train(guide_param, scale)
+        guide_param <- guide$transform(guide_param, self, panel_params)
+        guide_param <- guide$get_layer_key(guide_param, layers)
+      },
+      guide = guides[t],
+      guide_param = gdefs[t],
+      scale = panel_params[t]
+    )
 
     if (!isFALSE(self$r_axis_inside)) {
       # For radial axis, we need to pretend that rotation starts at 0 and
@@ -269,17 +276,18 @@ CoordRadial <- ggproto("CoordRadial", Coord,
     temp <- modify_list(panel_params, mod)
 
     # Train radial guide
-    for (r in intersect(c("r", "r.sec"), aesthetics[!empty])) {
-      gdefs[[r]] <- guides[[r]]$train(gdefs[[r]], panel_params[[r]])
-      gdefs[[r]] <- guides[[r]]$transform(gdefs[[r]], self, temp) # Use temp
-      gdefs[[r]] <- guides[[r]]$get_layer_key(gdefs[[r]], layers)
-    }
-
-    # Set theme suffixes
-    gdefs$theta$theme_suffix     <- "theta"
-    gdefs$theta.sec$theme_suffix <- "theta"
-    gdefs$r$theme_suffix         <- "r"
-    gdefs$r.sec$theme_suffix     <- "r"
+    r <- intersect(c("r", "r.sec"), aesthetics[!empty])
+    gdefs[r] <- Map(
+      function(guide, guide_param, scale) {
+        guide_param$theme_suffix <- "r"
+        guide_param <- guide$train(guide_param, scale)
+        guide_param <- guide$transform(guide_param, self, temp)
+        guide_param <- guide$get_layer_key(guide_param, layers)
+      },
+      guide = guides[r],
+      guide_param = gdefs[r],
+      scale = panel_params[r]
+    )
 
     panel_params$guides$update_params(gdefs)
     panel_params

R/coord-sf.R

@@ -721,6 +721,14 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic,
     accept_start <- graticule[[orth_start]] < thres
     accept_end   <- graticule[[orth_end]]   < thres
   }
+  if (!any(accept_start | accept_end)) {
+    eps <- sqrt(.Machine$double.xmin)
+    subtract <- switch(position, top = , bottom = 90, 0)
+    straight <-
+      abs(graticule$angle_start - subtract) < eps &
+      abs(graticule$angle_end   - subtract) < eps
+    accept_start <- straight
+  }
 
   # Parsing the information of the `label_axes` argument:
   # should we label the meridians ("E") or parallels ("N")?

R/facet-grid-.R

@@ -309,7 +309,9 @@ FacetGrid <- ggproto("FacetGrid", Facet,
         params$margins
       )
       # Apply recycling on original data to fit margins
-      data <- vec_slice(data, facet_vals$.index)
+      # We're using base subsetting here because `data` might have a superclass
+      # that isn't handled well by vctrs::vec_slice
+      data <- data[facet_vals$.index, , drop = FALSE]
       facet_vals$.index <- NULL
     }