Interpreter/wrapper for gpar() (#5867)

teunbrand · web-flow · commit 6c2e102065fc · 2024-04-29T10:34:23.000+02:00
* write wrapper

* use wrapper

* add news bullet

* remove defunct `len0_null()`
diff --git a/NAMESPACE b/NAMESPACE
@@ -422,6 +422,7 @@ export(get_alt_text)
 export(get_element_tree)
 export(get_guide_data)
 export(gg_dep)
+export(ggpar)
 export(ggplot)
 export(ggplotGrob)
 export(ggplot_add)
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* New helper function `ggpar()` to translate ggplot2's interpretation of 
+  graphical parameters to {grid}'s interpretation (@teunbrand, #5866).
+
 # ggplot2 3.5.1
 
 This is a small release focusing on fixing regressions from 3.5.0 and 
diff --git a/R/annotation-logticks.R b/R/annotation-logticks.R
@@ -175,14 +175,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
         ticks$x_b <- with(data, segmentsGrob(
           x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
           y0 = unit(xticks$start, "cm"), y1 = unit(xticks$end, "cm"),
-          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)
+          gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)
         ))
       }
       if (grepl("t", sides) && nrow(xticks) > 0) {
         ticks$x_t <- with(data, segmentsGrob(
           x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
           y0 = unit(1, "npc") - unit(xticks$start, "cm"), y1 = unit(1, "npc") - unit(xticks$end, "cm"),
-          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)
+          gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)
         ))
       }
     }
@@ -213,14 +213,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,
         ticks$y_l <- with(data, segmentsGrob(
           y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
           x0 = unit(yticks$start, "cm"), x1 = unit(yticks$end, "cm"),
-          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)
+          gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)
         ))
       }
       if (grepl("r", sides) && nrow(yticks) > 0) {
         ticks$y_r <- with(data, segmentsGrob(
           y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
           x0 = unit(1, "npc") - unit(yticks$start, "cm"), x1 = unit(1, "npc") - unit(yticks$end, "cm"),
-          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)
+          gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)
         ))
       }
     }
diff --git a/R/annotation-map.R b/R/annotation-map.R
@@ -95,9 +95,9 @@ GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap,
 
     polygonGrob(coords$x, coords$y, default.units = "native",
       id = grob_id,
-      gp = gpar(
+      gp = ggpar(
         col = data$colour, fill = alpha(data$fill, data$alpha),
-        lwd = data$linewidth * .pt)
+        lwd = data$linewidth)
       )
   },
 
diff --git a/R/coord-radial.R b/R/coord-radial.R
@@ -326,8 +326,8 @@ CoordRadial <- ggproto("CoordRadial", Coord,
         y = c(Inf, -Inf, -Inf,  Inf)
       )
       background <- coord_munch(self, background, panel_params, is_closed = TRUE)
