Merge branch 'main' into legend_title_justification

NEWS.md

@@ -3,6 +3,14 @@
 * When legend titles are larger than the legend, title justification extends
   to the placement of keys and labels (#1903).
 
+* `draw_key_label()` now better reflects the appearance of labels.
+
+* The `minor_breaks` function argument in scales can now take a function with
+  two arguments: the scale's limits and the scale's major breaks (#3583).
+
+* (internal) The `ScaleContinuous$get_breaks()` method no longer censors
+  the computed breaks.
+
 * Plot scales now ignore `AsIs` objects constructed with `I(x)`, instead of
   invoking the identity scale. This allows these columns to co-exist with other
   layers that need a non-identity scale for the same aesthetic. Also, it makes

R/guide-.R

@@ -224,7 +224,8 @@ Guide <- ggproto(
     key$.label <- labels
 
     if (is.numeric(breaks)) {
-      vec_slice(key, is.finite(breaks))
+      range <- scale$continuous_range %||% scale$get_limits()
+      key <- vec_slice(key, is.finite(oob_censor_any(breaks, range)))
     } else {
       key
     }

R/guide-bins.R

@@ -267,6 +267,7 @@ GuideBins <- ggproto(
     }
 
     key$.label <- labels
+    key <- vec_slice(key, !is.na(oob_censor_any(key$.value)))
 
     return(key)
   },

R/guide-colorsteps.R

@@ -181,6 +181,8 @@ GuideColoursteps <- ggproto(
     params$key$.value <- rescale(params$key$.value, from = limits)
     params$decor$min  <- rescale(params$decor$min,  from = limits)
     params$decor$max  <- rescale(params$decor$max,  from = limits)
+    params$key <-
+      vec_slice(params$key, !is.na(oob_censor_any(params$key$.value)))
     params
   },
 

R/legend-draw.R

@@ -236,26 +236,68 @@ draw_key_smooth <- function(data, params, size) {
 #' @export
 #' @rdname draw_key
 draw_key_text <- function(data, params, size) {
-  if(is.null(data$label)) data$label <- "a"
-
-  textGrob(data$label, 0.5, 0.5,
-    rot = data$angle %||% 0,
+  data$label <- data$label %||% "a"
+  just <- rotate_just(data$angle, data$hjust, data$vjust)
+  grob <- titleGrob(
+    data$label,
+    x = unit(just$hjust, "npc"), y = unit(just$vjust, "npc"),
+    angle = data$angle,
+    hjust = data$hjust,
+    vjust = data$vjust,
     gp = gpar(
       col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
-      fontfamily = data$family %||% "",
-      fontface = data$fontface %||% 1,
-      fontsize = (data$size %||% 3.88) * .pt
-    )
+      fontfamily = data$family   %||% "",
+      fontface   = data$fontface %||% 1,
+      fontsize   = (data$size %||% 3.88) * .pt
+    ),
+    margin = margin(0.1, 0.1, 0.1, 0.1, unit = "lines"),
+    margin_x = TRUE, margin_y = TRUE
   )
+  attr(grob, "width")  <- convertWidth(grobWidth(grob),   "cm", valueOnly = TRUE)
+  attr(grob, "height") <- convertHeight(grobHeight(grob), "cm", valueOnly = TRUE)
+  grob
 }
 
 #' @export
 #' @rdname draw_key
 draw_key_label <- function(data, params, size) {
-  grobTree(
-    draw_key_rect(data, list()),
-    draw_key_text(data, list())
+  data$label <- data$label %||% "a"
+  just <- rotate_just(data$angle, data$hjust, data$vjust)
+  padding <- rep(params$label.padding, length.out = 4)
+  descent <- font_descent(
+    family = data$family %||% "",
+    face = data$fontface %||% 1,
+    size = data$size %||% 3.88
+  )
+  grob <- labelGrob(
+    data$label,
+    x = unit(just$hjust, "npc"),
+    y = unit(just$vjust, "npc") + descent,
+    angle = data$angle,
+    just = c(data$hjust, data$vjust),
+    padding = padding,
+    r = params$label.r,
+    text.gp = gpar(
+      col = data$colour %||% "black",
+      fontfamily = data$family   %||% "",
+      fontface   = data$fontface %||% 1,
+      fontsize   = (data$size %||% 3.88) * .pt
+    ),
+    rect.gp = gpar(
+      col = if (isTRUE(all.equal(params$label.size, 0))) NA else data$colour,
+      fill = alpha(data$fill %||% "white", data$alpha),
+      lwd = params$label.size * .pt
+    )
   )
+  angle  <- deg2rad(data$angle %||% 0)
+  text   <- grob$children[[2]]
+  width  <- convertWidth(grobWidth(text),   "cm", valueOnly = TRUE)
+  height <- convertHeight(grobHeight(text), "cm", valueOnly = TRUE)
+  x <- c(0, 0, width, width)
+  y <- c(0, height, height, 0)
+  attr(grob, "width")  <- diff(range(x * cos(angle) - y * sin(angle)))
+  attr(grob, "height") <- diff(range(x * sin(angle) + y * cos(angle)))
+  grob
 }
 
 #' @export

R/scale-.R

@@ -26,7 +26,9 @@
 #'     each major break)
 #'   - A numeric vector of positions
 #'   - A function that given the limits returns a vector of minor breaks. Also
-#'     accepts rlang [lambda][rlang::as_function()] function notation.
+#'     accepts rlang [lambda][rlang::as_function()] function notation. When
+#'     the function has two arguments, it will be given the limits and major
+#'     breaks.
 #' @param n.breaks An integer guiding the number of major breaks. The algorithm
 #'   may choose a slightly different number to ensure nice break labels. Will
 #'   only have an effect if `breaks = waiver()`. Use `NULL` to use the default
@@ -714,11 +716,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
     }
 
     # Breaks in data space need to be converted back to transformed space
-    breaks <- self$trans$transform(breaks)
-    # Any breaks outside the dimensions are flagged as missing
-    breaks <- censor(breaks, self$trans$transform(limits), only.finite = FALSE)
-
-    breaks
+    self$trans$transform(breaks)
   },
 
   get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) {
@@ -736,6 +734,9 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
         call = self$call
       )
     }
