diff --git a/R/guide-axis.R b/R/guide-axis.R index 6f15c1f23e..a749abae6f 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -6,6 +6,14 @@ #' [scale_(x|y)_discrete()][scale_x_discrete()]. #' #' @inheritParams guide_legend +#' @param breaks,labels,minor.breaks Either `derive()` to indicate that the +#' breaks, labels or minor breaks should be taken from the scale, or valid +#' input to the scale's synonymous arguments to override the scale's settings. +#' By default, `breaks` and `labels` are derived from the scale, whereas +#' `minor.breaks` are omitted. +#' @param trans A `function`, `formula` or `` object that can perform +#' the transformation for secondary axes. Note that discrete scales cannot +#' be transformed. The default, `NULL`, will perform no transformation. #' @param check.overlap silently remove overlapping labels, #' (recursively) prioritizing the first, last, and middle labels. #' @param angle Compared to setting the angle in [theme()] / [element_text()], @@ -14,8 +22,6 @@ #' @param n.dodge The number of rows (for vertical axes) or columns (for #' horizontal axes) that should be used to render the labels. This is #' useful for displaying labels that would otherwise overlap. -#' @param minor.ticks Whether to draw the minor ticks (`TRUE`) or not draw -#' minor ticks (`FALSE`, default). #' @param cap A `character` to cut the axis line back to the last breaks. Can #' be `"none"` (default) to draw the axis line along the whole panel, or #' `"upper"` and `"lower"` to draw the axis to the upper or lower break, or @@ -43,24 +49,44 @@ #' #' # can also be used to add a duplicate guide #' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) -guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, - n.dodge = 1, minor.ticks = FALSE, cap = "none", - order = 0, position = waiver()) { - check_bool(minor.ticks) +guide_axis <- function( + title = waiver(), + breaks = derive(), + labels = derive(), + minor.breaks = NULL, + trans = NULL, + check.overlap = FALSE, + angle = NULL, + n.dodge = 1, + cap = "none", + order = 0, + position = waiver() +) { if (is.logical(cap)) { check_bool(cap) cap <- if (cap) "both" else "none" } cap <- arg_match0(cap, c("none", "both", "upper", "lower")) + if (is.logical(minor.breaks)) { + check_bool(minor.breaks) + minor.breaks <- if (minor.breaks) derive() else NULL + } + + check_breaks_labels(breaks, labels) new_guide( title = title, + # Override settings + breaks = breaks, + labels = labels, + minor_breaks = minor.breaks, + trans = allow_lambda(trans), + # customisations check.overlap = check.overlap, angle = angle, n.dodge = n.dodge, - minor.ticks = minor.ticks, cap = cap, # parameter @@ -83,13 +109,17 @@ GuideAxis <- ggproto( params = list( title = waiver(), + breaks = derive(), + labels = derive(), + minor_breaks = NULL, + trans = NULL, name = "axis", hash = character(), position = waiver(), + minor_ticks = FALSE, direction = NULL, angle = NULL, n.dodge = 1, - minor.ticks = FALSE, cap = "none", order = 0, check.overlap = FALSE @@ -108,33 +138,115 @@ GuideAxis <- ggproto( minor_length = "axis.minor.ticks.length" ), - extract_key = function(scale, aesthetic, minor.ticks, ...) { - major <- Guide$extract_key(scale, aesthetic, ...) - if (!minor.ticks) { - return(major) + extract_key = function(scale, aesthetic, + breaks, minor_breaks, labels, + trans, ...) { + + # Retrieve limits information + limits <- scale$get_limits() + range <- scale$continuous_range + + # Resolve transformations + scale_trans <- scale$scale$trans %||% identity_trans() + trans <- function_as_trans(trans, range, scale_trans) + + if (!is.null(trans) || is.custom(breaks) || is.custom(labels) || + is.custom(minor_breaks)) { + if (is.derived(breaks)) { + breaks <- scale$scale$breaks + if (is.waive(breaks) && !scale$is_discrete()) { + breaks <- scale_trans$breaks + } + } + if (is.derived(minor_breaks)) { + minor_breaks <- scale$scale$minor_breaks + } + limits <- scale_trans$inverse(limits) + # If anything needs to be computed that is not included in the viewscale, + # a temporary scale computes the necessary components + temp_scale <- ggproto( + NULL, scale$scale, + trans = trans %||% scale_trans, + limits = limits, + breaks = breaks, + minor_breaks = minor_breaks, + labels = if (is.derived(labels)) scale$scale$labels else labels + ) + if (scale$is_discrete()) { + # Allow plain numeric breaks for discrete scales + if (!is.numeric(breaks)) { + breaks <- temp_scale$get_breaks(limits) + } + # Allow minor breaks to be a function + if (is.function(minor_breaks)) { + minor_breaks <- minor_breaks(limits) + } + } else { + breaks <- temp_scale$get_breaks(limits) + minor_breaks <- temp_scale$get_breaks_minor(b = breaks, limits = limits) + } + } else { + temp_scale <- scale + if (!is.null(breaks)) { + breaks <- scale$get_breaks() + } + if (!is.null(minor_breaks)) { + minor_breaks <- scale$get_breaks_minor() + } } - minor_breaks <- scale$get_breaks_minor() - minor_breaks <- setdiff(minor_breaks, major$.value) - minor_breaks <- minor_breaks[is.finite(minor_breaks)] + if (is.null(trans)) { + map <- function(x) scale$map(x) + } else { + map <- function(x) scale$map(scale_trans$transform(x)) + } - if (length(minor_breaks) < 1) { - return(major) + if (!is.null(breaks)) { + if (!is.null(labels)) { + labels <- temp_scale$get_labels(breaks) + } + if (is.expression(labels)) { + labels <- as.list(labels) + } + key <- data_frame(!!aesthetic := map(breaks)) + key$.value <- breaks + key$.label <- labels + key <- vec_slice(key, is_finite(breaks)) + } else { + key <- data_frame0() } - minor <- data_frame0(!!aesthetic := scale$map(minor_breaks)) - minor$.value <- minor_breaks - minor$.type <- "minor" + if (!is.null(minor_breaks)) { - if (nrow(major) > 0) { - major$.type <- "major" - vec_rbind(major, minor) - } else { - minor + minor_breaks <- setdiff(minor_breaks, key$.value) + minor_breaks <- minor_breaks[is_finite(minor_breaks)] + + if (length(minor_breaks) < 1) { + return(key) + } + minor <- data_frame0(!!aesthetic := map(minor_breaks)) + + if (!scale$is_discrete()) { + minor$.value <- minor_breaks + } + + minor$.type <- "minor" + + if (nrow(key) > 0) { + key$.type <- "major" + key <- vec_rbind(key, minor) + } else { + return(minor) + } + } + if (nrow(key) == 0) { + return(NULL) } + key }, extract_params = function(scale, params, ...) { + params$minor_ticks <- any(params$key$.type == "minor") params$name <- paste0(params$name, "_", params$aesthetic) params }, @@ -305,7 +417,7 @@ GuideAxis <- ggproto( elements$major_length ) - if (!params$minor.ticks) { + if (!params$minor_ticks) { return(major) } @@ -359,7 +471,7 @@ GuideAxis <- ggproto( # Ticks major_cm <- convertUnit(elements$major_length, "cm", valueOnly = TRUE) range <- range(0, major_cm) - if (params$minor.ticks && !inherits(elements$minor, "element_blank")) { + if (params$minor_ticks && !inherits(elements$minor, "element_blank")) { minor_cm <- convertUnit(elements$minor_length, "cm", valueOnly = TRUE) range <- range(range, minor_cm) } @@ -592,3 +704,79 @@ axis_label_element_overrides <- function(axis_position, angle = NULL) { )) } } + +function_as_trans <- function(fun, limits, scale_trans, detail = 1000) { + if (is.null(fun)) { + return(NULL) + } + if (is.character(fun)) { + fun <- as.trans(fun) + } + if (!is.null(fun) && !is.numeric(limits)) { + cli::cli_warn("Cannot use axis transformation with discrete scales.") + return(NULL) + } + if (is.trans(fun)) { + if (fun$name == "identity") { + return(NULL) + } + return(fun) + } + if (is.null(fun) || is.null(limits) || zero_range(limits)) { + return(NULL) + } + if (!is.function(fun)) { + cli::cli_abort(paste0( + "The {.arg trans} argument must be a {.cls trans} object, ", + "a {.field formula} or {.field function}, not {obj_type_friendly(fun)}." + )) + } + + # Translation between primary and secondary ranges + limits_seq <- seq(limits[1], limits[2], length.out = detail) + origin_seq <- scale_trans$inverse(limits_seq) + trans_seq <- fun(origin_seq) + + if (length(trans_seq) != detail) { + cli::cli_abort( + "The {.arg trans} transformation must preserve the length of input." + ) + } + + finite <- is.finite(trans_seq) + origin_seq <- origin_seq[finite] + trans_seq <- trans_seq[finite] + + if (length(trans_seq) < detail / 100) { + cli::cli_abort(paste0( + "The {.arg trans} transformation could not transform the range ", + "{.field [{limits[1]}, {limits[2]}]}." + )) + } + + # Test for monotonicity + if (!is_unique(sign(diff(trans_seq)))) { + cli::cli_abort("The {.arg trans} transformation must be monotonic.") + } + + # Deduplicate in the expanded area of the range that can occur if the + # transformation is non-monotonic in the expansion. The split ensures + # that the middle duplicates are kept. + duplicates <- c( + !duplicated(trans_seq[seq_len(detail / 2)], fromLast = TRUE), + !duplicated(trans_seq[-seq_len(detail / 2)]) + ) + origin_seq <- origin_seq[duplicates] + trans_seq <- trans_seq[duplicates] + + trans_new( + "secondary_transformation", + transform = function(x) stats::approx(trans_seq, origin_seq, x)$y, + inverse = fun, + format = format_format(digits = 3), + domain = range(trans_seq) + ) +} + +is.custom <- function(x) !is.null(x) && !is.derived(x) + diff --git a/man/guide_axis.Rd b/man/guide_axis.Rd index d2efadff8e..cf90988581 100644 --- a/man/guide_axis.Rd +++ b/man/guide_axis.Rd @@ -6,10 +6,13 @@ \usage{ guide_axis( title = waiver(), + breaks = derive(), + labels = derive(), + minor.breaks = NULL, + trans = NULL, check.overlap = FALSE, angle = NULL, n.dodge = 1, - minor.ticks = FALSE, cap = "none", order = 0, position = waiver() @@ -21,6 +24,16 @@ If \code{NULL}, the title is not shown. By default (\code{\link[=waiver]{waiver()}}), the name of the scale object or the name specified in \code{\link[=labs]{labs()}} is used for the title.} +\item{breaks, labels, minor.breaks}{Either \code{derive()} to indicate that the +breaks, labels or minor breaks should be taken from the scale, or valid +input to the scale's synonymous arguments to override the scale's settings. +By default, \code{breaks} and \code{labels} are derived from the scale, whereas +\code{minor.breaks} are omitted.} + +\item{trans}{A \code{function}, \code{formula} or \verb{} object that can perform +the transformation for secondary axes. Note that discrete scales cannot +be transformed. The default, \code{NULL}, will perform no transformation.} + \item{check.overlap}{silently remove overlapping labels, (recursively) prioritizing the first, last, and middle labels.} @@ -32,9 +45,6 @@ you probably want.} horizontal axes) that should be used to render the labels. This is useful for displaying labels that would otherwise overlap.} -\item{minor.ticks}{Whether to draw the minor ticks (\code{TRUE}) or not draw -minor ticks (\code{FALSE}, default).} - \item{cap}{A \code{character} to cut the axis line back to the last breaks. Can be \code{"none"} (default) to draw the axis line along the whole panel, or \code{"upper"} and \code{"lower"} to draw the axis to the upper or lower break, or diff --git a/tests/testthat/_snaps/guides.md b/tests/testthat/_snaps/guides.md index 6fb109ecbd..c2c932f9d1 100644 --- a/tests/testthat/_snaps/guides.md +++ b/tests/testthat/_snaps/guides.md @@ -65,6 +65,26 @@ Breaks are not formatted correctly for a bin legend. i Use `(, ]` format to indicate bins. +# guide_axis(trans) works as expected. + + The `trans` argument must be a object, a formula or function, not the number 10. + +--- + + The `trans` transformation must be monotonic. + +--- + + The `trans` transformation could not transform the range [0, 10]. + +--- + + The `trans` transformation must preserve the length of input. + +--- + + `breaks` and `labels` must have the same length + # binning scales understand the different combinations of limits, breaks, labels, and show.limits `show.limits` is ignored when `labels` are given as a character vector. diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 6f7e241c92..5f03d2ea12 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -344,6 +344,95 @@ test_that("guide_colourbar warns about discrete scales", { }) +test_that("guide_axis(trans) works as expected.", { + + axis_key <- function(limits = c(0, 10), ..., scale = scale_x_continuous()) { + scale <- scale$clone() + scale$train(limits) + vs <- view_scale_primary(scale) + + guide <- guide_axis(...) + params <- guide$params + params$position <- "bottom" + guide$train(params, vs, "x")$key + } + + # Input checking + expect_snapshot_error(axis_key(trans = 10)) + expect_snapshot_error(axis_key(trans = sin)) + expect_snapshot_error(axis_key(trans = function(x) rep(Inf, length(x)))) + expect_snapshot_error(axis_key(trans = ~ 1)) + expect_snapshot_error(axis_key(breaks = 1:2, labels = "A")) + expect_silent(axis_key(trans = ~ sin(.x / 100))) + + fmt <- format_format(digits = 3) + + # Identity transformation + scale <- scale_x_continuous() + key <- axis_key(trans = ~., breaks = waiver(), scale = scale) + expect_equal(key$.label, fmt(seq(0, 10, by = 2.5))) + expect_equal(key$x, seq(0, 10, by = 2.5), tolerance = 1e-3) + + # Works with subtraction + key <- axis_key(trans = ~1-., breaks = waiver(), scale = scale) + expect_equal(key$.label, fmt(seq(-7.5, 0, by = 2.5))) + expect_equal(key$x, seq(8.5, 1, by = -2.5), tolerance = 1e-3) + + # Works with division + key <- axis_key(limits = c(1, 9), trans = ~ 10/., breaks = waiver(), scale = scale) + expect_equal(key$.label, fmt(10 / c(4, 2, 4/3, 1))) + expect_equal(key$x, c(4, 2, 4/3, 1), tolerance = 1e-3) + + # Works with log transformed scales + ## Identity transformation + key <- axis_key(trans = ~.x, scale = scale_x_log10()) + expect_equal(key$.label, fmt(10^c(0, 3, 6, 9))) + expect_equal(key$x, c(0, 3, 6, 9), tolerance = 1e-3) + + ## Proper transformation + key <- axis_key(trans = ~ . * 100, scale = scale_x_log10()) + expect_equal(key$.label, fmt(10^c(2, 5, 8, 11))) + expect_equal(key$x, c(0, 3, 6, 9), tolerance = 1e-3) + + # Custom breaks/labels + key <- axis_key( + trans = ~ . * 100, + breaks = 10^seq(2, 10, by = 2), + labels = math_format(format = log10), + scale = scale_x_log10() + ) + expect_equal(as.character(key$.label), paste0("10^", seq(2, 10, by = 2))) + expect_equal(key$x, seq(0, 8, by = 2)) + + # Plain discrete scale + key <- axis_key( + c("A", "B", "C"), + scale = scale_x_discrete() + ) + expect_equal(key$.label, c("A", "B", "C")) + expect_equal(unclass(key$x), c(1, 2, 3)) + + # Discrete custom breaks/labels + key <- axis_key( + c("A", "B", "C"), + breaks = c("A", "C"), + labels = c("X", "Y"), + scale = scale_x_discrete() + ) + expect_equal(key$.label, c("X", "Y")) + expect_equal(unclass(key$x), c(1, 3)) + + # Discrete numeric breaks + key <- axis_key( + c("A", "B", "C"), + breaks = c(1.5, 2.5), + labels = c("foo", "bar"), + scale = scale_x_discrete() + ) + expect_equal(key$.label, c("foo", "bar")) + expect_equal(unclass(key$x), c(1.5, 2.5)) +}) + # Visual tests ------------------------------------------------------------ test_that("axis guides are drawn correctly", { @@ -509,13 +598,13 @@ test_that("guide_axis() draws minor ticks correctly", { scale_x_continuous(labels = math_format()) + guides( # Test for styling and style inheritance - x = guide_axis(minor.ticks = TRUE), + x = guide_axis(minor.breaks = TRUE), # # Test for opposed lengths - y = guide_axis(minor.ticks = TRUE), + y = guide_axis(minor.breaks = TRUE), # # Test for flipped lenghts - x.sec = guide_axis(minor.ticks = TRUE), + x.sec = guide_axis(minor.breaks = TRUE), # # Test that minor.length doesn't influence spacing when no minor ticks are drawn - y.sec = guide_axis(minor.ticks = FALSE) + y.sec = guide_axis(minor.breaks = FALSE) ) expect_doppelganger("guides with minor ticks", p) })