-      bg_gp <- gpar(
-        lwd = len0_null(bg_element$linewidth * .pt),
+      bg_gp <- ggpar(
+        lwd = bg_element$linewidth,
         col = bg_element$colour, fill = bg_element$fill,
         lty = bg_element$linetype
       )
diff --git a/R/coord-sf.R b/R/coord-sf.R
@@ -326,9 +326,9 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     if (inherits(el, "element_blank")) {
       grobs <- list(element_render(theme, "panel.background"))
     } else {
-      line_gp <- gpar(
+      line_gp <- ggpar(
         col = el$colour,
-        lwd = len0_null(el$linewidth * .pt),
+        lwd = el$linewidth,
         lty = el$linetype
       )
       grobs <- c(
diff --git a/R/geom-curve.R b/R/geom-curve.R
@@ -57,10 +57,10 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment,
       default.units = "native",
       curvature = curvature, angle = angle, ncp = ncp,
       square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE,
-      gp = gpar(
+      gp = ggpar(
         col = alpha(trans$colour, trans$alpha),
         fill = alpha(arrow.fill, trans$alpha),
-        lwd = trans$linewidth * .pt,
+        lwd = trans$linewidth,
         lty = trans$linetype,
         lineend = lineend),
       arrow = arrow
diff --git a/R/geom-dotplot.R b/R/geom-dotplot.R
@@ -293,9 +293,9 @@ GeomDotplot <- ggproto("GeomDotplot", Geom,
       dotstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc,
                   stackposition = tdata$stackpos, stackdir = stackdir, stackratio = stackratio,
                   default.units = "npc",
-                  gp = gpar(col = alpha(tdata$colour, tdata$alpha),
+                  gp = ggpar(col = alpha(tdata$colour, tdata$alpha),
                             fill = fill_alpha(tdata$fill, tdata$alpha),
-                            lwd = tdata$stroke, lty = tdata$linetype,
+                            lwd = tdata$stroke / .pt, lty = tdata$linetype,
                             lineend = lineend))
     )
   },
diff --git a/R/geom-hex.R b/R/geom-hex.R
@@ -89,10 +89,10 @@ GeomHex <- ggproto("GeomHex", Geom,
 
     ggname("geom_hex", polygonGrob(
       coords$x, coords$y,
-      gp = gpar(
+      gp = ggpar(
         col = data$colour,
         fill = fill_alpha(data$fill, data$alpha),
-        lwd = data$linewidth * .pt,
+        lwd = data$linewidth,
         lty = data$linetype,
         lineend = lineend,
         linejoin = linejoin,
diff --git a/R/geom-label.R b/R/geom-label.R
@@ -90,17 +90,17 @@ GeomLabel <- ggproto("GeomLabel", Geom,
         padding = label.padding,
         r = label.r,
         angle = row$angle,
-        text.gp = gpar(
+        text.gp = ggpar(
           col = row$colour,
           fontsize = row$size * size.unit,
           fontfamily = row$family,
           fontface = row$fontface,
           lineheight = row$lineheight
         ),
-        rect.gp = gpar(
+        rect.gp = ggpar(
           col = if (isTRUE(all.equal(label.size, 0))) NA else row$colour,
           fill = fill_alpha(row$fill, row$alpha),
-          lwd = label.size * .pt
+          lwd = label.size
         )
       )
     })
@@ -115,7 +115,7 @@ GeomLabel <- ggproto("GeomLabel", Geom,
 labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"),
                       just = "center", padding = unit(0.25, "lines"), r = unit(0.1, "snpc"),
                       angle = NULL, default.units = "npc", name = NULL,
-                      text.gp = gpar(), rect.gp = gpar(fill = "white"), vp = NULL) {
+                      text.gp = gpar(), rect.gp = ggpar(fill = "white"), vp = NULL) {
 
   if (length(label) != 1) {
     cli::cli_abort("{.arg label} must be of length 1.")
@@ -130,7 +130,7 @@ labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"),
     vp <- viewport(
       angle = angle, x = x, y = y,
       width = unit(0, "cm"), height = unit(0, "cm"),
-      gp = gpar(fontsize = text.gp$fontsize)
+      gp = ggpar(fontsize = text.gp$fontsize)
     )
     x <- unit(rep(0.5, length(x)), "npc")
     y <- unit(rep(0.5, length(y)), "npc")
diff --git a/R/geom-map.R b/R/geom-map.R
@@ -144,10 +144,10 @@ GeomMap <- ggproto("GeomMap", GeomPolygon,
     data <- data[data_rows, , drop = FALSE]
 
     polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id,
-      gp = gpar(
+      gp = ggpar(
         col = data$colour,
         fill = fill_alpha(data$fill, data$alpha),
-        lwd = data$linewidth * .pt,
+        lwd = data$linewidth,
         lineend = lineend,
         linejoin = linejoin,
         linemitre = linemitre
diff --git a/R/geom-path.R b/R/geom-path.R
@@ -200,10 +200,10 @@ GeomPath <- ggproto("GeomPath", Geom,
       segmentsGrob(
         munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start],
         default.units = "native", arrow = arrow,
-        gp = gpar(
+        gp = ggpar(
           col = alpha(munched$colour, munched$alpha)[!end],
           fill = alpha(munched$colour, munched$alpha)[!end],
-          lwd = munched$linewidth[!end] * .pt,
+          lwd = munched$linewidth[!end],
           lty = munched$linetype[!end],
           lineend = lineend,
           linejoin = linejoin,
@@ -215,10 +215,10 @@ GeomPath <- ggproto("GeomPath", Geom,
       polylineGrob(
         munched$x, munched$y, id = id,
         default.units = "native", arrow = arrow,
-        gp = gpar(
+        gp = ggpar(
           col = alpha(munched$colour, munched$alpha)[start],
           fill = alpha(munched$colour, munched$alpha)[start],
-          lwd = munched$linewidth[start] * .pt,
+          lwd = munched$linewidth[start],
           lty = munched$linetype[start],
           lineend = lineend,
           linejoin = linejoin,
diff --git a/R/geom-point.R b/R/geom-point.R
@@ -145,18 +145,15 @@ GeomPoint <- ggproto("GeomPoint", Geom,
     }
 
     coords <- coord$transform(data, panel_params)
-    stroke_size <- coords$stroke
-    stroke_size[is.na(stroke_size)] <- 0
     ggname("geom_point",
       pointsGrob(
         coords$x, coords$y,
         pch = coords$shape,
-        gp = gpar(
+        gp = ggpar(
           col = alpha(coords$colour, coords$alpha),
           fill = fill_alpha(coords$fill, coords$alpha),
-          # Stroke is added around the outside of the point
-          fontsize = coords$size * .pt + stroke_size * .stroke / 2,
-          lwd = coords$stroke * .stroke / 2
+          pointsize = coords$size,
+          stroke = coords$stroke
         )
       )
     )
diff --git a/R/geom-polygon.R b/R/geom-polygon.R
@@ -130,10 +130,10 @@ GeomPolygon <- ggproto("GeomPolygon", Geom,
         polygonGrob(
           munched$x, munched$y, default.units = "native",
           id = munched$group,
-          gp = gpar(
+          gp = ggpar(
             col = first_rows$colour,
             fill = fill_alpha(first_rows$fill, first_rows$alpha),
-            lwd = first_rows$linewidth * .pt,
+            lwd = first_rows$linewidth,
             lty = first_rows$linetype,
             lineend = lineend,
             linejoin = linejoin,
@@ -161,10 +161,10 @@ GeomPolygon <- ggproto("GeomPolygon", Geom,
           munched$x, munched$y, default.units = "native",
           id = id, pathId = munched$group,
           rule = rule,
-          gp = gpar(
+          gp = ggpar(
             col = first_rows$colour,
             fill = fill_alpha(first_rows$fill, first_rows$alpha),
-            lwd = first_rows$linewidth * .pt,
+            lwd = first_rows$linewidth,
             lty = first_rows$linetype,
             lineend = lineend,
             linejoin = linejoin,
diff --git a/R/geom-rect.R b/R/geom-rect.R
@@ -57,10 +57,10 @@ GeomRect <- ggproto("GeomRect", Geom,
         height = coords$ymax - coords$ymin,
         default.units = "native",
         just = c("left", "top"),
-        gp = gpar(
+        gp = ggpar(
           col = coords$colour,
           fill = fill_alpha(coords$fill, coords$alpha),
-          lwd = coords$linewidth * .pt,
+          lwd = coords$linewidth,
           lty = coords$linetype,
           linejoin = linejoin,
           lineend = lineend
diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R
@@ -182,10 +182,10 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
     g_poly <- polygonGrob(
       munched_poly$x, munched_poly$y, id = munched_poly$id,
       default.units = "native",
-      gp = gpar(
+      gp = ggpar(
         fill = fill_alpha(aes$fill, aes$alpha),
         col = if (is_full_outline) aes$colour else NA,
-        lwd = if (is_full_outline) aes$linewidth * .pt else 0,
+        lwd = if (is_full_outline) aes$linewidth else 0,
         lty = if (is_full_outline) aes$linetype else 1,
         lineend = lineend,
         linejoin = linejoin,
@@ -213,9 +213,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
     g_lines <- polylineGrob(
       munched_lines$x, munched_lines$y, id = munched_lines$id,
       default.units = "native",
-      gp = gpar(
+      gp = ggpar(
         col = aes$colour,
-        lwd = aes$linewidth * .pt,
+        lwd = aes$linewidth,
         lty = aes$linetype,
         lineend = lineend,
         linejoin = linejoin,
diff --git a/R/geom-rug.R b/R/geom-rug.R
@@ -108,10 +108,10 @@ GeomRug <- ggproto("GeomRug", Geom,
       list(min = -1 * length, max = unit(1, "npc") + length)
     }
 
-    gp <- gpar(
+    gp <- ggpar(
       col = alpha(data$colour, data$alpha),
       lty = data$linetype,
-      lwd = data$linewidth * .pt,
+      lwd = data$linewidth,
       lineend = lineend
     )
     if (!is.null(data$x)) {
diff --git a/R/geom-segment.R b/R/geom-segment.R
@@ -122,10 +122,10 @@ GeomSegment <- ggproto("GeomSegment", Geom,
       arrow.fill <- arrow.fill %||% coord$colour
       return(segmentsGrob(coord$x, coord$y, coord$xend, coord$yend,
         default.units = "native",
-        gp = gpar(
+        gp = ggpar(
           col = alpha(coord$colour, coord$alpha),
           fill = alpha(arrow.fill, coord$alpha),
-          lwd = coord$linewidth * .pt,
+          lwd = coord$linewidth,
           lty = coord$linetype,
           lineend = lineend,
           linejoin = linejoin
diff --git a/R/geom-text.R b/R/geom-text.R
@@ -239,7 +239,7 @@ GeomText <- ggproto("GeomText", Geom,
       data$x, data$y, default.units = "native",
       hjust = data$hjust, vjust = data$vjust,
       rot = data$angle,
-      gp = gpar(
+      gp = ggpar(
         col = alpha(data$colour, data$alpha),
         fontsize = data$size * size.unit,
         fontfamily = data$family,
diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R
@@ -379,7 +379,7 @@ GuideColourbar <- ggproto(
         vjust = 0, hjust = 0,
         width = width, height = height,
         default.units = "npc",
-        gp = gpar(col = NA, fill = decor$colour)
+        gp = ggpar(col = NA, fill = decor$colour)
       )
     } else if (params$display == "gradient") {
       check_device("gradients", call = expr(guide_colourbar()))
@@ -394,7 +394,7 @@ GuideColourbar <- ggproto(
         vertical   = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc"))
       )
       gradient <- inject(linearGradient(decor$colour, value, !!!position))
-      grob <- rectGrob(gp = gpar(fill = gradient, col = NA))
+      grob <- rectGrob(gp = ggpar(fill = gradient, col = NA))
     }
 
     frame <- element_grob(elements$frame, fill = NA)
diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R
@@ -204,7 +204,7 @@ GuideColoursteps <- ggproto(
 
     size <- abs(decor$max - decor$min)
     just <- as.numeric(decor$min > decor$max)
-    gp   <- gpar(col = NA, fill = decor$colour)
+    gp   <- ggpar(col = NA, fill = decor$colour)
     if (params$direction == "vertical") {
       grob <- rectGrob(
         x = 0, y = decor$min,
diff --git a/R/legend-draw.R b/R/legend-draw.R
diff --git a/R/margins.R b/R/margins.R
diff --git a/R/theme-elements.R b/R/theme-elements.R
diff --git a/R/utilities-grid.R b/R/utilities-grid.R
diff --git a/man/ggpar.Rd b/man/ggpar.Rd

Original file line number	Diff line number	Diff line change
`@@ -175,14 +175,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,`
`175`	`175`	`ticks$x_b <- with(data, segmentsGrob(`
`176`	`176`	`x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),`
`177`	`177`	`y0 = unit(xticks$start, "cm"), y1 = unit(xticks$end, "cm"),`
`178`		`- gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)`
	`178`	`+ gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)`
`179`	`179`	`))`
`180`	`180`	`}`
`181`	`181`	`if (grepl("t", sides) && nrow(xticks) > 0) {`
`182`	`182`	`ticks$x_t <- with(data, segmentsGrob(`
`183`	`183`	`x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),`
`184`	`184`	`y0 = unit(1, "npc") - unit(xticks$start, "cm"), y1 = unit(1, "npc") - unit(xticks$end, "cm"),`
`185`		`- gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)`
	`185`	`+ gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)`
`186`	`186`	`))`
`187`	`187`	`}`
`188`	`188`	`}`
`@@ -213,14 +213,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom,`
`213`	`213`	`ticks$y_l <- with(data, segmentsGrob(`
`214`	`214`	`y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),`
`215`	`215`	`x0 = unit(yticks$start, "cm"), x1 = unit(yticks$end, "cm"),`
`216`		`- gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)`
	`216`	`+ gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)`
`217`	`217`	`))`
`218`	`218`	`}`
`219`	`219`	`if (grepl("r", sides) && nrow(yticks) > 0) {`
`220`	`220`	`ticks$y_r <- with(data, segmentsGrob(`
`221`	`221`	`y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),`
`222`	`222`	`x0 = unit(1, "npc") - unit(yticks$start, "cm"), x1 = unit(1, "npc") - unit(yticks$end, "cm"),`
`223`		`- gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt)`
	`223`	`+ gp = ggpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth)`
`224`	`224`	`))`
`225`	`225`	`}`
`226`	`226`	`}`
Original file line number	Diff line number	Diff line change
`@@ -326,8 +326,8 @@ CoordRadial <- ggproto("CoordRadial", Coord,`
`326`	`326`	`y = c(Inf, -Inf, -Inf, Inf)`
`327`	`327`	`)`
`328`	`328`	`background <- coord_munch(self, background, panel_params, is_closed = TRUE)`
`329`		`- bg_gp <- gpar(`
`330`		`- lwd = len0_null(bg_element$linewidth * .pt),`
	`329`	`+ bg_gp <- ggpar(`
	`330`	`+ lwd = bg_element$linewidth,`
`331`	`331`	`col = bg_element$colour, fill = bg_element$fill,`
`332`	`332`	`lty = bg_element$linetype`
`333`	`333`	`)`