From a4396242520dcd1a02a9d7c84fa33e6e136c380c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 10:42:58 +0200 Subject: [PATCH 1/8] add `check_list_of()` --- R/utils-checks.R | 33 ++++++++++++++++++++++++++++++ tests/testthat/test-utils-checks.R | 16 +++++++++++++++ 2 files changed, 49 insertions(+) diff --git a/R/utils-checks.R b/R/utils-checks.R index 2f61912..399aa1e 100644 --- a/R/utils-checks.R +++ b/R/utils-checks.R @@ -26,6 +26,39 @@ check_list_names <- function(data, names, call = caller_env(), ), call = call) } +check_list_of <- function(x, class, allow_null = FALSE, + call = caller_env(), arg = caller_arg(x)) { + problems <- character() + if (!missing(x)) { + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + if (is.list(x)) { + fail <- !is_each(x, inherits, what = class) + if (!any(fail)) { + return(invisible(NULL)) + } + problems <- vapply(x[fail], obj_type_friendly, character(1)) + problems <- paste0(arg, "[[", which(fail), "]] is ", problems) + names(problems) <- rep("x", length(problems)) + if (length(problems) > 5) { + problems <- c(problems[1:5], "x" = "...and more mismatches.") + } + } + } + + class <- vapply(class, function(x) as_cli("{.cls {x}}"), character(1)) + end <- if (is.list(x)) "." else paste0(", not ", obj_type_friendly(x), ".") + + message <- sprintf( + "`%s` must be %s%s", + arg, as_cli("a {.cls list} object with {.or {class}} elements"), + end + ) + message <- c(message, problems) + abort(message, call = call, arg = arg) +} + check_grob <- function(x, allow_null = FALSE, call = caller_env(), arg = caller_arg(x)) { if (!missing(x)) { diff --git a/tests/testthat/test-utils-checks.R b/tests/testthat/test-utils-checks.R index 1bfd367..20f05fa 100644 --- a/tests/testthat/test-utils-checks.R +++ b/tests/testthat/test-utils-checks.R @@ -139,3 +139,19 @@ test_that("check_unique throws appropriate errors", { "Example duplicate" ) }) + +test_that("check_list_of throws appropriate errors", { + + nums <- c("integer", "double", "numeric") + expect_silent(check_list_of(list(1, 2, 3), nums)) + expect_silent(check_list_of(NULL, allow_null = TRUE)) + + expect_error( + check_list_of(list(1, "A", 3), nums), + "is the string \"A\"" + ) + expect_error( + check_list_of(12, nums), + "not the number 12" + ) +}) From 829ce653c90bfc230f275382282bf1988d6d3093 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 13:01:12 +0200 Subject: [PATCH 2/8] add customisation options to bracket primitive --- R/primitive-bracket.R | 98 ++++++++++++++++++++++++++++++---------- R/utils.R | 7 +++ man/primitive_bracket.Rd | 8 ++++ 3 files changed, 88 insertions(+), 25 deletions(-) diff --git a/R/primitive-bracket.R b/R/primitive-bracket.R index 4a25c1d..63881ae 100644 --- a/R/primitive-bracket.R +++ b/R/primitive-bracket.R @@ -20,6 +20,10 @@ #' @param pad_discrete A `` giving the amount ranges should be #' extended when given as a discrete variable. This is applied after #' the `drop_zero` setting. +#' @param levels_brackets A list of `` objects to customise how +#' brackets appear at every level. +#' @param levels_text A list of `` objects to customise how +#' text appears at every level. #' @inheritParams common_parameters #' #' @return A `` primitive guide that can be used inside other @@ -70,6 +74,8 @@ primitive_bracket <- function( oob = "squish", drop_zero = TRUE, pad_discrete = 0.4, + levels_brackets = NULL, + levels_text = NULL, theme = NULL, position = waiver() ) { @@ -78,6 +84,16 @@ primitive_bracket <- function( oob <- arg_match0(oob, c("squish", "censor", "none")) check_bool(drop_zero) check_number_decimal(pad_discrete, allow_infinite = FALSE) + check_list_of( + levels_brackets, + c("element_line", "element_blank", "NULL"), + allow_null = TRUE + ) + check_list_of( + levels_text, + c("element_text", "element_blank", "NULL"), + allow_null = TRUE + ) bracket <- resolve_bracket(bracket) new_guide( @@ -87,6 +103,8 @@ primitive_bracket <- function( drop_zero = drop_zero, pad_discrete = pad_discrete, bracket = bracket, + levels_brackets = levels_brackets, + levels_text = levels_text, theme = theme, position = position, available_aes = c("any", "x", "y", "r", "theta"), @@ -105,7 +123,8 @@ PrimitiveBracket <- ggproto( params = new_params( key = NULL, oob = "squish", drop_zero = TRUE, - pad_discrete = 0.4, angle = waiver(), bracket = cbind(c(0, 1), 0.5) + pad_discrete = 0.4, angle = waiver(), bracket = cbind(c(0, 1), 0.5), + levels_text = NULL, levels_brackets = NULL ), hashables = exprs(key, decor, bracket), @@ -174,13 +193,30 @@ PrimitiveBracket <- ggproto( }, build_bracket = function(key, decor, elements, params) { - levels <- unique(c(key$.level, decor$.level)) + levels <- unique(c(key$.level, decor$.level)) + nlevels <- length(levels) + position <- params$position + + # Recycle custom elements per level to appropriate length + bracket_levels <- rep0(params$levels_brackets, length.out = nlevels) + text_levels <- rep0(params$levels_text, length.out = nlevels) + # Justify labels along their ranges if (!is_blank(elements$text)) { + hjust <- elements$text$hjust vjust <- elements$text$vjust - if (is_theta(params$position)) { - add <- if (params$position == "theta.sec") pi else 0 + + # If we have custom elements, take justification from there + if (!is.null(text_levels)) { + hjust <- vapply(text_levels, function(x) x$hjust %||% hjust, numeric(1)) + hjust <- hjust[match(key$.level, levels)] + vjust <- vapply(text_levels, function(x) x$vjust %||% vjust, numeric(1)) + vjust <- vjust[match(key$.level, levels)] + } + + if (is_theta(position)) { + add <- if (position == "theta.sec") pi else 0 key$theta <- justify_range(key$theta, key$thetaend, hjust, theta = TRUE) key <- polar_xy(key, key$r, key$theta + add, params$bbox) } else if ("xend" %in% names(key)) { @@ -192,31 +228,39 @@ PrimitiveBracket <- ggproto( if (is_blank(elements$line) || is_empty(decor)) { decor <- vec_slice(decor, 0) - } else if (params$position %in% .trbl) { - offset <- decor$offset - offset <- if (params$position %in% .trbl[1:2]) 1 - offset else offset - decor$x <- switch(params$position, left = , right = offset, decor$x) - decor$y <- switch(params$position, top = , bottom = offset, decor$y) + } else if (position %in% .trbl) { + offset <- decor$offset + offset <- if (position %in% .trbl[1:2]) 1 - offset else offset + decor$x <- switch(position, left = , right = offset, decor$x) + decor$y <- switch(position, top = , bottom = offset, decor$y) decor$offset <- 0 } - elements$text <- angle_labels(elements$text, params$angle, params$position) - brackets <- list() - labels <- list() offset <- elements$offset angle <- params$angle %|W|% NULL + size <- elements$size + text <- angle_labels(elements$text, angle, params$position) + + brackets <- vector("list", nlevels) + labels <- vector("list", nlevels) + + for (i in seq_len(nlevels)) { - for (i in levels) { - dec <- vec_slice(decor, decor$.level == i) - bracket <- draw_bracket(dec, elements, params$position, offset) - offset <- offset + as.numeric(!is.zero(bracket)) * elements$size - brackets <- c(brackets, list(bracket)) - text <- draw_labels( - vec_slice(key, key$.level == i), - elements$text, angle = angle, offset = offset, params$position + # Render bracket + brackets[[i]] <- draw_bracket( + decor = vec_slice(decor, decor$.level == levels[[i]]), + element = combine_elements(bracket_levels[[i]], elements$line), + size = size, offset = offset, position = position ) - offset <- offset + get_size_attr(text) - labels <- c(labels, list(text)) + offset <- offset + get_size_attr(brackets[[i]]) + + # Render text + labels[[i]] <- draw_labels( + key = vec_slice(key, key$.level == levels[[i]]), + element = combine_elements(text_levels[[i]], text), + angle = angle, offset = offset, position = position + ) + offset <- offset + get_size_attr(labels[[i]]) } if (params$position %in% c("top", "left")) { brackets <- rev(brackets) @@ -268,7 +312,7 @@ PrimitiveBracket <- ggproto( # Helpers ----------------------------------------------------------------- -draw_bracket <- function(decor, elements, position, offset) { +draw_bracket <- function(decor, element, size, offset, position) { if (nrow(decor) < 2) { return(zeroGrob()) } @@ -276,12 +320,16 @@ draw_bracket <- function(decor, elements, position, offset) { y <- unit(decor$y, "npc") if (is_theta(position)) { - offset <- (1 - decor$offset) * elements$size + offset + offset <- (1 - decor$offset) * size + offset x <- x + unit(sin(decor$theta) * offset, "cm") y <- y + unit(cos(decor$theta) * offset, "cm") } id <- vec_unrep(decor$group)$times - element_grob(elements$line, x = x, y = y, id.lengths = id) + grob <- element_grob(element, x = x, y = y, id.lengths = id) + if (!is_blank(element)) { + attr(grob, "size") <- size + } + grob } diff --git a/R/utils.R b/R/utils.R index 0378845..686a8c5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -79,6 +79,13 @@ pad <- function(x, length, fill = NA, where = "end") { switch(where, start = c(padding, x), c(x, padding)) } +rep0 <- function(x, ...) { + if (is.null(x)) { + return(NULL) + } + rep(x, ...) +} + rename <- function(df, old, new) { if (is.function(new)) { new <- new(old) diff --git a/man/primitive_bracket.Rd b/man/primitive_bracket.Rd index 358a5a9..809e356 100644 --- a/man/primitive_bracket.Rd +++ b/man/primitive_bracket.Rd @@ -11,6 +11,8 @@ primitive_bracket( oob = "squish", drop_zero = TRUE, pad_discrete = 0.4, + levels_brackets = NULL, + levels_text = NULL, theme = NULL, position = waiver() ) @@ -50,6 +52,12 @@ of \code{"squish"}, \code{"censor"} or \code{"none"}.} extended when given as a discrete variable. This is applied after the \code{drop_zero} setting.} +\item{levels_brackets}{A list of \verb{} objects to customise how +brackets appear at every level.} + +\item{levels_text}{A list of \verb{} objects to customise how +text appears at every level.} + \item{theme}{A \code{\link[ggplot2:theme]{}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the guide overrides and is combined with the plot's theme.} From 6b2a1aed17b79f3f6616ffd35babc4ccd38cb860 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 13:29:13 +0200 Subject: [PATCH 3/8] add customisation options to box primitive --- R/primitive-box.R | 82 ++++++++++++++++++++++++++++++++------------ man/primitive_box.Rd | 8 +++++ 2 files changed, 69 insertions(+), 21 deletions(-) diff --git a/R/primitive-box.R b/R/primitive-box.R index de8d49b..34e1f01 100644 --- a/R/primitive-box.R +++ b/R/primitive-box.R @@ -7,6 +7,8 @@ #' @inheritParams primitive_bracket #' @param min_size A [``][grid::unit] setting the minimal size #' of a box. +#' @param levels_box A list of `` objects to customise how +#' boxes appear at every level. #' #' @return A `` primitive guide that can be used inside other #' guides. @@ -54,6 +56,8 @@ primitive_box <- function( drop_zero = TRUE, pad_discrete = 0.4, min_size = NULL, + levels_box = NULL, + levels_text = NULL, theme = NULL, position = waiver() ) { @@ -62,6 +66,16 @@ primitive_box <- function( oob <- arg_match0(oob, c("squish", "censor", "none")) check_bool(drop_zero) check_number_decimal(pad_discrete, allow_infinite = FALSE) + check_list_of( + levels_box, + c("element_rect", "element_blank", "NULL"), + allow_null = TRUE + ) + check_list_of( + levels_text, + c("element_text", "element_blank", "NULL"), + allow_null = TRUE + ) new_guide( key = key, @@ -70,6 +84,8 @@ primitive_box <- function( drop_zero = drop_zero, pad_discrete = pad_discrete, min_size = min_size, + levels_box = levels_box, + levels_text = levels_text, theme = theme, position = position, available_aes = c("any", "x", "y", "r", "theta"), @@ -90,7 +106,8 @@ PrimitiveBox <- ggproto( params = new_params( key = NULL, oob = "squish", drop_zero = TRUE, - pad_discrete = 0.4, angle = waiver(), min_size = NULL + pad_discrete = 0.4, angle = waiver(), min_size = NULL, + levels_text = NULL, levels_box = NULL ), elements = list( @@ -149,13 +166,29 @@ PrimitiveBox <- ggproto( build_box = function(key, decor, elements, params) { - levels <- unique(c(key$.level, decor$.level)) + levels <- unique(c(key$.level, decor$.level)) + nlevels <- length(levels) + position <- params$position + + # Recycle custom elements per level to appropriate length + box_levels <- rep0(params$levels_box, length.out = nlevels) + text_levels <- rep0(params$levels_text, length.out = nlevels) + # Justify labels along their ranges if (!is_blank(elements$text)) { + hjust <- elements$text$hjust vjust <- elements$text$vjust - if (is_theta(params$position)) { - add <- if (params$position == "theta.sec") pi else 0 + + if (!is.null(text_levels)) { + hjust <- vapply(text_levels, function(x) x$hjust %||% hjust, numeric(1)) + hjust <- hjust[match(key$.level, levels)] + vjust <- vapply(text_levels, function(x) x$vjust %||% vjust, numeric(1)) + vjust <- vjust[match(key$.label, levels)] + } + + if (is_theta(position)) { + add <- if (position == "theta.sec") pi else 0 key$theta <- justify_range(key$theta, key$thetaend, hjust, theta = TRUE) key <- polar_xy(key, key$r, key$theta + add, params$bbox) } else if ("xend" %in% names(key)) { @@ -165,35 +198,42 @@ PrimitiveBox <- ggproto( } } - elements$text <- angle_labels(elements$text, params$angle, params$position) - grobs <- list() + grobs <- vector("list", nlevels) offset <- elements$offset angle <- params$angle %|W|% NULL min_size <- cm(params$min_size %||% 0.2) - sizes <- numeric() + sizes <- numeric(nlevels) + text <- angle_labels(elements$text, angle, position) measure <- switch( - params$position, + position, left = , right = width_cm, top = , bottom = height_cm, - function(x) attr(x, "size") %||% 0 + get_size_attr ) - for (i in levels) { - text <- draw_labels( - vec_slice(key, key$.level == i), - elements$text, angle = angle, offset = offset, params$position + for (i in seq_len(nlevels)) { + + # Render text + labels <- draw_labels( + vec_slice(key, key$.level == levels[[i]]), + combine_elements(text_levels[[i]], text), + angle = angle, offset = offset, position = position ) - size <- max(measure(text), min_size) - sizes <- c(sizes, size) + sizes[i] <- max(measure(labels), min_size) + + # Render box box <- draw_box( - vec_slice(decor, decor$.level == i), - elements$box, size = size, params$position, offset = offset + vec_slice(decor, decor$.level == levels[[i]]), + combine_elements(box_levels[[i]], elements$box), + size = sizes[i], offset = offset, position = position ) - offset <- offset + size - grobs <- c(grobs, list(grobTree(box, text))) + + offset <- offset + sizes[i] + grobs[[i]] <- grobTree(box, labels) } - if (params$position %in% c("top", "left")) { + + if (position %in% c("top", "left")) { grobs <- rev(grobs) sizes <- rev(sizes) } @@ -226,7 +266,7 @@ PrimitiveBox <- ggproto( # Helpers ----------------------------------------------------------------- -draw_box = function(decor, element, size, position, offset) { +draw_box = function(decor, element, size, offset, position) { if (nrow(decor) < 2 || is_blank(element)) { return(zeroGrob()) } diff --git a/man/primitive_box.Rd b/man/primitive_box.Rd index 537e150..93565bf 100644 --- a/man/primitive_box.Rd +++ b/man/primitive_box.Rd @@ -11,6 +11,8 @@ primitive_box( drop_zero = TRUE, pad_discrete = 0.4, min_size = NULL, + levels_box = NULL, + levels_text = NULL, theme = NULL, position = waiver() ) @@ -43,6 +45,12 @@ the \code{drop_zero} setting.} \item{min_size}{A [\verb{}][grid::unit] setting the minimal size of a box.} +\item{levels_box}{A list of \verb{} objects to customise how +boxes appear at every level.} + +\item{levels_text}{A list of \verb{} objects to customise how +text appears at every level.} + \item{theme}{A \code{\link[ggplot2:theme]{}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the guide overrides and is combined with the plot's theme.} From a3ebab65a6665ac6311309364456de1d2d2a1634 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 14:10:10 +0200 Subject: [PATCH 4/8] passing text formatting to labels --- R/primitive-labels.R | 18 ++++++++++++++++-- R/utils-text.R | 21 +++++++++++++++++++++ 2 files changed, 37 insertions(+), 2 deletions(-) diff --git a/R/primitive-labels.R b/R/primitive-labels.R index 77627f4..42ad731 100644 --- a/R/primitive-labels.R +++ b/R/primitive-labels.R @@ -204,6 +204,14 @@ draw_labels <- function(key, element, angle, offset, element = element, label = labels, x = x, y = y, + family = key$.family, + face = key$.face, + colour = key$.colour, + size = key$.size, + hjust = key$.hjust, + vjust = key$.vjust, + angle = key$.angle, + lineheight = key$.lineheight, margin_x = margin_x, margin_y = margin_y, check.overlap = check_overlap %||% FALSE @@ -235,8 +243,14 @@ draw_labels <- function(key, element, angle, offset, element = element, label = labels, x = x, y = y, - hjust = hjust, vjust = vjust, - angle = angle, + family = key$.family, + face = key$.face, + colour = key$.colour, + size = key$.size, + lineheight = key$.lineheight, + hjust = hjust, + vjust = vjust, + angle = angle, check.overlap = check_overlap ) diff --git a/R/utils-text.R b/R/utils-text.R index eda2834..fd001ae 100644 --- a/R/utils-text.R +++ b/R/utils-text.R @@ -88,3 +88,24 @@ get_fontmetrics <- function(x) { info[i[1]:i[2]] <- lapply(info[i[1]:i[2]], function(x) .in2cm * x / res) info } + +.label_params <- setdiff(fn_fmls_names(element_text), c("margin", "debug", "inherit.blank")) + +label_args <- function(..., call = caller_env()) { + args <- list2(...) + if (length(args) == 0) { + return(NULL) + } + + if (!is.null(args$color)) { + args$colour <- args$color + args$color <- NULL + } + extra <- setdiff(names(args), .label_params) + if (length(extra) > 0) { + cli::cli_warn("Ignoring unknown parameters: {.and {extra}}.", call = call) + } + args <- args[lengths(args) > 0] + names(args) <- paste0(".", names(args)) + args +} From 79f604cb6d5c3b265c14dcfab4b8f1186ef50ed4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 14:10:23 +0200 Subject: [PATCH 5/8] adopt formatting in ranged keys --- R/key-range.R | 37 ++++++++++++++++++++++----------- man/key_range.Rd | 16 +++++++------- tests/testthat/test-key-range.R | 17 +++++++++------ 3 files changed, 45 insertions(+), 25 deletions(-) diff --git a/R/key-range.R b/R/key-range.R index b3e8ca3..8905e86 100644 --- a/R/key-range.R +++ b/R/key-range.R @@ -31,8 +31,10 @@ #' argument is evaluated. #' @param ... [``][rlang::topic-data-mask] A set of mappings #' similar to those provided to [`aes()`][ggplot2::aes], which will be -#' evaluated in the `data` argument. These must contain `start` and `end` -#' mappings. +#' evaluated in the `data` argument. +#' For `key_range_map()`, these *must* contain `start` and `end` mappings. +#' Can contain additional parameters for text styling, namely `colour`, +#' `family`, `face`, `size`, `hjust`, `vjust`, `angle` and `lineheight`. #' @param .call A [call][rlang::topic-error-call] to display in messages. #' #' @details @@ -77,16 +79,17 @@ NULL #' @rdname key_range #' @export -key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE) { +key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE, ...) { check_string(sep) check_bool(reverse) force(sep) force(reverse) + dots <- label_args(...) call <- current_call() function(scale, aesthetic = NULL) { range_from_label( scale = scale, aesthetic = aesthetic, - sep = sep, reverse = reverse, + sep = sep, reverse = reverse, extra_args = dots, call = call ) } @@ -94,8 +97,11 @@ key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE) { #' @rdname key_range #' @export -key_range_manual <- function(start, end, name = NULL, level = NULL) { - df <- data_frame0(start = start, end = end, .label = name, .level = level) +key_range_manual <- function(start, end, name = NULL, level = NULL, ...) { + df <- data_frame0( + start = start, end = end, .label = name, .level = level, + !!!label_args(...) + ) check_columns(df, c("start", "end")) class(df) <- c("key_range", "key_guide", class(df)) df @@ -111,20 +117,25 @@ key_range_map <- function(data, ..., .call = caller_env()) { df <- eval_aes( data, mapping, required = c("start", "end"), - optional = c("name", "level"), + optional = c("name", "level", .label_params), call = .call, arg_mapping = "mapping", arg_data = "data" ) - df <- rename(df, c("name", "level"), c(".label", ".level")) + df <- rename( + df, c("name", "level", .label_params), + c(".label", ".level", paste0(".", .label_params)) + ) + df$colour <- df$color + df$color <- NULL class(df) <- c("key_range", "key_guide", class(df)) df } -key_range_rle <- function(x) { +key_range_rle <- function(x, ...) { rle <- vec_unrep(x) end <- cumsum(rle$times) + 0.5 start <- end - rle$times - key_range_manual(start, end, name = rle$key, level = 1L) + key_range_manual(start, end, name = rle$key, level = 1L, ...) } # Extractor --------------------------------------------------------------- @@ -213,7 +224,8 @@ range_censor <- function(ranges, limits) { ## Other helpers ---------------------------------------------------------- range_from_label <- function( - scale, aesthetic = NULL, sep = "[^[:alnum:]]+", reverse = FALSE, call = caller_env() + scale, aesthetic = NULL, sep = "[^[:alnum:]]+", reverse = FALSE, + extra_args = list(), call = caller_env() ) { # Extract a standard key from the scale aesthetic <- aesthetic %||% scale$aesthetics[1] @@ -258,7 +270,7 @@ range_from_label <- function( start = value, end = value, .label = key$.label, .level = 0 ) if (is_empty(labels)) { - return(key) + return(data_frame0(key, !!!extra_args)) } ranges <- apply(labels, 2, function(labs) { rle <- vec_unrep(labs) @@ -274,6 +286,7 @@ range_from_label <- function( ranges$.level <- rep.int(seq_along(nrows), nrows) range <- vec_slice(ranges, !is.na(ranges$.label)) df <- vec_rbind(key, range) + df <- data_frame0(df, !!!extra_args) class(df) <- c("key_range", "key_guide", class(df)) df } diff --git a/man/key_range.Rd b/man/key_range.Rd index 3de780d..7f01723 100644 --- a/man/key_range.Rd +++ b/man/key_range.Rd @@ -7,9 +7,9 @@ \alias{key_range_map} \title{Range keys} \usage{ -key_range_auto(sep = "[^[:alnum:]]+", reverse = FALSE) +key_range_auto(sep = "[^[:alnum:]]+", reverse = FALSE, ...) -key_range_manual(start, end, name = NULL, level = NULL) +key_range_manual(start, end, name = NULL, level = NULL, ...) key_range_map(data, ..., .call = caller_env()) } @@ -24,6 +24,13 @@ labels as the inner labels and the last labels as the outer labels. If \code{TRUE}, thee first labels are treated as the outer labels and the last labels are treated as the inner labels.} +\item{...}{\code{\link[rlang:topic-data-mask]{}} A set of mappings +similar to those provided to \code{\link[ggplot2:aes]{aes()}}, which will be +evaluated in the \code{data} argument. +For \code{key_range_map()}, these \emph{must} contain \code{start} and \code{end} mappings. +Can contain additional parameters for text styling, namely \code{colour}, +\code{family}, \code{face}, \code{size}, \code{hjust}, \code{vjust}, \code{angle} and \code{lineheight}.} + \item{start, end}{A vector that can be interpreted by the scale, giving the start and end positions of each range respectively.} @@ -37,11 +44,6 @@ drawn.} \code{\link[ggplot2:fortify]{fortify()}} to a \verb{}, in which the \code{mapping} argument is evaluated.} -\item{...}{\code{\link[rlang:topic-data-mask]{}} A set of mappings -similar to those provided to \code{\link[ggplot2:aes]{aes()}}, which will be -evaluated in the \code{data} argument. These must contain \code{start} and \code{end} -mappings.} - \item{.call}{A \link[rlang:topic-error-call]{call} to display in messages.} } \value{ diff --git a/tests/testthat/test-key-range.R b/tests/testthat/test-key-range.R index 94c2106..6314853 100644 --- a/tests/testthat/test-key-range.R +++ b/tests/testthat/test-key-range.R @@ -1,6 +1,6 @@ test_that("key_range_auto works as intended", { - fun <- key_range_auto() + fun <- key_range_auto(colour = "red") expect_type(fun, "closure") template <- scale_x_discrete(limits = c("1 A", "2 A", "1 B", "2 B", "3 A")) @@ -12,6 +12,7 @@ test_that("key_range_auto works as intended", { expect_equal(unclass(test$end), c(1:5, 2, 4, 5)) expect_equal(test$.label, c(1:2, 1:3, "A", "B", "A")) expect_equal(test$.level, rep(c(0, 1), c(5, 3))) + expect_equal(test$.colour, rep("red", nrow(test))) template$limits[5] <- "3" expect_warning(fun(template), regexp = "can be split into equal lengths") @@ -24,29 +25,32 @@ test_that("key_range_auto works as intended", { expect_equal(unclass(test$end), 1:5) expect_equal(test$.label, LETTERS[1:5]) expect_equal(test$.level, rep(0, 5)) + expect_equal(test$.colour, rep("red", nrow(test))) }) test_that("key_range_manual works as intended", { - test <- key_range_manual(1:5, 4:8, LETTERS[1:5], c(1, 1, 2, 2, 1)) + test <- key_range_manual(1:5, 4:8, LETTERS[1:5], c(1, 1, 2, 2, 1), colour = "blue") expect_s3_class(test, "key_range") expect_equal(test$start, 1:5) expect_equal(test$end, 4:8) expect_equal(test$.label, LETTERS[1:5]) expect_equal(test$.level, c(1, 1, 2, 2, 1)) + expect_equal(test$.colour, rep("blue", nrow(test))) }) test_that("key_range_map works as intended", { - test <- key_range_map(presidential, start = start, end = end, name = name) + test <- key_range_map(presidential, start = start, end = end, name = name, colour = "green") expect_s3_class(test, "key_range") - expect_equal(test$start, presidential$start) - expect_equal(test$end, presidential$end) + expect_equal(test$start, presidential$start) + expect_equal(test$end, presidential$end) expect_equal(test$.label, presidential$name) + expect_equal(test$.colour, rep("green", nrow(test))) expect_warning(expect_warning( key_range_map(presidential, foo = start), @@ -61,12 +65,13 @@ test_that("key_range_map works as intended", { test_that("key_range_rle works as intended", { - test <- key_range_rle(rep(LETTERS[1:5], 5:1)) + test <- key_range_rle(rep(LETTERS[1:5], 5:1), colour = "orange") expect_s3_class(test, "key_range") expect_equal(test$start, c(0, 5, 9, 12, 14) + 0.5) expect_equal(test$end, c(5, 9, 12, 14, 15) + 0.5) expect_equal(test$.label, LETTERS[1:5]) + expect_equal(test$.colour, rep("orange", nrow(test))) }) test_that("range_extract_key can censor oob values", { From 87821f0ea47d1f80dec54e2ee8b04f9e0f26f3bf Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 14:33:05 +0200 Subject: [PATCH 6/8] adopt formatting in regular keys --- R/key-.R | 32 ++++++++++++++++++++++---------- tests/testthat/test-key-.R | 26 ++++++++++---------------- 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/R/key-.R b/R/key-.R index 58e6e95..7e1f187 100644 --- a/R/key-.R +++ b/R/key-.R @@ -79,10 +79,11 @@ NULL #' @rdname key_standard #' @export -key_auto <- function() { +key_auto <- function(...) { function(scale, aesthetic = NULL) { aesthetic <- aesthetic %||% scale$aesthetics[1] df <- Guide$extract_key(scale, aesthetic) + df <- data_frame0(df, !!!label_args(...)) class(df) <- c("key_standard", "key_guide", class(df)) df } @@ -90,9 +91,11 @@ key_auto <- function() { #' @rdname key_standard #' @export -key_manual <- function(aesthetic, value = aesthetic, label = as.character(value), type = NULL) { +key_manual <- function(aesthetic, value = aesthetic, + label = as.character(value), type = NULL, + ...) { df <- data_frame0(aesthetic = aesthetic, value = value, - label = label, type = type) + label = label, type = type, !!!label_args(...)) check_columns(df, c("aesthetic", "value", "label")) df <- rename(df, c("value", "label", "type"), c(".value", ".label", ".type")) class(df) <- c("key_standard", "key_guide", class(df)) @@ -109,14 +112,18 @@ key_map <- function(data, ..., .call = caller_env()) { df <- eval_aes( data, mapping, required = c("aesthetic"), - optional = c("value", "label"), + optional = c("value", "label", .label_params), call = .call, arg_mapping = "mapping", arg_data = "data" ) df$value <- df$value %||% df$aesthetic df$label <- df$label %||% as.character(df$aesthetic) check_columns(df, c("aesthetic", "value", "label")) - df <- rename(df, c("value", "label"), c(".value", ".label")) + df <- rename( + df, + c("value", "label", .label_params), + c(".value", ".label", paste0(".", .label_params)) + ) class(df) <- c("key_standard", "key_guide", class(df)) df } @@ -124,10 +131,12 @@ key_map <- function(data, ..., .call = caller_env()) { #' @rdname key_standard #' @export -key_minor <- function() { +key_minor <- function(...) { + dots <- label_args(...) function(scale, aesthetic = NULL) { aesthetic <- aesthetic %||% scale$aesthetics[1] df <- GuideAxis$extract_key(scale, aesthetic, minor.ticks = TRUE) + df <- data_frame0(df, !!!dots) class(df) <- c("key_standard", "key_guide", class(df)) df } @@ -137,7 +146,7 @@ key_minor <- function() { #' @export key_log <- function( prescale_base = NULL, negative_small = 0.1, expanded = TRUE, - labeller = NULL + labeller = NULL, ... ) { check_number_decimal( negative_small, min = 1e-100, @@ -150,13 +159,14 @@ key_log <- function( force(prescale_base) force(negative_small) force(expanded) + dots <- label_args(...) call <- expr(key_log()) function(scale, aesthetic = NULL) { - log10_keys( + key <- log10_keys( scale = scale, aesthetic = aesthetic, prescale_base = prescale_base, negative_small = negative_small, - expanded = expanded, call = call + expanded = expanded, extra_args = dots, call = call ) } } @@ -201,6 +211,7 @@ log10_keys <- function(scale, aesthetic, negative_small = 0.1, expanded = TRUE, labeller = NULL, + extra_args = NULL, call = caller_env()) { aesthetic <- aesthetic %||% scale$aesthetics[1] if (scale$is_discrete()) { @@ -263,7 +274,8 @@ log10_keys <- function(scale, aesthetic, !!aesthetic := ticks, .value = ticks, .label = labels, - .type = rep(c("major", "minor", "mini"), times = nticks) + .type = rep(c("major", "minor", "mini"), times = nticks), + !!!extra_args ) if (expanded) { diff --git a/tests/testthat/test-key-.R b/tests/testthat/test-key-.R index 310d9eb..c64d72e 100644 --- a/tests/testthat/test-key-.R +++ b/tests/testthat/test-key-.R @@ -1,7 +1,7 @@ test_that("key_auto works as intended", { - fun <- key_auto() + fun <- key_auto(colour = "red") expect_type(fun, "closure") template <- scale_x_discrete(limits = LETTERS[1:5]) @@ -11,28 +11,30 @@ test_that("key_auto works as intended", { expect_equal(test$x, 1:5, ignore_attr = TRUE) expect_equal(test$.value, LETTERS[1:5], ignore_attr = TRUE) expect_equal(test$.label, LETTERS[1:5]) + expect_equal(test$.colour, rep("red", nrow(test))) }) test_that("key_manual works as intended", { - test <- key_manual(1:5) + test <- key_manual(1:5, colour = "blue") expect_s3_class(test, "key_standard") expect_equal(test$aesthetic, 1:5) expect_equal(test$.value, 1:5) expect_equal(test$.label, as.character(1:5)) - + expect_equal(test$.colour, rep("blue", nrow(test))) }) test_that("key_map works as intended", { - test <- key_map(iris, aesthetic = as.character(unique(Species))) + test <- key_map(iris, aesthetic = as.character(unique(Species)), colour = "green") expect_s3_class(test, "key_standard") expect_equal(test$aesthetic, levels(iris$Species)) expect_equal(test$.value, levels(iris$Species)) expect_equal(test$.label, levels(iris$Species)) + expect_equal(test$.colour, rep("green", nrow(test))) expect_error(expect_warning(expect_warning( key_map(iris, foo = Species), @@ -42,7 +44,7 @@ test_that("key_map works as intended", { test_that("key_minor works as intended", { - fun <- key_minor() + fun <- key_minor(colour = "purple") expect_type(fun, "closure") template <- scale_x_continuous(limits = c(0, 10), breaks = seq(0, 10, by = 2)) @@ -53,18 +55,20 @@ test_that("key_minor works as intended", { expect_equal(test$.value, c(0, 2, 4, 6, 8, 10, 1, 3, 5, 7, 9), ignore_attr = TRUE) expect_equal(test$.label, c(0, 2, 4, 6, 8, 10, rep(NA_character_, 5))) expect_equal(test$.type, rep(c("major", "minor"), c(6, 5))) + expect_equal(test$.colour, rep("purple", nrow(test))) }) test_that("key_log works as intended", { - fun <- key_log() + fun <- key_log(colour = "pink") expect_type(fun, "closure") template <- scale_x_continuous(limits = c(0.1, 10), transform = "log10") test <- fun(template) expect_s3_class(test, "key_standard") expect_snapshot(test) + expect_equal(test$.colour, rep("pink", nrow(test))) }) @@ -115,13 +119,3 @@ test_that("log10_keys returns sensible results", { }) - - -df <- data.frame(x = rcauchy(100), y = rnorm(100)) - -ggplot(df, aes(x, y)) + - geom_point() + - scale_x_continuous( - trans = "asinh", - guide = guide_axis_custom("log") - ) From b7b755f46d817815854086d920b48f4a86d39d76 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 14:53:45 +0200 Subject: [PATCH 7/8] update snapshot --- tests/testthat/_snaps/key-.md | 40 +++++++++++++++++------------------ 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/tests/testthat/_snaps/key-.md b/tests/testthat/_snaps/key-.md index 33a7e09..0b934d4 100644 --- a/tests/testthat/_snaps/key-.md +++ b/tests/testthat/_snaps/key-.md @@ -3,24 +3,24 @@ Code test Output - x .value .label .type - 1 -1.00000000 -1.00000000 10^-1 major - 2 0.00000000 0.00000000 10^0 major - 3 1.00000000 1.00000000 10^1 major - 4 -0.30103000 -0.30103000 NULL minor - 5 0.69897000 0.69897000 NULL minor - 6 -0.69897000 -0.69897000 NULL mini - 7 -0.52287875 -0.52287875 NULL mini - 8 -0.39794001 -0.39794001 NULL mini - 9 -0.22184875 -0.22184875 NULL mini - 10 -0.15490196 -0.15490196 NULL mini - 11 -0.09691001 -0.09691001 NULL mini - 12 -0.04575749 -0.04575749 NULL mini - 13 0.30103000 0.30103000 NULL mini - 14 0.47712125 0.47712125 NULL mini - 15 0.60205999 0.60205999 NULL mini - 16 0.77815125 0.77815125 NULL mini - 17 0.84509804 0.84509804 NULL mini - 18 0.90308999 0.90308999 NULL mini - 19 0.95424251 0.95424251 NULL mini + x .value .label .type .colour + 1 -1.00000000 -1.00000000 10^-1 major pink + 2 0.00000000 0.00000000 10^0 major pink + 3 1.00000000 1.00000000 10^1 major pink + 4 -0.30103000 -0.30103000 NULL minor pink + 5 0.69897000 0.69897000 NULL minor pink + 6 -0.69897000 -0.69897000 NULL mini pink + 7 -0.52287875 -0.52287875 NULL mini pink + 8 -0.39794001 -0.39794001 NULL mini pink + 9 -0.22184875 -0.22184875 NULL mini pink + 10 -0.15490196 -0.15490196 NULL mini pink + 11 -0.09691001 -0.09691001 NULL mini pink + 12 -0.04575749 -0.04575749 NULL mini pink + 13 0.30103000 0.30103000 NULL mini pink + 14 0.47712125 0.47712125 NULL mini pink + 15 0.60205999 0.60205999 NULL mini pink + 16 0.77815125 0.77815125 NULL mini pink + 17 0.84509804 0.84509804 NULL mini pink + 18 0.90308999 0.90308999 NULL mini pink + 19 0.95424251 0.95424251 NULL mini pink From 67fe423a8548780a9f7a6fe814242d1068de08e7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 14:54:23 +0200 Subject: [PATCH 8/8] redocument --- man/key_standard.Rd | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/man/key_standard.Rd b/man/key_standard.Rd index efedafd..83ade01 100644 --- a/man/key_standard.Rd +++ b/man/key_standard.Rd @@ -9,27 +9,33 @@ \alias{key_log} \title{Standard keys} \usage{ -key_auto() +key_auto(...) key_manual( aesthetic, value = aesthetic, label = as.character(value), - type = NULL + type = NULL, + ... ) key_map(data, ..., .call = caller_env()) -key_minor() +key_minor(...) key_log( prescale_base = NULL, negative_small = 0.1, expanded = TRUE, - labeller = NULL + labeller = NULL, + ... ) } \arguments{ +\item{...}{\code{\link[rlang:topic-data-mask]{}} A set of mappings +similar to those provided to \code{\link[ggplot2:aes]{aes()}}, which will be +evaluated in the \code{data} argument. These must contain \code{aesthetic} mapping.} + \item{aesthetic, value}{A vector of values for the guide to represent equivalent to the \code{breaks} argument in scales. The \code{aesthetic} will be mapped, whereas \code{value} will not. For most intents and purposes, @@ -45,10 +51,6 @@ treated as major breaks.} \code{\link[ggplot2:fortify]{fortify()}} to a \verb{}, in which the \code{mapping} argument is evaluated.} -\item{...}{\code{\link[rlang:topic-data-mask]{}} A set of mappings -similar to those provided to \code{\link[ggplot2:aes]{aes()}}, which will be -evaluated in the \code{data} argument. These must contain \code{aesthetic} mapping.} - \item{.call}{A \link[rlang:topic-error-call]{call} to display in messages.} \item{prescale_base}{A \verb{} giving the base of logarithm to