Merge branch 'main' into rename_coord_transform

DESCRIPTION

@@ -39,11 +39,9 @@ Imports:
  isoband,
  lifecycle (> 1.0.1),
  MASS,
- mgcv,
  rlang (>= 1.1.0),
  scales (>= 1.3.0),
  stats,
- tibble,
  vctrs (>= 0.6.0),
  withr (>= 2.5.0)
 Suggests:
@@ -55,6 +53,7 @@ Suggests:
  knitr,
  mapproj,
  maps,
+ mgcv,
  multcomp,
  munsell,
  nlme,
@@ -67,6 +66,7 @@ Suggests:
  sf (>= 0.7-3),
  svglite (>= 2.1.2),
  testthat (>= 3.1.5),
+ tibble,
  vdiffr (>= 1.0.6),
  xml2
 Enhances: 

NAMESPACE

@@ -515,6 +515,8 @@ export(remove_missing)
 export(render_axes)
 export(render_strips)
 export(replace_theme)
+export(reset_geom_defaults)
+export(reset_stat_defaults)
 export(reset_theme_settings)
 export(resolution)
 export(scale_alpha)
@@ -735,7 +737,6 @@ importFrom(grid,unit)
 importFrom(lifecycle,deprecated)
 importFrom(scales,alpha)
 importFrom(stats,setNames)
-importFrom(tibble,tibble)
 importFrom(utils,.DollarNames)
 importFrom(utils,head)
 importFrom(utils,tail)

R/annotation-logticks.R

@@ -165,7 +165,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
 
  names(xticks)[names(xticks) == "value"] <- x_name # Rename to 'x' for coordinates$transform
  xticks <- coord$transform(xticks, panel_params)
- xticks = xticks[xticks$x <= 1 & xticks$x >= 0,]
+ xticks <- xticks[xticks$x <= 1 & xticks$x >= 0,]
 
  if (outside)
  xticks$end = -xticks$end
@@ -203,7 +203,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
 
  names(yticks)[names(yticks) == "value"] <- y_name # Rename to 'y' for coordinates$transform
  yticks <- coord$transform(yticks, panel_params)
- yticks = yticks[yticks$y <= 1 & yticks$y >= 0,]
+ yticks <- yticks[yticks$y <= 1 & yticks$y >= 0,]
 
  if (outside)
  yticks$end = -yticks$end
@@ -238,7 +238,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
 # - start: on the other axis, start position of the line (usually 0)
 # - end: on the other axis, end position of the line (for example, .1, .2, or .3)
 calc_logticks <- function(base = 10, ticks_per_base = base - 1,
- minpow = 0, maxpow = minpow + 1, start = 0, shortend = .1, midend = .2, longend = .3) {
+ minpow = 0, maxpow = minpow + 1, start = 0, shortend = 0.1, midend = 0.2, longend = 0.3) {
 
  # Number of blocks of tick marks
  reps <- maxpow - minpow

R/axis-secondary.R

@@ -188,7 +188,13 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
  if (scale$is_discrete()) {
  self$breaks <- scale$get_breaks()
  } else {
- self$breaks <- scale$get_transformation()$breaks
+ breaks <- scale$get_transformation()$breaks
+ n_breaks <- scale$n.breaks
+ if (!is.null(n_breaks) && "n" %in% fn_fmls_names(breaks)) {
+ self$breaks <- function(x) breaks(x, n = n_breaks)
+ } else {
+ self$breaks <- breaks
+ }
  }
  }
  if (is.derived(self$labels)) self$labels <- scale$labels

R/bin.R

@@ -165,7 +165,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
  }
 
  # Add row for missings
