From f243b6eebbe413c3cc97451d48474036e6209665 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 20 Apr 2024 11:08:47 +0200 Subject: [PATCH 01/14] Use `is_theta()` helper --- R/compose-ontop.R | 2 +- R/compose-stack.R | 4 ++-- R/key-.R | 4 ++-- R/primitive-box.R | 4 ++-- R/primitive-bracket.R | 4 ++-- R/primitive-ticks.R | 2 +- R/primitive-title.R | 2 +- R/shapes_brackets.R | 4 ++-- R/utils.R | 7 +++++++ 9 files changed, 20 insertions(+), 13 deletions(-) diff --git a/R/compose-ontop.R b/R/compose-ontop.R index 5c6b80e..72bd872 100644 --- a/R/compose-ontop.R +++ b/R/compose-ontop.R @@ -71,7 +71,7 @@ ComposeOntop <- ggproto( guide_index <- seq_len(n_guides) grobs <- vector("list", n_guides) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { stack_offset <- unit(cm(params$stack_offset %||% 0), "cm") offset <- stack_offset diff --git a/R/compose-stack.R b/R/compose-stack.R index 9494a95..c2a4d38 100644 --- a/R/compose-stack.R +++ b/R/compose-stack.R @@ -94,7 +94,7 @@ ComposeStack <- ggproto( }, override_elements = function(params, elements, theme) { - if (!params$position %in% c("theta", "theta.sec")) { + if (!is_theta(params$position)) { elements$spacing <- cm(elements$spacing) } if (!is.null(params$side_titles)) { @@ -155,7 +155,7 @@ ComposeStack <- ggproto( guide_index <- seq_len(n_guides) grobs <- vector("list", n_guides) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { stack_offset <- unit(cm(params$stack_offset %||% 0), "cm") offset <- stack_offset offset_ranges <- vector("list", n_guides) diff --git a/R/key-.R b/R/key-.R index be87651..280fa21 100644 --- a/R/key-.R +++ b/R/key-.R @@ -304,7 +304,7 @@ transform_key <- function(key, position, coord, panel_params) { key <- replace_null(key, x = other, y = other) transformed <- coord$transform(key, panel_params) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { add <- if (position == "theta.sec") pi else 0 transformed$theta <- transformed$theta + add } @@ -321,7 +321,7 @@ transform_key <- function(key, position, coord, panel_params) { key <- rename(key, c("y", "yend"), rev) } key <- coord$transform(key, panel_params) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { transformed$thetaend <- key$theta + add } else { if (ends[1]) { diff --git a/R/primitive-box.R b/R/primitive-box.R index a5da6a0..62b1351 100644 --- a/R/primitive-box.R +++ b/R/primitive-box.R @@ -150,7 +150,7 @@ PrimitiveBox <- ggproto( if (!is_blank(elements$text)) { hjust <- elements$text$hjust vjust <- elements$text$vjust - if (params$position %in% c("theta", "theta.sec")) { + if (is_theta(params$position)) { add <- if (params$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) @@ -229,7 +229,7 @@ draw_box = function(decor, element, size, position, offset) { aes <- switch(position, top = , bottom = "x", left = , right = "y", "theta") rle <- new_rle(decor$group) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { rev <- vec_slice(decor, nrow(decor):1) x <- unit(c(decor$x, rev$x), "npc") y <- unit(c(decor$y, rev$y), "npc") diff --git a/R/primitive-bracket.R b/R/primitive-bracket.R index 107344c..07bb55d 100644 --- a/R/primitive-bracket.R +++ b/R/primitive-bracket.R @@ -177,7 +177,7 @@ PrimitiveBracket <- ggproto( if (!is_blank(elements$text)) { hjust <- elements$text$hjust vjust <- elements$text$vjust - if (params$position %in% c("theta", "theta.sec")) { + if (is_theta(params$position)) { add <- if (params$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) @@ -273,7 +273,7 @@ draw_bracket <- function(decor, elements, position, offset) { x <- unit(decor$x, "npc") y <- unit(decor$y, "npc") - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { offset <- (1 - decor$offset) * elements$size + offset x <- x + unit(sin(decor$theta) * offset, "cm") y <- y + unit(cos(decor$theta) * offset, "cm") diff --git a/R/primitive-ticks.R b/R/primitive-ticks.R index e35c7d7..7e97de4 100644 --- a/R/primitive-ticks.R +++ b/R/primitive-ticks.R @@ -203,7 +203,7 @@ draw_ticks = function(key, element, params, position, length, offset = 0) { return(zeroGrob()) } bidi <- c(1, -as.numeric(params$bidi %||% FALSE)) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { angle <- rep(key$theta, each = 2) x <- rep(key$x, each = 2) y <- rep(key$y, each = 2) diff --git a/R/primitive-title.R b/R/primitive-title.R index 66aba2d..08e6705 100644 --- a/R/primitive-title.R +++ b/R/primitive-title.R @@ -88,7 +88,7 @@ PrimitiveTitle <- ggproto( }, transform = function(self, params, coord, panel_params) { - if (params$position %in% c("theta", "theta.sec")) { + if (is_theta(params$position)) { params$bbox <- panel_params$bbox %||% list(c(x = c(0, 1), y = c(0, 1))) params$arc <- panel_params$arc %||% c(0, 2 * pi) params$donut <- panel_params$inner_radius %||% c(0, 0.4) diff --git a/R/shapes_brackets.R b/R/shapes_brackets.R index d43ada6..71287fb 100644 --- a/R/shapes_brackets.R +++ b/R/shapes_brackets.R @@ -136,7 +136,7 @@ transform_bracket <- function(bracket, position, coord, panel_params) { bbox <- panel_params$bbox %||% list(x = c(0, 1), y = c(0, 1)) - if (position %in% c("theta", "theta.sec")) { + if (is_theta(position)) { bbox <- panel_params$bbox %||% list(x = c(0, 1), y = c(0, 1)) range <- panel_params$r.range if (position == "theta") { @@ -152,7 +152,7 @@ transform_bracket <- function(bracket, position, coord, panel_params) { bracket$y <- bracket$y %||% other bracket <- coord_munch(coord, bracket, panel_params) - if (!position %in% c("theta", "theta.sec")) { + if (!is_theta(position)) { return(bracket) } donut <- panel_params$inner_radius diff --git a/R/utils.R b/R/utils.R index abe1f18..facaf88 100644 --- a/R/utils.R +++ b/R/utils.R @@ -157,6 +157,13 @@ suffix_position <- function(value, position) { value } +is_theta <- function(x) { + if (is_missing(x) || !is.character(x)) { + return(FALSE) + } + x %in% c("theta", "theta.sec") +} + # Based on example in ?vctrs::vec_chop # It's faster than stats::ave vec_ave <- function(x, group, fun, ...) { From 454e67a489a7bcb3a191d5435832e3ddf19042f3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 20 Apr 2024 11:10:56 +0200 Subject: [PATCH 02/14] tweak composition --- R/compose-.R | 3 ++- R/compose-stack.R | 16 +++++++++------- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/R/compose-.R b/R/compose-.R index c76f839..578a5f3 100644 --- a/R/compose-.R +++ b/R/compose-.R @@ -86,7 +86,8 @@ Compose <- ggproto( } else { guide_title <- waiver() } - guide_params[[i]]$position <- position + guide_params[[i]]$position <- + (guide_params[[i]]$position %|W|% NULL) %||% position guide_params[[i]]$angle <- guide_params[[i]]$angle %|W|% params$angle guide_params[[i]]["key"] <- list(guide_params[[i]]$key %||% key) guide_params[[i]] <- params$guides[[i]]$train( diff --git a/R/compose-stack.R b/R/compose-stack.R index c2a4d38..0b2edd2 100644 --- a/R/compose-stack.R +++ b/R/compose-stack.R @@ -154,14 +154,23 @@ ComposeStack <- ggproto( guide_index <- seq_len(n_guides) grobs <- vector("list", n_guides) + draw_label <- !isFALSE(params$draw_label %||% TRUE) + + keep <- rep(TRUE, n_guides) + if (!draw_label && length(params$drop) > 0) { + drop <- intersect(params$drop %||% guide_index[-1], guide_index) + keep[drop] <- FALSE + } if (is_theta(position)) { stack_offset <- unit(cm(params$stack_offset %||% 0), "cm") offset <- stack_offset offset_ranges <- vector("list", n_guides) + guide_index <- guide_index[keep] for (i in guide_index) { pars <- params$guide_params[[i]] + pars$draw_label <- params$draw_label pars$stack_offset <- offset grob <- params$guides[[i]]$draw( theme = theme, position = position, direction = direction, @@ -188,13 +197,6 @@ ComposeStack <- ggproto( side_titles <- self$build_title(params$side_titles, elems, params) - keep <- rep(TRUE, n_guides) - draw_label <- !isFALSE(params$draw_label %||% TRUE) - if (!draw_label && length(params$drop) > 0) { - drop <- intersect(params$drop %||% guide_index[-1], guide_index) - keep[drop] <- FALSE - } - for (i in guide_index) { pars <- params$guide_params[[i]] pars$draw_label <- draw_label From a59342445349b003a38ebb5bc956bbf2684a4a9d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 20 Apr 2024 12:36:29 +0200 Subject: [PATCH 03/14] ensure size attributes returns a number --- R/primitive-bracket.R | 5 ++--- R/utils.R | 3 +++ 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/primitive-bracket.R b/R/primitive-bracket.R index 07bb55d..8599a56 100644 --- a/R/primitive-bracket.R +++ b/R/primitive-bracket.R @@ -171,7 +171,6 @@ PrimitiveBracket <- ggproto( }, build_bracket = function(key, decor, elements, params) { - levels <- unique(c(key$.level, decor$.level)) if (!is_blank(elements$text)) { @@ -213,7 +212,7 @@ PrimitiveBracket <- ggproto( vec_slice(key, key$.level == i), elements$text, angle = angle, offset = offset, params$position ) - offset <- offset + attr(text, "size") %||% 0 + offset <- offset + get_size_attr(text) labels <- c(labels, list(text)) } if (params$position %in% c("top", "left")) { @@ -229,7 +228,7 @@ PrimitiveBracket <- ggproto( params$position, top = , bottom = height_cm(grobs$labels), left = , right = width_cm(grobs$labels), - vapply(grobs$labels, attr, which = "size", numeric(1)) + vapply(grobs$labels, get_size_attr, numeric(1)) ) is_bracket <- as.numeric(!is_each(grobs$brackets, is.zero)) bracket <- is_bracket * elements$size diff --git a/R/utils.R b/R/utils.R index facaf88..32f77ac 100644 --- a/R/utils.R +++ b/R/utils.R @@ -70,6 +70,9 @@ eval_aes <- function( x } +get_size_attr <- function(x) { + attr(x, "size", exact = TRUE) %||% 0 +} pad <- function(x, length, fill = NA, where = "end") { padding <- rep(fill, length - length(x)) From d7e722b71b869b5bfcaeb7a5538184559305cf30 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 20 Apr 2024 12:36:53 +0200 Subject: [PATCH 04/14] fallback for non-standard positions --- R/primitive-labels.R | 3 ++- R/utils-text.R | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/R/primitive-labels.R b/R/primitive-labels.R index 04d40e8..04ab220 100644 --- a/R/primitive-labels.R +++ b/R/primitive-labels.R @@ -355,6 +355,7 @@ position_margin <- function(position, margin = margin(), gap = unit(0, "pt")) { top = replace(margin, 3, margin[3] + gap), bottom = replace(margin, 1, margin[1] + gap), left = replace(margin, 2, margin[2] + gap), - right = replace(margin, 4, margin[4] + gap) + right = replace(margin, 4, margin[4] + gap), + margin + (gap / 2) ) } diff --git a/R/utils-text.R b/R/utils-text.R index 8a539f9..0b4515e 100644 --- a/R/utils-text.R +++ b/R/utils-text.R @@ -11,7 +11,8 @@ setup_legend_text <- function(theme, direction = "vertical") { top = element_text(hjust = 0.5, vjust = 0.0, margin = margin), bottom = element_text(hjust = 0.5, vjust = 1.0, margin = margin), left = element_text(hjust = 1.0, vjust = 0.5, margin = margin), - right = element_text(hjust = 0.0, vjust = 0.5, margin = margin) + right = element_text(hjust = 0.0, vjust = 0.5, margin = margin), + element_text(hjust = 0.5, vjust = 0.5, margin = margin) ) ) calc_element("legend.text", theme + text) From e05d04b6c4c6d65f91b3168eb230d1872c2f66f6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 20 Apr 2024 13:10:38 +0200 Subject: [PATCH 05/14] compatibility for arched legends --- R/primitive-box.R | 4 ++++ R/primitive-bracket.R | 3 +++ R/primitive-line.R | 10 ++++++++-- R/primitive-title.R | 5 ++++- R/shapes_brackets.R | 4 ++++ 5 files changed, 23 insertions(+), 3 deletions(-) diff --git a/R/primitive-box.R b/R/primitive-box.R index 62b1351..de8d49b 100644 --- a/R/primitive-box.R +++ b/R/primitive-box.R @@ -104,9 +104,13 @@ PrimitiveBox <- ggproto( params <- primitive_extract_params(scale, params, ...) aesthetic <- params$aesthetic + if (aesthetic %in% c("x", "y")) { params$key <- rename(params$key, c("start", "end"), paste0(aesthetic, c("", "end"))) + } else if (is_theta(params$position)) { + params$key <- + rename(params$key, c("start", "end"), c("x", "xend")) } params }, diff --git a/R/primitive-bracket.R b/R/primitive-bracket.R index 8599a56..4a25c1d 100644 --- a/R/primitive-bracket.R +++ b/R/primitive-bracket.R @@ -129,6 +129,9 @@ PrimitiveBracket <- ggproto( if (aesthetic %in% c("x", "y")) { params$key <- rename(params$key, c("start", "end"), paste0(aesthetic, c("", "end"))) + } else if (is_theta(params$position)) { + params$key <- + rename(params$key, c("start", "end"), c("x", "xend")) } params }, diff --git a/R/primitive-line.R b/R/primitive-line.R index 8ba0f65..15f80ca 100644 --- a/R/primitive-line.R +++ b/R/primitive-line.R @@ -95,6 +95,7 @@ PrimitiveLine <- ggproto( } cap[cap == -Inf] <- limits[1] cap[cap == Inf] <- limits[2] + decor <- data_frame(!!aesthetic := cap) if (aesthetic %in% c("x", "y")) { opposite <- setdiff(c("x", "y"), aesthetic) @@ -103,9 +104,14 @@ PrimitiveLine <- ggproto( value <- if (position %in% c("top", "right")) -Inf else Inf decor[[opposite]] <- value } else { - decor[[aesthetic]] <- - scale$rescale(scale$oob(decor[[aesthetic]], range = limits), limits) + value <- scale$oob(decor[[aesthetic]], range = limits) + if (is_theta(position)) { + decor[[aesthetic]] <- value + } else { + decor[[aesthetic]] <- scale$rescale(value, limits) + } } + group <- seq_len(ceiling(nrow(decor) / 2)) decor$group <- rep(group, each = 2, length.out = nrow(decor)) decor diff --git a/R/primitive-title.R b/R/primitive-title.R index 08e6705..40deaf2 100644 --- a/R/primitive-title.R +++ b/R/primitive-title.R @@ -107,7 +107,7 @@ PrimitiveTitle <- ggproto( params$position, top = , bottom = height_cm(grobs), left = , right = width_cm(grobs), - attr(grobs, "offset") + attr(grobs, "offset") %||% 0 ) }, @@ -143,6 +143,9 @@ PrimitiveTitle <- ggproto( # Helpers ----------------------------------------------------------------- draw_theta_title <- function(label, elements, params) { + if (is.null(label)) { + return(zeroGrob()) + } title <- elements$title position <- params$position diff --git a/R/shapes_brackets.R b/R/shapes_brackets.R index 71287fb..5a949ed 100644 --- a/R/shapes_brackets.R +++ b/R/shapes_brackets.R @@ -158,6 +158,10 @@ transform_bracket <- function(bracket, position, coord, panel_params) { donut <- panel_params$inner_radius r <- donut[as.numeric(position == "theta") + 1] bracket <- polar_xy(bracket, r, bracket$theta, bbox) + + if (abs(diff(donut)) < 1e-2) { + return(bracket) + } if (position == "theta") { bracket$offset <- (rescale(bracket$r, to = c(0, 1), from = donut) - 1) * 10 } else { From 761dc7af88964359d1cf3d000a1b2127ba686ace Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sun, 21 Apr 2024 15:31:02 +0200 Subject: [PATCH 06/14] allow null keys in composition --- R/compose-.R | 2 +- R/key-.R | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/R/compose-.R b/R/compose-.R index 578a5f3..958dfa5 100644 --- a/R/compose-.R +++ b/R/compose-.R @@ -72,7 +72,7 @@ Compose <- ggproto( aesthetic <- params$aesthetic <- aesthetic %||% scale$aesthetics[1] check_position(position, allow_null = TRUE) - key <- params$key + key <- resolve_key(params$key, allow_null = TRUE) if (is.function(key)) { key <- key(scale, aesthetic %||% scale$aesthetics[1]) } diff --git a/R/key-.R b/R/key-.R index 280fa21..363c7c6 100644 --- a/R/key-.R +++ b/R/key-.R @@ -176,7 +176,10 @@ validate_key_types <- function(key, call = caller_env()) { key } -resolve_key <- function(x) { +resolve_key <- function(x, allow_null = FALSE) { + if (allow_null && is.null(x)) { + return(NULL) + } if (is.character(x)) { fun <- find_global(paste0("key_", x), env = global_env(), mode = "function") From d053b7153ff4f163b8ab642d1e5bae14bf54e05c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 10:30:20 +0200 Subject: [PATCH 07/14] resolve conflict --- R/compose-.R | 4 +++- R/compose-crux.R | 4 +++- R/primitive-labels.R | 11 ----------- R/primitive-line.R | 2 +- R/primitive-ticks.R | 2 +- R/utils-text.R | 19 +++++++++++++++---- 6 files changed, 23 insertions(+), 19 deletions(-) diff --git a/R/compose-.R b/R/compose-.R index 958dfa5..f22b775 100644 --- a/R/compose-.R +++ b/R/compose-.R @@ -101,7 +101,7 @@ Compose <- ggproto( params$title <- title } params$guide_params <- guide_params - params$hash <- hash(guide_params) + params$hash <- hash(lapply(guide_params, get_hash)) params }, @@ -218,3 +218,5 @@ set_limits <- function(params, limits) { params$limits <- limits params } + +get_hash <- function(x) x$hash diff --git a/R/compose-crux.R b/R/compose-crux.R index 392d47c..7057b61 100644 --- a/R/compose-crux.R +++ b/R/compose-crux.R @@ -203,7 +203,9 @@ ComposeCrux <- ggproto( position = elems$title_position, with(elems$title, rotate_just(angle, hjust, vjust)) ) - gt <- gtable_add_padding(gt, elems$margin) + if (!is.null(elems$margin)) { + gt <- gtable_add_padding(gt, elems$margin) + } } gt } diff --git a/R/primitive-labels.R b/R/primitive-labels.R index 04ab220..c91b154 100644 --- a/R/primitive-labels.R +++ b/R/primitive-labels.R @@ -348,14 +348,3 @@ label_priority_between <- function(min, max) { mid <- min - 1 + (n + 1) %/% 2 c(mid, label_priority_between(min, mid), label_priority_between(mid, max)) } - -position_margin <- function(position, margin = margin(), gap = unit(0, "pt")) { - switch( - position, - top = replace(margin, 3, margin[3] + gap), - bottom = replace(margin, 1, margin[1] + gap), - left = replace(margin, 2, margin[2] + gap), - right = replace(margin, 4, margin[4] + gap), - margin + (gap / 2) - ) -} diff --git a/R/primitive-line.R b/R/primitive-line.R index 15f80ca..3ef547a 100644 --- a/R/primitive-line.R +++ b/R/primitive-line.R @@ -80,7 +80,7 @@ PrimitiveLine <- ggproto( legend = list(line = "legend.axis.line") ), - hashables = exprs(decor), + hashables = exprs(decor[[aesthetic]], get0("position")), extract_key = standard_extract_key, diff --git a/R/primitive-ticks.R b/R/primitive-ticks.R index 7e97de4..db33130 100644 --- a/R/primitive-ticks.R +++ b/R/primitive-ticks.R @@ -84,7 +84,7 @@ PrimitiveTicks <- ggproto( params = new_params(key = NULL, bidi = FALSE), - hashables = exprs(key), + hashables = exprs(key$.value), elements = list( position = list( diff --git a/R/utils-text.R b/R/utils-text.R index 0b4515e..b8885f2 100644 --- a/R/utils-text.R +++ b/R/utils-text.R @@ -2,8 +2,8 @@ setup_legend_text <- function(theme, direction = "vertical") { position <- calc_element("legend.text.position", theme) position <- position %||% switch(direction, horizontal = "bottom", vertical = "right") - gap <- calc_element("legend.key.spacing", theme) - margin <- calc_element("text", theme)$margin + gap <- calc_element("legend.key.spacing", theme) %||% unit(0, "pt") + margin <- calc_element("text", theme)$margin %||% margin() margin <- position_margin(position, margin, gap) text <- theme( text = switch( @@ -21,13 +21,24 @@ setup_legend_text <- function(theme, direction = "vertical") { setup_legend_title <- function(theme, direction = "vertical") { position <- calc_element("legend.title.position", theme) position <- position %||% switch(direction, horizontal = "left", vertical = "top") - gap <- calc_element("legend.key.spacing", theme) - margin <- calc_element("text", theme)$margin + gap <- calc_element("legend.key.spacing", theme) %||% unit(0, "pt") + margin <- calc_element("text", theme)$margin %||% margin() margin <- position_margin(position, margin, gap) title <- theme(text = element_text(hjust = 0, vjust = 0.5, margin = margin)) calc_element("legend.title", theme + title) } +position_margin <- function(position, margin = margin(), gap = unit(0, "pt")) { + switch( + position, + top = replace(margin, 3, margin[3] + gap), + bottom = replace(margin, 1, margin[1] + gap), + left = replace(margin, 2, margin[2] + gap), + right = replace(margin, 4, margin[4] + gap), + margin + (gap / 2) + ) +} + get_text_dim_cm <- function(label, style, type = "both") { if (inherits(style, "element_text")) { style <- get_text_gp(style) From 8d01a00aa90b7617c48f649ffdbc1e13731a4e58 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 17:11:07 +0200 Subject: [PATCH 08/14] copy polar utilities --- R/utils-ggplot2.R | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/R/utils-ggplot2.R b/R/utils-ggplot2.R index a4fc580..5d95c01 100644 --- a/R/utils-ggplot2.R +++ b/R/utils-ggplot2.R @@ -217,4 +217,43 @@ get_key_size <- function(keys, which = "width", n) { apply(size, 2, max) } +polar_bbox <- function(arc, margin = c(0.05, 0.05, 0.05, 0.05), + inner_radius = c(0, 0.4)) { + if (abs(diff(arc) >= 2 * pi)) { + return(list(x = c(0, 1), y = c(0, 1))) + } + xmax <- 0.5 * sin(arc) + 0.5 + ymax <- 0.5 * cos(arc) + 0.5 + xmin <- inner_radius[1] * sin(arc) + 0.5 + ymin <- inner_radius[1] * cos(arc) + 0.5 + margin <- rep(margin, length.out = 4) + margin <- c( + max(ymin) + margin[1], + max(xmin) + margin[2], + min(ymin) - margin[3], + min(xmin) - margin[4] + ) + pos_theta <- c(0, 0.5, 1, 1.5) * pi + in_sector <- in_arc(pos_theta, arc) + bounds <- ifelse( + in_sector, + c(1, 1, 0, 0), + c(max(ymax, margin[1]), max(xmax, margin[2]), + min(ymax, margin[3]), min(xmax, margin[4])) + ) + list(x = c(bounds[4], bounds[2]), y = c(bounds[3], bounds[1])) +} + +in_arc <- function(theta, arc) { + if (abs(diff(arc)) > 2 * pi - sqrt(.Machine$double.eps)) { + return(rep(TRUE, length(theta))) + } + arc <- arc %% (2 * pi) + if (arc[1] < arc[2]) { + theta >= arc[1] & theta <= arc[2] + } else { + !(theta < arc[1] & theta > arc[2]) + } +} + # nocov end From b1b0e4ad8fe2beeb7e72182c35141856795e6034 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 17:24:20 +0200 Subject: [PATCH 09/14] text size tweaks --- R/primitive-labels.R | 2 +- R/utils-text.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/primitive-labels.R b/R/primitive-labels.R index c91b154..dd4ce59 100644 --- a/R/primitive-labels.R +++ b/R/primitive-labels.R @@ -279,7 +279,7 @@ measure_theta_labels <- function(element, labels, margin, angle, hjust, vjust) { y <- vec_interleave(ymin, ymax, ymax, ymin) angle <- rep(angle, each = 4) - max(x * sin(angle) + y * cos(angle)) + max(x * sin(angle) + y * cos(angle), na.rm = TRUE) } angle_labels <- function(element, angle, position) { diff --git a/R/utils-text.R b/R/utils-text.R index b8885f2..eda2834 100644 --- a/R/utils-text.R +++ b/R/utils-text.R @@ -35,7 +35,7 @@ position_margin <- function(position, margin = margin(), gap = unit(0, "pt")) { bottom = replace(margin, 1, margin[1] + gap), left = replace(margin, 2, margin[2] + gap), right = replace(margin, 4, margin[4] + gap), - margin + (gap / 2) + margin + gap ) } From 70416fbcb741e53519742564015cad219d49d8b2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 17:52:36 +0200 Subject: [PATCH 10/14] first draft of colour ring --- R/guide_colour_ring.R | 359 ++++++++++++++++++++++++++++++++++++++++++ R/utils.R | 5 + 2 files changed, 364 insertions(+) create mode 100644 R/guide_colour_ring.R diff --git a/R/guide_colour_ring.R b/R/guide_colour_ring.R new file mode 100644 index 0000000..213a572 --- /dev/null +++ b/R/guide_colour_ring.R @@ -0,0 +1,359 @@ +# Constructors ------------------------------------------------------------- + +#' Colour rings and arcs +#' +#' Similar to [`guide_colourbar()`][ggplot2::guide_colourbar], this guide +#' displays continuous `colour` or `fill` aesthetics. Instead of a bar, the +#' gradient in shown in a ring or arc, which can be convenient for cyclical +#' palettes such as some provided in the \pkg{scico} package. +#' +#' @param key A [standard key][key_standard] specification. Defaults to +#' [`key_auto()`]. +#' @param start,end A `` in radians specifying the offset of the +#' starting and end points from 12 o'clock. The `NULL` default for `end`, +#' internally defaults to `start + 2 * pi`. +#' @param outer_guide,inner_guide Guides to display on the outside and inside +#' of the colour ring. Each guide can be specified using one of the following: +#' * A `` class object. +#' * A `` that returns a `` class object. +#' * A `` naming such function, without the `guide_` or +#' `primitive_` prefix. +#' @param nbin A positive `` determining how many colours to display. +#' @param reverse A `` whether to reverse continuous guides. +#' If `TRUE`, guides like colour bars are flipped. If `FALSE` (default), +#' the original order is maintained. +#' @param show_labels A `` indicating for which guide labels +#' should be shown. Can be one of `"outer"` (default), `"inner"`, `"both"` or +#' `"none"`. Note that labels can only be omitted if the related guide +#' has a label suppression mechanism. +#' @param ... Arguments forwarded to the `outer_guide` and `inner_guide` if +#' provided as functions or strings. +#' @inheritParams common_parameters +#' +#' @return A `` object. +#' @export +#' @family standalone guides +#' +#' @examples +#' # Rings works best with a cyclical palette +#' my_pal <- c("black", "tomato", "white", "dodgerblue", "black") +#' +#' p <- ggplot(mpg, aes(displ, hwy, colour = cty)) + +#' geom_point() + +#' scale_colour_gradientn(colours = my_pal) +#' +#' # Standard colour ring +#' p + guides(colour = "colour_ring") +#' +#' # As an arc +#' p + guides(colour = guide_colour_ring( +#' start = 1.25 * pi, end = 2.75 * pi +#' )) +#' +#' # Removing the inner tick marks +#' p + guides(colour = guide_colour_ring(inner_guide = "none")) +#' +#' # Include labels on the inner axis +#' p + guides(colour = guide_colour_ring(show_labels = "both")) +#' +#' # Passing an argument to inner/outer guides +#' p + guides(colour = guide_colour_ring(angle = 0)) +guide_colour_ring <- function( + title = waiver(), + key = "auto", + start = 0, + end = NULL, + outer_guide = "axis_custom", + inner_guide = "axis_custom", + nbin = 300, + reverse = FALSE, + show_labels = "outer", + theme = NULL, + position = waiver(), + available_aes = c("colour", "fill"), + ... +) { + show_labels <- arg_match0(show_labels, c("both", "inner", "outer", "none")) + show_labels <- list( + inner = show_labels %in% c("inner", "both"), + outer = show_labels %in% c("outer", "both") + ) + + coord <- coord_radial( + start = start, end = end, + expand = FALSE, inner.radius = 0.9 + ) + + new_compose( + list(inner = inner_guide, outer = outer_guide), + title = title, + coord = coord, + args = list(...), + key = key, + nbin = nbin, + reverse = reverse, + theme = theme, + show_labels = show_labels, + position = position, + available_aes = available_aes, + super = GuideColourRing + ) +} + +# Class ------------------------------------------------------------------- + +#' @export +#' @rdname gguidance_extensions +#' @format NULL +#' @usage NULL +GuideColourRing <- ggproto( + "GuideColourRing", Compose, + + params = new_params( + guides = list(), guide_params = list(), + key = NULL, angle = waiver(), coord = NULL, + nbin = 300, alpha = NA, reverse = FALSE, + show_labels = list(inner = FALSE, outer = TRUE) + ), + + train = function(self, params = self$params, scale, aesthetic = NULL, + title = waiver(), ...) { + params$guide_params$inner$position <- "theta.sec" + params$guide_params$outer$position <- "theta" + params <- Compose$train(params, scale, aesthetic, title, ...) + params <- ggproto_parent(Guide, self)$train(params, scale, aesthetic) + params + }, + + extract_key = function(scale, aesthetic, nbin, ...) { + standard_extract_key(scale, aesthetic, key_sequence(nbin)) + }, + + extract_decor = function(scale, aesthetic, ...) { + data_frame(!!aesthetic := scale$get_limits(), group = 1L) + }, + + get_layer_key = function(params, layers, data = NULL) { + params <- ring_xy(params, params$aesthetic) + + params <- Compose$get_layer_key(params, layers, data) + if (isTRUE(params$reverse)) { + params <- set_limits(params, rev(params$limits)) + } + + panels <- params$coord$setup_panel_params( + scale_x_continuous(limits = params$limits), + scale_y_continuous(limits = c(0, 1)) + ) + # Override parameters + panels$inner_radius <- c(0.5, 0.5) + panels$bbox <- params$bbox <- polar_bbox(panels$arc, 0, panels$inner_radius) + + params <- Compose$transform(params, params$coord, panels) + params$arc <- panels$arc %% (2 * pi) + params$decor <- coord_munch(params$coord, params$decor, panels, segment_length = 0.04) + params + }, + + build_frame = function(params, theme, size) { + theme$legend.frame <- theme$legend.frame %||% element_blank() + frame <- calc_element("legend.frame", theme) + if (is_blank(frame)) { + frame <- list(colour = NA, linewidth = 0) + } + decor <- params$decor + + x <- unit(decor$x, "npc") + y <- unit(decor$y, "npc") + + x <- unit.c(x, rev(x) - unit(sin(rev(decor$theta)) * size, "cm")) + y <- unit.c(y, rev(y) - unit(cos(rev(decor$theta)) * size, "cm")) + + if (abs(diff(params$coord$arc %% (2 * pi))) < 1e-2) { + id <- nrow(decor)[c(1, 1)] + } else { + id <- nrow(decor) * 2 + } + + polygonGrob( + x = x, y = y, id.lengths = id, + gp = gpar( + fill = NA, + col = frame$colour, + lwd = frame$linewidth * .pt, + lty = frame$linetype + ) + ) + }, + + build_arc = function(params, theme, size, frame) { + check_device("clippingPaths") + arc <- params$coord$arc + limits <- params$limits %||% range(params$key$.value) + theta <- rescale(params$key$.value, to = arc, from = limits) + difftheta <- diff(theta) + start <- c(arc[1], theta[-1] - 0.5 * difftheta) + end <- c(theta[-length(theta)] + 0.5 * difftheta, arc[2]) + + theta <- vec_interleave(start, start, end, end) + r <- rep(c(0, 1, 1, 0), length(start)) * size + + x <- rescale(0.5 * sin(theta) + 0.5, from = params$bbox$x) + y <- rescale(0.5 * cos(theta) + 0.5, from = params$bbox$y) + + x <- unit(x, "npc") - unit(sin(theta) * r, "cm") + y <- unit(y, "npc") - unit(cos(theta) * r, "cm") + + colour <- params$key$colour + ring <- polygonGrob( + x = x, y = y, id.lengths = rep(4, nrow(params$key)), + gp = gpar(fill = colour, col = colour, lwd = 1), + vp = viewport(clip = frame) + ) + gTree(children = gList(ring, frame)) + }, + + draw = function(self, theme, position = NULL, direction = NULL, + params = self$params) { + defaults <- .theme_defaults_colourbar + theme <- theme + params$theme + theme$legend.text.position <- "theta" + if (inherits(defaults$legend.ticks.length, "rel")) { + theme$legend.ticks.length <- theme$legend.ticks.length * + defaults$legend.ticks.length + defaults$legend.ticks.length <- NULL + } + theme <- replace_null(theme, !!!defaults) + width <- cm(calc_element("legend.key.width", theme)) + + # Draw inner guide + inner <- params$guide_params$inner + inner$stack_offset <- unit(width, "cm") + inner$draw_label <- isTRUE(params$show_labels$inner) + inner <- params$guides$inner$draw(theme, position, direction, params = inner) + + # Draw outer guide + outer <- params$guide_params$outer + outer$draw_label <- isTRUE(params$show_labels$outer) + outer <- params$guides$outer$draw(theme, position, direction, params = outer) + + # Draw ring + frame <- self$build_frame(params, theme, width) + ring <- self$build_arc(params, theme, width, frame) + + # Setup title + theme$legend.title <- setup_legend_title(theme) + title_elem <- list(title = calc_element("legend.title", theme)) + title_grob <- self$build_title(params$title, title_elem, params) + title_pos <- calc_element("legend.title.position", theme) %||% "top" + + margin <- ring_margin(params$arc, outer$offset, width + cm(inner$offset)) + background <- element_render(theme, "legend.background") + + size <- 5 * cm(calc_element("legend.key.size", theme)) + asp <- with(params$bbox, diff(y) / diff(x)) + gt <- gtable( + widths = unit(size * pmin(1 / asp, 1), "cm"), + heights = unit(size * pmin(asp, 1), "cm") + ) + gt <- gtable_add_grob(gt, ring, 1, 1, name = "ring", clip = "off") + gt <- gtable_add_grob(gt, inner, 1, 1, name = "inner", clip = "off") + gt <- gtable_add_grob(gt, outer, 1, 1, name = "outer", clip = "off") + gt <- gtable_add_padding(gt, margin) + gt <- self$add_title(gt, title_grob, title_pos, title_elem$title$hjust) + + gt <- gtable_add_padding(gt, calc_element("legend.margin", theme) %||% margin()) + + if (!is.zero(background)) { + gt <- gtable_add_grob( + gt, background, + name = "background", clip = "off", + t = 1, r = -1, b = -1, l = 1, z = -Inf + ) + } + + gt + } +) + +# Helpers ----------------------------------------------------------------- + +ring_xy <- function(params, aesthetic) { + if ("guide_params" %in% names(params)) { + params$guide_params <- lapply(params$guide_params, ring_xy, aesthetic = aesthetic) + } + key <- params$key + if (!is.null(key)) { + key$x <- key$x %||% key$.value %||% key[[aesthetic]] + key$y <- key$y %||% 1 + params$key <- key + } + decor <- params$decor + if (!is.null(decor)) { + decor$x <- decor$x %||% decor$.value %||% decor[[aesthetic]] + decor$y <- decor$y %||% 1 + params$decor <- decor + } + params +} + +ring_margin <- function(arc, outer = NULL, inner = NULL) { + + outer <- cm(outer %||% unit(0, "cm")) + + # If we have a full circle, apply outer padding to every margin + if (abs(diff(arc)) >= 2 * pi) { + return(unit(rep(outer, 4), "cm")) + } + + tol <- c(1, -1) * sqrt(.Machine$double.eps) + margin <- rep(0, 4) + inner <- cm(inner %||% unit(0, "cm")) + + # Left margin + if (in_arc(1.5 * pi, arc)) { + margin[4] <- outer + } else if (any(keep <- in_range(arc, c(1, 2) * pi + tol))) { + theta <- arc[keep] + margin[4] <- max(abs(cos(theta))) * outer + } else if (all(in_range(arc, c(0, 1) * pi + tol))) { + margin[4] <- max(cos(arc)) * inner + } + + # Right margin + if (in_arc(0.5 * pi, arc)) { + margin[2] <- outer + } else if (any(keep <- in_range(arc, c(0, 1) * pi + tol))) { + theta <- arc[keep] + margin[2] <- max(abs(cos(theta))) * outer + } else if (all(in_range(arc, c(1, 2) * pi + tol))) { + margin[2] <- max(cos(arc)) * inner + } + + # Bottom margin + if (in_arc(pi, arc)) { + margin[3] <- outer + } else if (any(keep <- in_range(arc, c(0.5, 1.5) * pi + tol))) { + theta <- arc[keep] + margin[3] <- max(abs(sin(theta))) * outer + } else if (all(in_arc(arc, c(1.5, 2.5) * pi + tol))) { + margin[3] <- max(sin(arc)) * inner + } + + # Top margin + if (in_arc(0, arc)) { + margin[1] <- outer + } else if (any( + keep <- + in_range(arc, c(0, 0.5) * pi + c(0, tol[2])) | + in_range(arc, c(1.5, 2) * pi + c(tol[1], 0)) + )) { + theta <- arc[keep] + margin[1] <- max(abs(sin(theta))) * outer + } else if (all(in_arc(arc, c(0.5, 1.5) * pi + tol))) { + margin[1] <- max(-sin(arc)) * inner + } + + unit(margin, "cm") +} + diff --git a/R/utils.R b/R/utils.R index 32f77ac..c121a1d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -108,6 +108,11 @@ is_oob <- function(x, limits) { x < limits[1] | x > limits[2] } +in_range <- function(x, range) { + range <- sort(range) + x >= range[1] & x <= range[2] +} + polar_xy <- function(data, r, theta, bbox) { data$x <- rescale(r * sin(theta) + 0.5, from = bbox$x) data$y <- rescale(r * cos(theta) + 0.5, from = bbox$y) From bf40f8946ccaa656ae5a1820904ed5df84de07e8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 18:39:14 +0200 Subject: [PATCH 11/14] use typical element setup --- R/guide_colour_ring.R | 94 ++++++++++++++++++++++++-------------- R/guide_colourbar_custom.R | 3 +- 2 files changed, 62 insertions(+), 35 deletions(-) diff --git a/R/guide_colour_ring.R b/R/guide_colour_ring.R index 213a572..d56bf54 100644 --- a/R/guide_colour_ring.R +++ b/R/guide_colour_ring.R @@ -116,6 +116,16 @@ GuideColourRing <- ggproto( show_labels = list(inner = FALSE, outer = TRUE) ), + elements = list( + frame = "legend.frame", + size = "legend.key.size", + width = "legend.key.width", + background = "legend.background", + title = "legend.title", + title_position = "legend.title.position", + margin = "legend.margin" + ), + train = function(self, params = self$params, scale, aesthetic = NULL, title = waiver(), ...) { params$guide_params$inner$position <- "theta.sec" @@ -155,9 +165,8 @@ GuideColourRing <- ggproto( params }, - build_frame = function(params, theme, size) { - theme$legend.frame <- theme$legend.frame %||% element_blank() - frame <- calc_element("legend.frame", theme) + build_frame = function(params, elements) { + frame <- elements$frame if (is_blank(frame)) { frame <- list(colour = NA, linewidth = 0) } @@ -166,8 +175,8 @@ GuideColourRing <- ggproto( x <- unit(decor$x, "npc") y <- unit(decor$y, "npc") - x <- unit.c(x, rev(x) - unit(sin(rev(decor$theta)) * size, "cm")) - y <- unit.c(y, rev(y) - unit(cos(rev(decor$theta)) * size, "cm")) + x <- unit.c(x, rev(x) - unit(sin(rev(decor$theta)) * elements$width, "cm")) + y <- unit.c(y, rev(y) - unit(cos(rev(decor$theta)) * elements$width, "cm")) if (abs(diff(params$coord$arc %% (2 * pi))) < 1e-2) { id <- nrow(decor)[c(1, 1)] @@ -186,7 +195,7 @@ GuideColourRing <- ggproto( ) }, - build_arc = function(params, theme, size, frame) { + build_arc = function(params, elements, frame) { check_device("clippingPaths") arc <- params$coord$arc limits <- params$limits %||% range(params$key$.value) @@ -196,7 +205,7 @@ GuideColourRing <- ggproto( end <- c(theta[-length(theta)] + 0.5 * difftheta, arc[2]) theta <- vec_interleave(start, start, end, end) - r <- rep(c(0, 1, 1, 0), length(start)) * size + r <- rep(c(0, 1, 1, 0), length(start)) * elements$width x <- rescale(0.5 * sin(theta) + 0.5, from = params$bbox$x) y <- rescale(0.5 * cos(theta) + 0.5, from = params$bbox$y) @@ -213,8 +222,30 @@ GuideColourRing <- ggproto( gTree(children = gList(ring, frame)) }, + setup_elements = function(params, elements, theme) { + elements$title <- setup_legend_title(theme, params$direction) + Guide$setup_elements(params, elements, theme) + }, + + override_elements = function(params, elements, theme) { + elements$title_position <- elements$title_position %||% + switch(params$direction, horizontal = "left", vertical = "top") + check_position(elements$title_position, .trbl, arg = "legend.title.position") + elements$width <- cm(elements$width) + elements$size <- cm(elements$size) * 5 + elements$margin <- elements$margin %||% margin() + elements$background <- element_grob(elements$background) + elements + }, + draw = function(self, theme, position = NULL, direction = NULL, params = self$params) { + + position <- params$position <- params$position %||% position + direction <- params$direction <- params$direction %||% direction + check_position(position, .trbl) + check_argmatch(direction, c("horizontal", "vertical")) + defaults <- .theme_defaults_colourbar theme <- theme + params$theme theme$legend.text.position <- "theta" @@ -224,11 +255,12 @@ GuideColourRing <- ggproto( defaults$legend.ticks.length <- NULL } theme <- replace_null(theme, !!!defaults) - width <- cm(calc_element("legend.key.width", theme)) + elems <- self$setup_elements(params, self$elements, theme) + elems <- self$override_elements(params, elems, theme) # Draw inner guide inner <- params$guide_params$inner - inner$stack_offset <- unit(width, "cm") + inner$stack_offset <- unit(elems$width, "cm") inner$draw_label <- isTRUE(params$show_labels$inner) inner <- params$guides$inner$draw(theme, position, direction, params = inner) @@ -238,35 +270,29 @@ GuideColourRing <- ggproto( outer <- params$guides$outer$draw(theme, position, direction, params = outer) # Draw ring - frame <- self$build_frame(params, theme, width) - ring <- self$build_arc(params, theme, width, frame) - - # Setup title - theme$legend.title <- setup_legend_title(theme) - title_elem <- list(title = calc_element("legend.title", theme)) - title_grob <- self$build_title(params$title, title_elem, params) - title_pos <- calc_element("legend.title.position", theme) %||% "top" - - margin <- ring_margin(params$arc, outer$offset, width + cm(inner$offset)) - background <- element_render(theme, "legend.background") + frame <- self$build_frame(params, elems) + ring <- self$build_arc(params, elems, frame) - size <- 5 * cm(calc_element("legend.key.size", theme)) + # Setup gtable asp <- with(params$bbox, diff(y) / diff(x)) gt <- gtable( - widths = unit(size * pmin(1 / asp, 1), "cm"), - heights = unit(size * pmin(asp, 1), "cm") - ) - gt <- gtable_add_grob(gt, ring, 1, 1, name = "ring", clip = "off") - gt <- gtable_add_grob(gt, inner, 1, 1, name = "inner", clip = "off") - gt <- gtable_add_grob(gt, outer, 1, 1, name = "outer", clip = "off") - gt <- gtable_add_padding(gt, margin) - gt <- self$add_title(gt, title_grob, title_pos, title_elem$title$hjust) - - gt <- gtable_add_padding(gt, calc_element("legend.margin", theme) %||% margin()) - - if (!is.zero(background)) { + widths = unit(elems$size * pmin(1 / asp, 1), "cm"), + heights = unit(elems$size * pmin(asp, 1), "cm") + ) |> + gtable_add_grob(ring, 1, 1, name = "ring", clip = "off") |> + gtable_add_grob(inner, 1, 1, name = "inner", clip = "off") |> + gtable_add_grob(outer, 1, 1, name = "outer", clip = "off") + + # Add padding, title, margin and background + margin <- ring_margin(params$arc, outer$offset, elems$width + cm(inner$offset)) + title <- self$build_title(params$title, elems) + gt <- gtable_add_padding(gt, margin) |> + self$add_title(title, elems$title_position, elems$title$hjust) |> + gtable_add_padding(elems$margin) + + if (!is.zero(elems$background)) { gt <- gtable_add_grob( - gt, background, + gt, elems$background, name = "background", clip = "off", t = 1, r = -1, b = -1, l = 1, z = -Inf ) diff --git a/R/guide_colourbar_custom.R b/R/guide_colourbar_custom.R index 3b92eed..50c6cab 100644 --- a/R/guide_colourbar_custom.R +++ b/R/guide_colourbar_custom.R @@ -113,5 +113,6 @@ guide_colourbar_custom <- function( .theme_defaults_colourbar <- theme( legend.axis.line = element_blank(), legend.ticks = element_line(colour = "white", linewidth = 0.5 / .pt), - legend.ticks.length = rel(-1) + legend.ticks.length = rel(-1), + legend.frame = element_blank() ) From b969febe7caef4e33c733ec72b8468decc2a3747 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 18:40:06 +0200 Subject: [PATCH 12/14] document --- NAMESPACE | 2 + man/gguidance-package.Rd | 2 + man/gguidance_extensions.Rd | 11 ++-- man/guide_axis_custom.Rd | 1 + man/guide_colour_ring.Rd | 110 ++++++++++++++++++++++++++++++++ man/guide_colourbar_custom.Rd | 1 + man/guide_coloursteps_custom.Rd | 1 + man/guide_subtitle.Rd | 1 + 8 files changed, 124 insertions(+), 5 deletions(-) create mode 100644 man/guide_colour_ring.Rd diff --git a/NAMESPACE b/NAMESPACE index 88ff469..3bd1ff1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ export(GizmoDensity) export(GizmoGrob) export(GizmoHistogram) export(GizmoStepcap) +export(GuideColourRing) export(GuideSubtitle) export(PrimitiveBox) export(PrimitiveBracket) @@ -40,6 +41,7 @@ export(gizmo_grob) export(gizmo_histogram) export(gizmo_stepcap) export(guide_axis_custom) +export(guide_colour_ring) export(guide_colourbar_custom) export(guide_coloursteps_custom) export(guide_subtitle) diff --git a/man/gguidance-package.Rd b/man/gguidance-package.Rd index beedb89..370c1e2 100644 --- a/man/gguidance-package.Rd +++ b/man/gguidance-package.Rd @@ -6,6 +6,8 @@ \alias{gguidance-package} \title{gguidance: Extended guide options for 'ggplot2'} \description{ +\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} + A 'ggplot2' extension that focusses on expanding the plotter's arsenal of guides, such as axes, legends and colour bars. } \seealso{ diff --git a/man/gguidance_extensions.Rd b/man/gguidance_extensions.Rd index 3e3e399..6f3c2a5 100644 --- a/man/gguidance_extensions.Rd +++ b/man/gguidance_extensions.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/compose-.R, R/compose-crux.R, % R/compose-ontop.R, R/compose-sandwich.R, R/compose-stack.R, -% R/gguidance-package.R, R/gizmo-barcap.R, R/gizmo-density.R, -% R/gizmo-grob.R, R/gizmo-histogram.R, R/gizmo-stepcap.R, R/guide_subtitle.R, -% R/primitive-box.R, R/primitive-bracket.R, R/primitive-labels.R, -% R/primitive-line.R, R/primitive-spacer.R, R/primitive-ticks.R, -% R/primitive-title.R +% R/gguidance-package.R, R/gizmo-barcap.R, R/gizmo-density.R, R/gizmo-grob.R, +% R/gizmo-histogram.R, R/gizmo-stepcap.R, R/guide_colour_ring.R, +% R/guide_subtitle.R, R/primitive-box.R, R/primitive-bracket.R, +% R/primitive-labels.R, R/primitive-line.R, R/primitive-spacer.R, +% R/primitive-ticks.R, R/primitive-title.R \docType{data} \name{Compose} \alias{Compose} @@ -19,6 +19,7 @@ \alias{GizmoGrob} \alias{GizmoHistogram} \alias{GizmoStepcap} +\alias{GuideColourRing} \alias{GuideSubtitle} \alias{PrimitiveBox} \alias{PrimitiveBracket} diff --git a/man/guide_axis_custom.Rd b/man/guide_axis_custom.Rd index 9512f2b..fc2484a 100644 --- a/man/guide_axis_custom.Rd +++ b/man/guide_axis_custom.Rd @@ -123,6 +123,7 @@ ggplot(msleep, aes(bodywt, brainwt)) + } \seealso{ Other standalone guides: +\code{\link{guide_colour_ring}()}, \code{\link{guide_colourbar_custom}()}, \code{\link{guide_coloursteps_custom}()}, \code{\link{guide_subtitle}()} diff --git a/man/guide_colour_ring.Rd b/man/guide_colour_ring.Rd new file mode 100644 index 0000000..f17f810 --- /dev/null +++ b/man/guide_colour_ring.Rd @@ -0,0 +1,110 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide_colour_ring.R +\name{guide_colour_ring} +\alias{guide_colour_ring} +\title{Colour rings and arcs} +\usage{ +guide_colour_ring( + title = waiver(), + key = "auto", + start = 0, + end = NULL, + outer_guide = "axis_custom", + inner_guide = "axis_custom", + nbin = 300, + reverse = FALSE, + show_labels = "outer", + theme = NULL, + position = waiver(), + available_aes = c("colour", "fill"), + ... +) +} +\arguments{ +\item{title}{A \verb{} or \verb{} indicating the title of +the guide. If \code{NULL}, the title is not shown. The default, +\code{\link[ggplot2:waiver]{waiver()}}, takes the name of the scale object or +the name specified in \code{\link[ggplot2:labs]{labs()}} as the title.} + +\item{key}{A \link[=key_standard]{standard key} specification. Defaults to +\code{\link[=key_auto]{key_auto()}}.} + +\item{start, end}{A \verb{} in radians specifying the offset of the +starting and end points from 12 o'clock. The \code{NULL} default for \code{end}, +internally defaults to \code{start + 2 * pi}.} + +\item{outer_guide, inner_guide}{Guides to display on the outside and inside +of the colour ring. Each guide can be specified using one of the following: +\itemize{ +\item A \verb{} class object. +\item A \verb{} that returns a \verb{} class object. +\item A \verb{} naming such function, without the \code{guide_} or +\code{primitive_} prefix. +}} + +\item{nbin}{A positive \verb{} determining how many colours to display.} + +\item{reverse}{A \verb{} whether to reverse continuous guides. +If \code{TRUE}, guides like colour bars are flipped. If \code{FALSE} (default), +the original order is maintained.} + +\item{show_labels}{A \verb{} indicating for which guide labels +should be shown. Can be one of \code{"outer"} (default), \code{"inner"}, \code{"both"} or +\code{"none"}. Note that labels can only be omitted if the related guide +has a label suppression mechanism.} + +\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.} + +\item{position}{A \verb{} giving the location of the guide. Can be one of \code{"top"}, +\code{"bottom"}, \code{"left"} or \code{"right"}.} + +\item{available_aes}{A \verb{} vector listing the aesthetics for which this guide can +be build.} + +\item{...}{Arguments forwarded to the \code{outer_guide} and \code{inner_guide} if +provided as functions or strings.} +} +\value{ +A \verb{} object. +} +\description{ +Similar to \code{\link[ggplot2:guide_colourbar]{guide_colourbar()}}, this guide +displays continuous \code{colour} or \code{fill} aesthetics. Instead of a bar, the +gradient in shown in a ring or arc, which can be convenient for cyclical +palettes such as some provided in the \pkg{scico} package. +} +\examples{ +# Rings works best with a cyclical palette +my_pal <- c("black", "tomato", "white", "dodgerblue", "black") + +p <- ggplot(mpg, aes(displ, hwy, colour = cty)) + + geom_point() + + scale_colour_gradientn(colours = my_pal) + +# Standard colour ring +p + guides(colour = "colour_ring") + +# As an arc +p + guides(colour = guide_colour_ring( + start = 1.25 * pi, end = 2.75 * pi +)) + +# Removing the inner tick marks +p + guides(colour = guide_colour_ring(inner_guide = "none")) + +# Include labels on the inner axis +p + guides(colour = guide_colour_ring(show_labels = "both")) + +# Passing an argument to inner/outer guides +p + guides(colour = guide_colour_ring(angle = 0)) +} +\seealso{ +Other standalone guides: +\code{\link{guide_axis_custom}()}, +\code{\link{guide_colourbar_custom}()}, +\code{\link{guide_coloursteps_custom}()}, +\code{\link{guide_subtitle}()} +} +\concept{standalone guides} diff --git a/man/guide_colourbar_custom.Rd b/man/guide_colourbar_custom.Rd index cf9214c..0f705b0 100644 --- a/man/guide_colourbar_custom.Rd +++ b/man/guide_colourbar_custom.Rd @@ -151,6 +151,7 @@ ggplot(msleep, aes(sleep_total, sleep_rem)) + \seealso{ Other standalone guides: \code{\link{guide_axis_custom}()}, +\code{\link{guide_colour_ring}()}, \code{\link{guide_coloursteps_custom}()}, \code{\link{guide_subtitle}()} } diff --git a/man/guide_coloursteps_custom.Rd b/man/guide_coloursteps_custom.Rd index 9ec4a7f..693ca6c 100644 --- a/man/guide_coloursteps_custom.Rd +++ b/man/guide_coloursteps_custom.Rd @@ -148,6 +148,7 @@ p + scale_colour_viridis_b( \seealso{ Other standalone guides: \code{\link{guide_axis_custom}()}, +\code{\link{guide_colour_ring}()}, \code{\link{guide_colourbar_custom}()}, \code{\link{guide_subtitle}()} } diff --git a/man/guide_subtitle.Rd b/man/guide_subtitle.Rd index e29aa67..701c7a6 100644 --- a/man/guide_subtitle.Rd +++ b/man/guide_subtitle.Rd @@ -99,6 +99,7 @@ p + guides(colour = guide_subtitle( \seealso{ Other standalone guides: \code{\link{guide_axis_custom}()}, +\code{\link{guide_colour_ring}()}, \code{\link{guide_colourbar_custom}()}, \code{\link{guide_coloursteps_custom}()} } From 4b05c6bbc5fbcd9dfc5ef615b9b82ebc9ee563c7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 18:40:17 +0200 Subject: [PATCH 13/14] write tests --- .../_snaps/guide_colour_ring/conical.svg | 140 ++++++++++++++++++ .../_snaps/guide_colour_ring/inner-labels.svg | 140 ++++++++++++++++++ .../_snaps/guide_colour_ring/open-ring.svg | 139 +++++++++++++++++ .../_snaps/guide_colour_ring/resized-ring.svg | 140 ++++++++++++++++++ .../guide_colour_ring/standard-ring.svg | 140 ++++++++++++++++++ tests/testthat/test-guide_colour_ring.R | 95 ++++++++++++ 6 files changed, 794 insertions(+) create mode 100644 tests/testthat/_snaps/guide_colour_ring/conical.svg create mode 100644 tests/testthat/_snaps/guide_colour_ring/inner-labels.svg create mode 100644 tests/testthat/_snaps/guide_colour_ring/open-ring.svg create mode 100644 tests/testthat/_snaps/guide_colour_ring/resized-ring.svg create mode 100644 tests/testthat/_snaps/guide_colour_ring/standard-ring.svg create mode 100644 tests/testthat/test-guide_colour_ring.R diff --git a/tests/testthat/_snaps/guide_colour_ring/conical.svg b/tests/testthat/_snaps/guide_colour_ring/conical.svg new file mode 100644 index 0000000..3a75a15 --- /dev/null +++ b/tests/testthat/_snaps/guide_colour_ring/conical.svg @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +drat + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 + +conical + + diff --git a/tests/testthat/_snaps/guide_colour_ring/inner-labels.svg b/tests/testthat/_snaps/guide_colour_ring/inner-labels.svg new file mode 100644 index 0000000..7d60d09 --- /dev/null +++ b/tests/testthat/_snaps/guide_colour_ring/inner-labels.svg @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +drat + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 + + + + + + +inner labels + + diff --git a/tests/testthat/_snaps/guide_colour_ring/open-ring.svg b/tests/testthat/_snaps/guide_colour_ring/open-ring.svg new file mode 100644 index 0000000..fda9773 --- /dev/null +++ b/tests/testthat/_snaps/guide_colour_ring/open-ring.svg @@ -0,0 +1,139 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +drat + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 + +open ring + + diff --git a/tests/testthat/_snaps/guide_colour_ring/resized-ring.svg b/tests/testthat/_snaps/guide_colour_ring/resized-ring.svg new file mode 100644 index 0000000..bbb40c0 --- /dev/null +++ b/tests/testthat/_snaps/guide_colour_ring/resized-ring.svg @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +drat + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 + +resized ring + + diff --git a/tests/testthat/_snaps/guide_colour_ring/standard-ring.svg b/tests/testthat/_snaps/guide_colour_ring/standard-ring.svg new file mode 100644 index 0000000..fac9848 --- /dev/null +++ b/tests/testthat/_snaps/guide_colour_ring/standard-ring.svg @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + +drat + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 + +standard ring + + diff --git a/tests/testthat/test-guide_colour_ring.R b/tests/testthat/test-guide_colour_ring.R new file mode 100644 index 0000000..7b67e3f --- /dev/null +++ b/tests/testthat/test-guide_colour_ring.R @@ -0,0 +1,95 @@ +test_that("guide_colour_ring looks as it should", { + + # vdiffr's device doesn't support clipping paths yet, so we just ignore + # warnings for now + expect_doppelganger <- function(...) { + suppressWarnings(vdiffr::expect_doppelganger(...)) + } + + p <- ggplot(mtcars, aes(disp, mpg, colour = drat)) + + geom_point() + + theme( + legend.frame = element_rect(colour = "tomato"), + legend.background = element_rect(colour = "limegreen") + ) + + outline <- compose_stack("axis_custom", primitive_line(theme = theme( + legend.axis.line = element_line(colour = "dodgerblue") + )), theme = theme(gguidance.guide.spacing = unit(0, "cm"))) + + standard_ring <- guides(colour = guide_colour_ring( + nbin = 15, outer_guide = outline, inner_guide = outline + )) + + pring <- p + standard_ring + + expect_doppelganger( + "standard ring", pring + ) + + pring <- p + guides(colour = guide_colour_ring( + nbin = 15, outer_guide = outline, inner_guide = outline, show_labels = "inner" + )) + + expect_doppelganger( + "inner labels", pring + ) + + pring <- p + standard_ring + theme( + legend.key.size = unit(2, "lines"), + legend.key.width = unit(5, "mm") + ) + + expect_doppelganger( + "resized ring", pring + ) + + pring <- p + standard_ring + theme(legend.key.width = rel(2.5)) + + expect_doppelganger( + "conical", pring + ) + + pring <- p + guides(colour = guide_colour_ring( + nbin = 15, outer_guide = outline, inner_guide = outline, + start = 0.25 * pi, end = 1.75 * pi + )) + + expect_doppelganger( + "open ring", pring + ) +}) + +test_that("ring_margin calculates margins correctly", { + + # Full ring should have outer margins everywhere + test <- ring_margin(c(0, 2) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(2, 2, 2, 2)) + + test <- ring_margin(c(0, 1) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(2, 2, 2, 0)) + + test <- ring_margin(c(0.5, 1.5) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(0, 2, 2, 2)) + + test <- ring_margin(c(1, 2) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(2, 0, 2, 2)) + + test <- ring_margin(c(1.5, 0.5) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(2, 2, 0, 2)) + + s2 <- sqrt(2) + + test <- ring_margin(c(0.25, 0.75) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(s2, 2, s2, s2 / 2)) + + test <- ring_margin(c(0.75, 1.25) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(s2 / 2, s2, 2, s2)) + + test <- ring_margin(c(1.25, 1.75) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(s2, s2 / 2, s2, 2)) + + test <- ring_margin(c(1.75, 0.25) * pi, outer = 2, inner = 1) + expect_equal(as.numeric(test), c(2, s2, s2 / 2, s2)) + +}) From 76e98018c16331009d19078855b8c76f7622a583 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 27 Apr 2024 18:41:52 +0200 Subject: [PATCH 14/14] add news bullet --- NEWS.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index da88eec..59eb05e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -14,8 +14,9 @@ Full guides are guides that you can just drop in the `guides()` function or as `guide` argument to scales. * `guide_axis_custom()` as an axis guide. -* `guide_colourbar_custom()` as a colour/fill guide. -* `guide_coloursteps_custom()` as a colour/fill guide. +* `guide_colourbar_custom()` as a continuous colour/fill guide. +* `guide_coloursteps_custom()` as a binned colour/fill guide. +* `guide_colour_ring()` as a continuous colour/fill guide. * `guide_subtitle()` as a colour/fill guide. ## Gizmos