+    # major breaks are not censored, however;
+    # some transforms assume finite major breaks
+    b <- b[is.finite(b)]
 
     if (is.waive(self$minor_breaks)) {
       if (is.null(b)) {
@@ -744,8 +745,18 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
         breaks <- self$trans$minor_breaks(b, limits, n)
       }
     } else if (is.function(self$minor_breaks)) {
-      # Find breaks in data space, and convert to numeric
-      breaks <- self$minor_breaks(self$trans$inverse(limits))
+      # Using `fetch_ggproto` here to avoid auto-wrapping the user-supplied
+      # breaks function as a ggproto method.
+      break_fun <- fetch_ggproto(self, "minor_breaks")
+      arg_names <- fn_fmls_names(break_fun)
+
+      # Find breaks in data space
+      if (length(arg_names) == 1L) {
+        breaks <- break_fun(self$trans$inverse(limits))
+      } else {
+        breaks <- break_fun(self$trans$inverse(limits), self$trans$inverse(b))
+      }
+      # Convert breaks to numeric
       breaks <- self$trans$transform(breaks)
     } else {
       breaks <- self$trans$transform(self$minor_breaks)
@@ -819,14 +830,16 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
     # labels
     labels <- self$get_labels(major)
 
-    # drop oob breaks/labels by testing major == NA
-    if (!is.null(labels)) labels <- labels[!is.na(major)]
-    if (!is.null(major)) major <- major[!is.na(major)]
-
     # minor breaks
     minor <- self$get_breaks_minor(b = major, limits = range)
     if (!is.null(minor)) minor <- minor[!is.na(minor)]
 
+    major <- oob_censor_any(major, range)
+
+    # drop oob breaks/labels by testing major == NA
+    if (!is.null(labels)) labels <- labels[!is.na(major)]
+    if (!is.null(major)) major <- major[!is.na(major)]
+
     # rescale breaks [0, 1], which are used by coord/guide
     major_n <- rescale(major, from = range)
     minor_n <- rescale(minor, from = range)

R/scale-view.R

@@ -21,10 +21,12 @@ view_scale_primary <- function(scale, limits = scale$get_limits(),
     continuous_scale_sorted <- sort(continuous_range)
     breaks <- scale$get_breaks(continuous_scale_sorted)
     minor_breaks <- scale$get_breaks_minor(b = breaks, limits = continuous_scale_sorted)
+    breaks <- censor(breaks, continuous_scale_sorted, only.finite = FALSE)
   } else {
     breaks <- scale$get_breaks(limits)
     minor_breaks <- scale$get_breaks_minor(b = breaks, limits = limits)
   }
+  minor_breaks <- censor(minor_breaks, continuous_range, only.finite = FALSE)
 
   ggproto(NULL, ViewScale,
     scale = scale,
@@ -76,7 +78,7 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(),
       aesthetics = scale$aesthetics,
       name = scale$sec_name(),
       make_title = function(self, title) self$scale$make_sec_title(title),
-
+      continuous_range = sort(continuous_range),
       dimension = function(self) self$break_info$range,
       get_limits = function(self) self$break_info$range,
       get_breaks = function(self) self$break_info$major_source,

tests/testthat/test-scales-breaks-labels.R

@@ -1,7 +1,7 @@
 test_that("labels match breaks, even when outside limits", {
   sc <- scale_y_continuous(breaks = 1:4, labels = 1:4, limits = c(1, 3))
 
-  expect_equal(sc$get_breaks(), c(1:3, NA))
+  expect_equal(sc$get_breaks(), 1:4)
   expect_equal(sc$get_labels(), 1:4)
   expect_equal(sc$get_breaks_minor(), c(1, 1.5, 2, 2.5, 3))
 })
@@ -231,7 +231,7 @@ test_that("breaks can be specified by names of labels", {
 test_that("only finite or NA values for breaks for transformed scales (#871)", {
   sc <- scale_y_continuous(limits = c(0.01, 0.99), trans = "probit",
                            breaks = seq(0, 1, 0.2))
-  breaks <- sc$get_breaks()
+  breaks <- sc$break_info()$major_source
   expect_true(all(is.finite(breaks) | is.na(breaks)))
 })
 
@@ -257,7 +257,7 @@ test_that("equal length breaks and labels can be passed to ViewScales with limit
     limits = c(10, 30)
   )
 
-  expect_identical(test_scale$get_breaks(), c(NA, 20, NA))
+  expect_identical(test_scale$get_breaks(), c(0, 20, 40))
   expect_identical(test_scale$get_labels(), c(c("0", "20", "40")))
 
   test_view_scale <- view_scale_primary(test_scale)