check_linewidth() performs an update

teunbrand · teunbrand · commit a2c6cf1c230e · 2024-09-03T14:32:12.000+02:00
diff --git a/R/geom-.R b/R/geom-.R
@@ -271,7 +271,7 @@ check_aesthetics <- function(x, n) {
   ))
 }
 
-check_linewidth <- function(data, name) {
+update_linewidth <- function(data, name) {
   if (is.null(data$linewidth) && !is.null(data$size)) {
     deprecate_soft0("3.4.0", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic"))
     data$linewidth <- data$size
diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R
@@ -227,7 +227,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
                         outlier.size = NULL, outlier.stroke = 0.5,
                         outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5,
                         staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     # this may occur when using geom_boxplot(stat = "identity")
     if (nrow(data) != 1) {
diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R
@@ -55,7 +55,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "mitre", fatten = 2.5, width = NULL,
                         flipped_aes = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
 
     middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA)
diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R
@@ -60,7 +60,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom,
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         width = NULL, flipped_aes = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     x <- vec_interleave(data$xmin, data$xmax, NA, data$x,    data$x,    NA, data$xmin, data$xmax)
     y <- vec_interleave(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin)
diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R
@@ -74,7 +74,7 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom,
   },
 
   draw_panel = function(self, data, panel_params, coord, height = NULL, lineend = "butt") {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     GeomPath$draw_panel(data_frame0(
       x = vec_interleave(data$xmax, data$xmax, NA, data$xmax, data$xmin, NA, data$xmin, data$xmin),
       y = vec_interleave(data$ymin, data$ymax, NA, data$y,    data$y,    NA, data$ymin, data$ymax),
diff --git a/R/geom-hex.R b/R/geom-hex.R
@@ -58,7 +58,7 @@ geom_hex <- function(mapping = NULL, data = NULL,
 GeomHex <- ggproto("GeomHex", Geom,
   draw_group = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "mitre", linemitre = 10) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     if (empty(data)) {
       return(zeroGrob())
     }
diff --git a/R/geom-path.R b/R/geom-path.R
@@ -165,7 +165,7 @@ GeomPath <- ggproto("GeomPath", Geom,
   draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL,
                         lineend = "butt", linejoin = "round", linemitre = 10,
                         na.rm = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     if (!anyDuplicated(data$group)) {
       cli::cli_inform(c(
         "{.fn {snake_class(self)}}: Each group consists of only one observation.",
diff --git a/R/geom-polygon.R b/R/geom-polygon.R
@@ -109,7 +109,7 @@ geom_polygon <- function(mapping = NULL, data = NULL,
 GeomPolygon <- ggproto("GeomPolygon", Geom,
   draw_panel = function(self, data, panel_params, coord, rule = "evenodd",
                         lineend = "butt", linejoin = "round", linemitre = 10) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     n <- nrow(data)
     if (n == 1) return(zeroGrob())
 
diff --git a/R/geom-rect.R b/R/geom-rect.R
@@ -69,7 +69,7 @@ GeomRect <- ggproto("GeomRect", Geom,
   },
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     if (!coord$is_linear()) {
       aesthetics <- setdiff(
         names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax")
diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R
@@ -133,7 +133,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
   draw_group = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "round", linemitre = 10, na.rm = FALSE,
                         flipped_aes = FALSE, outline.type = "both") {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ]
     data <- data[order(data$group), ]
diff --git a/R/geom-rug.R b/R/geom-rug.R
@@ -90,7 +90,7 @@ GeomRug <- ggproto("GeomRug", Geom,
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         sides = "bl", outside = FALSE, length = unit(0.03, "npc")) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     check_inherits(length, "unit")
     rugs <- list()
     data <- coord$transform(data, panel_params)
diff --git a/R/geom-segment.R b/R/geom-segment.R
@@ -116,7 +116,7 @@ GeomSegment <- ggproto("GeomSegment", Geom,
                         lineend = "butt", linejoin = "round", na.rm = FALSE) {
     data$xend <- data$xend %||% data$x
     data$yend <- data$yend %||% data$y
-    data <- check_linewidth(data, snake_class(self))
+    data <- update_linewidth(data, snake_class(self))
     data <- remove_missing(data, na.rm = na.rm,
       c("x", "y", "xend", "yend", "linetype", "linewidth"),
       name = "geom_segment"
diff --git a/R/utilities-checks.R b/R/utilities-checks.R
@@ -69,6 +69,49 @@ check_inherits <- function(x,
   )
 }
 
+check_length <- function(x, length = integer(), ..., min = 0, max = Inf,
+                         arg = caller_arg(x), call = caller_env()) {
+  n <- length(x)
+  if (n %in% length) {
+    return(invisible(NULL))
+  }
+  if (length(length) > 0) {
+    type <- if (length(length) == 1) {
+      switch(as.character(length), "0" = "empty vector", "1" = "scalar", "vector")
+    } else {
+      "vector"
+    }
+    cli::cli_abort(
+      "{.arg {arg}} must be a {type} of length {.or {length}}, not length {n}.",
+      call = call, arg = arg
+    )
+  }
+
+  range <- pmax(range(min, max), 0)
+  if (n >= min & n <= max) {
+    return(invisible(NULL))
+  }
+  if (identical(range[1], range[2])) {
+    check_length(x, range[1], arg = arg, call = call)
+    return(invisible(NULL))
+  }
+
+  type <- if (range[2] == 1) "scalar" else "vector"
+  msg  <- "{.arg {arg}} must be a {type} with "
+
+  if (identical(range[2], Inf)) {
+    msg <- c(msg, "at least length {range[1]}")
+  }
+  if (identical(range[1], 0)) {
+    msg <- c(msg, "at most length {range[2]}")
+  }
+  if (length(msg) == 1) {
+    msg <- c(msg, "a length between {.and {range}}")
+  }
+  msg <- paste0(c(msg, ", not length {n}."), collapse = "")
+  cli::cli_abort(msg, call = call, arg = arg)
+}
+
 #' Check graphics device capabilities
 #'
 #' This function makes an attempt to estimate whether the graphics device is

Original file line number	Diff line number	Diff line change
`@@ -271,7 +271,7 @@ check_aesthetics <- function(x, n) {`
`271`	`271`	`))`
`272`	`272`	`}`
`273`	`273`
`274`		`-check_linewidth <- function(data, name) {`
	`274`	`+update_linewidth <- function(data, name) {`
`275`	`275`	`if (is.null(data$linewidth) && !is.null(data$size)) {`
`276`	`276`	deprecate_soft0("3.4.0", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic"))
`277`	`277`	`data$linewidth <- data$size`
Original file line number	Diff line number	Diff line change
`@@ -58,7 +58,7 @@ geom_hex <- function(mapping = NULL, data = NULL,`
`58`	`58`	`GeomHex <- ggproto("GeomHex", Geom,`
`59`	`59`	`draw_group = function(self, data, panel_params, coord, lineend = "butt",`
`60`	`60`	`linejoin = "mitre", linemitre = 10) {`
`61`		`- data <- check_linewidth(data, snake_class(self))`
	`61`	`+ data <- update_linewidth(data, snake_class(self))`
`62`	`62`	`if (empty(data)) {`
`63`	`63`	`return(zeroGrob())`
`64`	`64`	`}`