- if (any(is.na(bins))) {
+ if (anyNA(bins)) {
  bin_count <- c(bin_count, sum(is.na(bins)))
  bin_widths <- c(bin_widths, NA)
  bin_x <- c(bin_x, NA)

R/compat-plyr.R

@@ -54,13 +54,13 @@ rename <- function(x, replace) {
 id_var <- function(x, drop = FALSE) {
  if (length(x) == 0) {
  id <- integer()
- n = 0L
+ n <- 0L
  } else if (!is.null(attr(x, "n")) && !drop) {
  return(x)
  } else if (is.factor(x) && !drop) {
  x <- addNA(x, ifany = TRUE)
  id <- as.integer(x)
- n <- length(levels(x))
+ n <- nlevels(x)
  } else {
  levels <- sort(unique0(x), na.last = TRUE)
  id <- match(x, levels)

R/coord-.R

@@ -208,6 +208,20 @@ Coord <- ggproto("Coord",
  # used as a fudge for CoordFlip and CoordPolar
  modify_scales = function(scales_x, scales_y) {
  invisible()
+ },
+
+ draw_panel = function(self, panel, params, theme) {
+ fg <- self$render_fg(params, theme)
+ bg <- self$render_bg(params, theme)
+ if (isTRUE(theme$panel.ontop)) {
+ panel <- list2(!!!panel, bg, fg)
+ } else {
+ panel <- list2(bg, !!!panel, fg)
+ }
+ gTree(
+ children = inject(gList(!!!panel)),
+ vp = viewport(clip = self$clip)
+ )
  }
 )
 

R/coord-polar.R

@@ -137,7 +137,7 @@ CoordPolar <- ggproto("CoordPolar", Coord,
  ret[[n]]$sec.labels <- out$sec.labels
  }
 
- details = list(
+ details <- list(
  x.range = ret$x$range, y.range = ret$y$range,
  x.major = ret$x$major, y.major = ret$y$major,
  x.minor = ret$x$minor, y.minor = ret$y$minor,

R/coord-radial.R

@@ -409,6 +409,27 @@ CoordRadial <- ggproto("CoordRadial", Coord,
  )
  },
 
+
+ draw_panel = function(self, panel, params, theme) {
+ clip_support <- check_device("clippingPaths", "test", maybe = TRUE)
+ if (self$clip == "on" && !isFALSE(clip_support)) {
+ clip_path <- data_frame0(
+ x = c(Inf, Inf, -Inf, -Inf),
+ y = c(Inf, -Inf, -Inf, Inf)
+ )
+ clip_path <- coord_munch(self, clip_path, params, is_closed = TRUE)
+ clip_path <- polygonGrob(clip_path$x, clip_path$y)
+ # Note that clipping path is applied to panel without coord
+ # foreground/background (added in parent method).
+ # These may contain decorations that needn't be clipped
+ panel <- list(gTree(
+ children = inject(gList(!!!panel)),
+ vp = viewport(clip = clip_path)
+ ))
+ }
+ ggproto_parent(Coord, self)$draw_panel(panel, params, theme)
+ },
+
  labels = function(self, labels, panel_params) {
  # `Layout$resolve_label()` doesn't know to look for theta/r/r.sec guides,
  # so we'll handle title propagation here.

R/coord-sf.R

@@ -416,7 +416,7 @@ sf_rescale01 <- function(x, x_range, y_range) {
 
 # different limits methods
 calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) {
- if (any(!is.finite(c(xlim, ylim))) && method != "geometry_bbox") {
+ if (!all(is.finite(c(xlim, ylim))) && method != "geometry_bbox") {
  cli::cli_abort(c(
  "Scale limits cannot be mapped onto spatial coordinates in {.fn coord_sf}.",
  "i" = "Consider setting {.code lims_method = \"geometry_bbox\"} or {.code default_crs = NULL}."
@@ -585,7 +585,7 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE,
 }
 
 parse_axes_labeling <- function(x) {
- labs = unlist(strsplit(x, ""))
+ labs <- unlist(strsplit(x, ""))
  list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4])
 }
 

R/facet-.R

@@ -139,22 +139,25 @@ Facet <- ggproto("Facet", NULL,
  free <- params$free %||% list(x = FALSE, y = FALSE)
  space <- params$space_free %||% list(x = FALSE, y = FALSE)
 
- if ((free$x || free$y) && !coord$is_free()) {
- cli::cli_abort(
- "{.fn {snake_class(self)}} can't use free scales with \\
- {.fn {snake_class(coord)}}."
- )
- }
-
  aspect_ratio <- theme$aspect.ratio
  if (!is.null(aspect_ratio) && (space$x || space$y)) {
  cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio.")
  }
 
+ if (!coord$is_free()) {
+ if (space$x && space$y) {
+ aspect_ratio <- aspect_ratio %||% coord$ratio
+ } else if (free$x || free$y) {
+ cli::cli_abort(
+ "{.fn {snake_class(self)}} can't use free scales with \\
+ {.fn {snake_class(coord)}}."
+ )
+ }
+ }
+
  table <- self$init_gtable(
  panels, layout, theme, ranges, params,
- aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]]),
- clip = coord$clip
+ aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]])
  )
 
  table <- self$attach_axes(table, layout, ranges, coord, theme, params)
@@ -198,7 +201,7 @@ Facet <- ggproto("Facet", NULL,
  data
  },
  init_gtable = function(panels, layout, theme, ranges, params,
- aspect_ratio = NULL, clip = "on") {
+ aspect_ratio = NULL) {
 
  # Initialise matrix of panels
  dim <- c(max(layout$ROW), max(layout$COL))
@@ -220,15 +223,15 @@ Facet <- ggproto("Facet", NULL,
  if (space$y) {
  idx <- layout$PANEL[layout$COL == 1]
  heights <- vapply(idx, function(i) diff(ranges[[i]]$y.range), numeric(1))
- heights <- unit(heights, "null")
+ heights <- unit(heights * abs(aspect_ratio %||% 1), "null")
  }
 
  # Build gtable
  table <- gtable_matrix(
  "layout", table,
  widths = widths, heights = heights,
  respect = !is.null(aspect_ratio),
- clip = clip, z = matrix(1, dim[1], dim[2])
+ clip = "off", z = matrix(1, dim[1], dim[2])
  )
 
  # Set panel names
@@ -561,7 +564,7 @@ is_facets <- function(x) {
 # but that seems like a reasonable tradeoff.
 eval_facets <- function(facets, data, possible_columns = NULL) {
  vars <- compact(lapply(facets, eval_facet, data, possible_columns = possible_columns))
- data_frame0(tibble::as_tibble(vars))
+ data_frame0(!!!vars)
 }
 eval_facet <- function(facet, data, possible_columns = NULL) {
  # Treat the case when `facet` is a quosure of a symbol specifically
@@ -678,7 +681,7 @@ find_panel <- function(table) {
 }
 #' @rdname find_panel
 #' @export
-panel_cols = function(table) {
+panel_cols <- function(table) {
  panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
  unique0(panels[, c('l', 'r')])
 }

R/facet-grid-.R

@@ -319,8 +319,8 @@ FacetGrid <- ggproto("FacetGrid", Facet,
  if (length(missing_facets) > 0) {
  to_add <- unique0(layout[missing_facets])
 
- data_rep <- rep.int(1:nrow(data), nrow(to_add))
- facet_rep <- rep(1:nrow(to_add), each = nrow(data))
+ data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add))
+ facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data))
 
  data <- unrowname(data[data_rep, , drop = FALSE])
  facet_vals <- unrowname(vec_cbind(
@@ -404,13 +404,13 @@ FacetGrid <- ggproto("FacetGrid", Facet,
  space <- if (!inside_x & table_has_grob(table, "axis-b")) padding
  table <- seam_table(
  table, strips$x$bottom, side = "bottom", name = "strip-b",
- shift = shift_x, z = 2, clip = "on", spacing = space
+ shift = shift_x, z = 2, clip = "off", spacing = space
  )
  } else {
  space <- if (!inside_x & table_has_grob(table, "axis-t")) padding
  table <- seam_table(
  table, strips$x$top, side = "top", name = "strip-t",
- shift = shift_x, z = 2, clip = "on", spacing = space
+ shift = shift_x, z = 2, clip = "off", spacing = space
  )
  }
 
@@ -422,13 +422,13 @@ FacetGrid <- ggproto("FacetGrid", Facet,
  space <- if (!inside_y & table_has_grob(table, "axis-l")) padding
  table <- seam_table(
  table, strips$y$left, side = "left", name = "strip-l",
- shift = shift_y, z = 2, clip = "on", spacing = space
+ shift = shift_y, z = 2, clip = "off", spacing = space
  )
  } else {
  space <- if (!inside_y & table_has_grob(table, "axis-r")) padding
  table <- seam_table(
  table, strips$y$right, side = "right", name = "strip-r",
- shift = shift_y, z = 2, clip = "on", spacing = space
+ shift = shift_y, z = 2, clip = "off", spacing = space
  )
  }
  table

R/facet-null.R

@@ -63,11 +63,10 @@ FacetNull <- ggproto("FacetNull", Facet,
  grob_widths <- unit.c(grobWidth(axis_v$left), unit(1, "null"), grobWidth(axis_v$right))
  grob_heights <- unit.c(grobHeight(axis_h$top), unit(abs(aspect_ratio), "null"), grobHeight(axis_h$bottom))
  grob_names <- c("spacer", "axis-l", "spacer", "axis-t", "panel", "axis-b", "spacer", "axis-r", "spacer")
- grob_clip <- c("off", "off", "off", "off", coord$clip, "off", "off", "off", "off")
 
  layout <- gtable_matrix("layout", all,
  widths = grob_widths, heights = grob_heights,
- respect = respect, clip = grob_clip,
+ respect = respect, clip = "off",
  z = z_matrix
  )
  layout$layout$name <- grob_names