From dd9e0602f79e31f5c5f0c903273f55ff19ab0b63 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Sun, 8 Dec 2024 14:33:31 +0100 Subject: [PATCH] Dendrograms (#34) * allow rels as units * draft new primitive guide * draft segment keys * document segment keys * rename `label_args()` to `extra_args()` * add segment key tests * document segments primitive * allow for sensible `oppo` parameter in keys * little bit of tuning * add tests for `primitive_segments()` * fix links in docs * allow for `key = ` in `primitive_segments()` * Add dendrogram guide * fix bug in r-axis when `coord_radial(theta = "y")` * add dendrogram scales * add news bullet * update pkgdown yaml * R CMD Check compliance * add piece about dendrograms --- NAMESPACE | 7 + NEWS.md | 7 + R/guide_axis_dendro.R | 77 ++++++ R/key-.R | 8 +- R/key-range.R | 4 +- R/key-segment.R | 204 ++++++++++++++ R/primitive-.R | 10 +- R/primitive-segments.R | 258 ++++++++++++++++++ R/scale_dendro.R | 162 +++++++++++ R/utils-checks.R | 6 +- R/utils-text.R | 21 -- R/utils.R | 22 ++ _pkgdown.yml | 1 + man/guide_axis_base.Rd | 1 + man/guide_axis_dendro.Rd | 124 +++++++++ man/guide_axis_nested.Rd | 1 + man/guide_colbar.Rd | 1 + man/guide_colring.Rd | 1 + man/guide_colsteps.Rd | 1 + man/guide_legend_base.Rd | 1 + man/guide_legend_cross.Rd | 1 + man/guide_legend_group.Rd | 1 + man/key_group.Rd | 1 + man/key_range.Rd | 1 + man/key_segments.Rd | 79 ++++++ man/key_specialty.Rd | 1 + man/key_standard.Rd | 1 + man/primitive_box.Rd | 1 + man/primitive_bracket.Rd | 1 + man/primitive_fence.Rd | 1 + man/primitive_labels.Rd | 1 + man/primitive_line.Rd | 1 + man/primitive_segments.Rd | 94 +++++++ man/primitive_spacer.Rd | 1 + man/primitive_ticks.Rd | 1 + man/primitive_title.Rd | 1 + man/scale_x_dendro.Rd | 145 ++++++++++ .../primitive-segments-cartesian.svg | 63 +++++ .../primitive-segments-legend.svg | 97 +++++++ .../primitive-segments-radial.svg | 63 +++++ .../scale_dendro/scale-dendro-cartesian.svg | 96 +++++++ .../scale_dendro/scale-dendro-radial.svg | 100 +++++++ tests/testthat/test-key-segment.R | 48 ++++ tests/testthat/test-primitive-segments.R | 67 +++++ tests/testthat/test-scale_dendro.R | 60 ++++ vignettes/articles/tour.Rmd | 43 +++ 46 files changed, 1852 insertions(+), 34 deletions(-) create mode 100644 R/guide_axis_dendro.R create mode 100644 R/key-segment.R create mode 100644 R/primitive-segments.R create mode 100644 R/scale_dendro.R create mode 100644 man/guide_axis_dendro.Rd create mode 100644 man/key_segments.Rd create mode 100644 man/primitive_segments.Rd create mode 100644 man/scale_x_dendro.Rd create mode 100644 tests/testthat/_snaps/primitive-segments/primitive-segments-cartesian.svg create mode 100644 tests/testthat/_snaps/primitive-segments/primitive-segments-legend.svg create mode 100644 tests/testthat/_snaps/primitive-segments/primitive-segments-radial.svg create mode 100644 tests/testthat/_snaps/scale_dendro/scale-dendro-cartesian.svg create mode 100644 tests/testthat/_snaps/scale_dendro/scale-dendro-radial.svg create mode 100644 tests/testthat/test-key-segment.R create mode 100644 tests/testthat/test-primitive-segments.R create mode 100644 tests/testthat/test-scale_dendro.R diff --git a/NAMESPACE b/NAMESPACE index 5699443..3770794 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,6 +43,7 @@ export(gizmo_grob) export(gizmo_histogram) export(gizmo_stepcap) export(guide_axis_base) +export(guide_axis_dendro) export(guide_axis_nested) export(guide_colbar) export(guide_colring) @@ -52,6 +53,7 @@ export(guide_legend_cross) export(guide_legend_group) export(key_auto) export(key_bins) +export(key_dendro) export(key_group_lut) export(key_group_split) export(key_log) @@ -62,6 +64,8 @@ export(key_none) export(key_range_auto) export(key_range_manual) export(key_range_map) +export(key_segment_manual) +export(key_segment_map) export(key_sequence) export(new_compose) export(primitive_box) @@ -69,9 +73,12 @@ export(primitive_bracket) export(primitive_fence) export(primitive_labels) export(primitive_line) +export(primitive_segments) export(primitive_spacer) export(primitive_ticks) export(primitive_title) +export(scale_x_dendro) +export(scale_y_dendro) export(theme_guide) import(ggplot2) import(grid) diff --git a/NEWS.md b/NEWS.md index ce38181..196b18e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # legendry (development version) +* Added support for dendrograms (#33): + * New scale functions `scale_x_dendro()` and `scale_y_dendro()`. + * New full guide function: `guide_axis_dendro()`. + * New primitive guide function: `primitive_segments()` + * New key functions: `key_segment_manual()`, `key_segment_map()` and + `key_dendro()`. + * Fixed bug where `guide_axis_nested(key = key_range_auto(...))` produced duplicated labels (#31) diff --git a/R/guide_axis_dendro.R b/R/guide_axis_dendro.R new file mode 100644 index 0000000..d99dcd2 --- /dev/null +++ b/R/guide_axis_dendro.R @@ -0,0 +1,77 @@ +# Constructor ------------------------------------------------------------- + +#' Dendrogram guide +#' +#' This axis is a speciality axis for discrete data that has been +#' hierarchically clustered. Please be aware that the guide cannot affect the +#' scale limits, which should be set appropriately. This guide will give +#' misleading results when this step is skipped! +#' +#' @inheritParams primitive_segments +#' @inheritParams primitive_labels +#' @inheritParams common_parameters +#' @param ticks,axis_line Guides to use as ticks or axis lines. Defaults to +#' drawing no ticks or axis lines. Can be specified as one of the following: +#' * A `` class object. +#' * A `` that returns a `` class object. +#' * A `` naming such a function, without the `guide_` or +#' `primitive_` prefix. +#' @return A `` object. +#' @export +#' @family standalone guides +#' +#' @examples +#' # Hierarchically cluster data +#' clust <- hclust(dist(scale(mtcars)), "ave") +#' +#' # Using the guide along with appropriate limits +#' p <- ggplot(mtcars, aes(disp, rownames(mtcars))) + +#' geom_col() + +#' scale_y_discrete(limits = clust$labels[clust$order]) +#' +#' # Standard usage +#' p + guides(y = guide_axis_dendro(clust)) +#' +#' # Adding ticks and axis line +#' p + guides(y = guide_axis_dendro(clust, ticks = "ticks", axis_line = "line")) + +#' theme(axis.line = element_line()) +#' +#' # Controlling space allocated to dendrogram +#' p + guides(y = guide_axis_dendro(clust, space = unit(4, "cm"))) + +#' theme(axis.ticks.y.left = element_line("red")) +#' +#' # If want just the dendrograme, use `primitive_segments()` +#' p + guides(y = primitive_segments(clust), y.sec = "axis") +guide_axis_dendro <- function( + key = "dendro", title = waiver(), theme = NULL, + space = rel(10), vanish = TRUE, + n.dodge = 1, angle = waiver(), check.overlap = FALSE, + ticks = "none", axis_line = "none", + order = 0, position = waiver() +) { + + theme <- replace_null( + theme %||% theme(), + legendry.guide.spacing = unit(0, "cm") + ) + + labels <- primitive_labels( + angle = angle, + n.dodge = n.dodge, + check.overlap = check.overlap + ) + + dendro <- primitive_segments( + key = key, + space = space, + vanish = vanish + ) + + compose_stack( + axis_line, ticks, labels, dendro, + drop = c(3L, 4L), + title = title, theme = theme, order = order, + available_aes = c("any", "x", "y", "r", "theta"), + position = position + ) +} diff --git a/R/key-.R b/R/key-.R index 69406b4..757a5c1 100644 --- a/R/key-.R +++ b/R/key-.R @@ -87,7 +87,7 @@ key_auto <- function(...) { function(scale, aesthetic = NULL) { aesthetic <- aesthetic %||% scale$aesthetics[1] df <- Guide$extract_key(scale, aesthetic) - df <- data_frame0(df, !!!label_args(...)) + df <- data_frame0(df, !!!extra_args(...)) class(df) <- c("key_standard", "key_guide", class(df)) df } @@ -99,7 +99,7 @@ key_manual <- function(aesthetic, value = aesthetic, label = as.character(value), type = NULL, ...) { df <- data_frame0(aesthetic = aesthetic, value = value, - label = label, type = type, !!!label_args(...)) + label = label, type = type, !!!extra_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)) @@ -136,7 +136,7 @@ key_map <- function(data, ..., .call = caller_env()) { #' @rdname key_standard #' @export key_minor <- function(...) { - dots <- label_args(...) + dots <- extra_args(...) function(scale, aesthetic = NULL) { aesthetic <- aesthetic %||% scale$aesthetics[1] df <- GuideAxis$extract_key(scale, aesthetic, minor.ticks = TRUE) @@ -163,7 +163,7 @@ key_log <- function( force(prescale_base) force(negative_small) force(expanded) - dots <- label_args(...) + dots <- extra_args(...) call <- expr(key_log()) function(scale, aesthetic = NULL) { key <- log10_keys( diff --git a/R/key-range.R b/R/key-range.R index 2fb412f..1b7cc2c 100644 --- a/R/key-range.R +++ b/R/key-range.R @@ -84,7 +84,7 @@ key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE, ...) { check_bool(reverse) force(sep) force(reverse) - dots <- label_args(...) + dots <- extra_args(...) call <- current_call() fun <- function(scale, aesthetic = NULL) { range_from_label( @@ -102,7 +102,7 @@ key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE, ...) { key_range_manual <- function(start, end, name = NULL, level = NULL, ...) { df <- data_frame0( start = start, end = end, .label = name, .level = level, - !!!label_args(...) + !!!extra_args(...) ) check_columns(df, c("start", "end")) class(df) <- c("key_range", "key_guide", class(df)) diff --git a/R/key-segment.R b/R/key-segment.R new file mode 100644 index 0000000..8e28499 --- /dev/null +++ b/R/key-segment.R @@ -0,0 +1,204 @@ +#' Segment keys +#' +#' @description +#' These functions are helper functions for working with segment data as keys +#' in guides. They all share the goal of creating a guide key, but have +#' different methods: +#' +#' * `key_segment_manual()` directly uses user-provided vectors to set segments. +#' * `key_segment_map()` makes mappings from a `` to set segments. +#' * `key_dendro()` is a specialty case for coercing dendrogram data to segments. +#' Be aware that setting the key alone cannot affect the scale limits, and +#' will give misleading results when used incorrectly! +#' +#' @param value,value_end A vector that is interpreted to be along the scale +#' that the guide codifies. +#' @param oppo,oppo_end A vector that is interpreted to be orthogonal to the +#' `value` and `value_end` variables. +#' @param data A `` or similar object coerced by +#' [`fortify()`][ggplot2::fortify] to a ``, in which the `mapping` +#' argument is evaluated. +#' @param dendro A data structure that can be coerced to a dendrogram through +#' the [`as.dendrogram()`][stats::as.dendrogram()] function. When `NULL` +#' (default) an attempt is made to search for such data in the scale. +#' @param type A string, either `"rectangle"` or `"triangle"`, indicating the +#' shape of edges between nodes of the dendrogram. +#' @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. +#' For `key_segments_map()`, these *must* contain `value` and `oppo` mappings. +#' @param .call A [call][rlang::topic-error-call] to display in messages. +#' +#' @export +#' @name key_segments +#' @family keys +#' @return +#' For `key_segments_manual()` and `key_segments_map()`, a `` with +#' the `` class. +#' +#' @examples +#' # Giving vectors directly +#' key_segment_manual( +#' value = 0:1, value_end = 2:3, +#' oppo = 1:0, oppo_end = 3:2 +#' ) +#' +#' # Taking columns of a data frame +#' data <- data.frame(x = 0:1, y = 1:0, xend = 2:3, yend = 3:2) +#' key_segment_map(data, value = x, oppo = y, value_end = xend, oppo_end = yend) +#' +#' # Using dendrogram data +#' clust <- hclust(dist(USArrests), "ave") +#' key_dendro(clust)(scale_x_discrete()) +key_segment_manual <- function(value, oppo, value_end = value, + oppo_end = oppo, ...) { + df <- data_frame0( + value = value, oppo = oppo, + value_end = value_end, oppo_end = oppo_end, + !!!extra_args(..., .valid_args = .line_params) + ) + check_columns(df, c("value", "oppo")) + class(df) <- c("key_segment", "key_guide", class(df)) + df +} + +#' @rdname key_segments +#' @export +key_segment_map <- function(data, ..., .call = caller_env()) { + + mapping <- enquos(...) + mapping <- Filter(Negate(quo_is_missing), mapping) + mapping <- new_aes(mapping, env = .call) + + df <- eval_aes( + data, mapping, + required = c("value", "oppo"), + optional = c("value_end", "oppo_end", .line_params), + call = .call, arg_mapping = "mapping", arg_data = "data" + ) + + df$colour <- df$color + df$color <- NULL + df <- rename(df, .line_params, paste0(".", .line_params)) + class(df) <- c("key_segment", "key_guide", class(df)) + df + +} + +#' @rdname key_segments +#' @export +key_dendro <- function(dendro = NULL, type = "rectangle") { + force(dendro) + function(scale, aesthetic = NULL, ...) { + extract_dendro(scale$scale$clust %||% dendro, type = type) + } +} + +# Dendrogram utilities ---------------------------------------------------- + +# Simplified version of `stats:::plotNode`. +# It only looks for the segments and ignores labels and most other attributes. +extract_dendro <- function(tree, type = "rectangle") { + + # Check arguments + whole_tree <- tree <- try_fetch( + stats::as.dendrogram(tree), + error = function(cnd) { + cli::cli_abort("Could not find or coerce {.arg dendro} argument.", parent = cnd) + } + ) + type <- arg_match0(type, c("rectangle", "triangle")) + + # Initialise stuff + depth <- 0 + llimit <- list() + x1 <- i <- 1 + x2 <- number_of_members(tree) + KK <- kk <- integer() + + n_obs <- stats::nobs(tree) + n_segments <- switch(type, triangle = 2 * n_obs - 2, 4 * n_obs - 4) + + mtx <- matrix(NA_real_, n_segments, ncol = 4) + colnames(mtx) <- c("value", "oppo", "value_end", "oppo_end") + + repeat { + depth <- depth + 1 + inner <- !stats::is.leaf(tree) && x1 != x2 + + node <- node_limit(x1, x2, tree) + llimit[[depth]] <- node$limit + + ymax <- attr(tree, 'height') + xmax <- node$x + + if (inner) { + for (k in seq_along(tree)) { + child <- tree[[k]] + + ymin <- attr(child, "height") %||% 0 + xmin <- node$limit[k] + (attr(child, "midpoint") %||% 0) + + # Update segments + if (type == "triangle") { + mtx[i, ] <- c(xmax, ymax, xmin, ymin) + i <- i + 1 + } else { + mtx[i + 0:1, ] <- c(xmax, xmin, ymax, ymax, xmin, xmin, ymax, ymin) + i <- i + 2 + } + } + if (length(tree) > 0) { + KK[depth] <- length(tree) + kk[depth] <- 1L + x1 <- node$limit[1L] + x2 <- node$limit[2L] + tree <- tree[[1]] + } + } else { + repeat { + depth <- depth - 1L + if (!depth || kk[depth] < KK[depth]) { + break + } + } + if (!depth) { + break + } + length(kk) <- depth + kk[depth] <- k <- kk[depth] + 1L + x1 <- llimit[[depth]][k] + x2 <- llimit[[depth]][k + 1L] + tree <- whole_tree[[kk]] + } + } + as.data.frame(mtx) +} + +# Copy of `stats:::.memberDend()` +number_of_members <- function(tree) { + attr(tree, "x.member") %||% attr(tree, "members") %||% 1L +} + +# Simplified version of `stats:::plotNodeLimit`, +# It has `center = FALSE` build-in. +node_limit <- function(x1, x2, subtree) { + inner <- !stats::is.leaf(subtree) && x1 != x2 + if (inner) { + K <- length(subtree) + limit <- integer(K) + xx1 <- x1 + for (k in 1L:K) { + xx1 <- xx1 + number_of_members(subtree[[k]]) + limit[k] <- xx1 + } + } else { + limit <- x2 + } + limit <- c(x1, limit) + mid <- attr(subtree, "midpoint") + center <- inner && !is.numeric(mid) + x <- if (center) mean(c(x1, x2)) else x1 + (mid %||% 0) + list(x = x, limit = limit) +} + diff --git a/R/primitive-.R b/R/primitive-.R index cebeee6..9d91b9b 100644 --- a/R/primitive-.R +++ b/R/primitive-.R @@ -85,16 +85,18 @@ primitive_setup_params <- function(params) { if (!is_empty(params$key)) { key <- params$key value <- guide_rescale(key$.value, params$limits) - key$x <- key$x %||% switch(params$position, left = 1, right = 0, value) - key$y <- key$y %||% switch(params$position, bottom = 1, top = 0, value) + oppo <- key$oppo %||% as.numeric(params$position %in% c("left", "bottom")) + key$x <- key$x %||% switch(params$position, left = , right = oppo, value) + key$y <- key$y %||% switch(params$position, bottom = , top = oppo, value) params$key <- key } decor <- params$decor if (!is_empty(params$decor)) { decor <- params$decor - decor$x <- decor$x %||% switch(params$position, left = 1, right = 0, 0.5) - decor$y <- decor$y %||% switch(params$position, bottom = 1, top = 0, 0.5) + oppo <- decor$oppo %||% as.numeric(params$position %in% c("left", "bottom")) + decor$x <- decor$x %||% switch(params$position, left = , right = oppo, 0.5) + decor$y <- decor$y %||% switch(params$position, bottom = , top = oppo, 0.5) params$decor <- decor } params diff --git a/R/primitive-segments.R b/R/primitive-segments.R new file mode 100644 index 0000000..c9eb469 --- /dev/null +++ b/R/primitive-segments.R @@ -0,0 +1,258 @@ +# Constructor ------------------------------------------------------------- + +#' Guide primitives: segments +#' +#' This function constructs a [guide primitive][guide-primitives]. +#' +#' @param key A [segment key][key_segments] specification. See more information +#' in the linked topic. Alternatively, an object of class +#' [``][stats::hclust] that automatically invokes `key_dendro()`. +#' @param space Either a [``][grid::unit()] or [``][ggplot2::rel()] +#' object of length 1 determining the space allocated in the orthogonal +#' direction. When the `space` argument is of class `` (default) the +#' base size is taken from the tick length theme setting. +#' @param vanish Only relevant when the guide is used in the secondary theta +#' position: a `` on whether the continue to draw the segments +#' until they meed in the center (`TRUE`) or strictly observe the `space` +#' setting (`FALSE`). +#' @inheritParams common_parameters +#' +#' @return A `` primitive guide that can be used inside other +#' guides. +#' @family primitives +#' @export +#' +#' @details +#' # Styling options +#' +#' Below are the [theme][ggplot2::theme] options that determine the style of +#' this guide, which may differ depending on whether the guide is used in an +#' axis or in a legend context. +#' +#' ## As an axis guide +#' +#' * `axis.ticks.{x/y}.{position}` an [``][ggplot2::element_line] +#' for display of the segments. +#' * `axis.ticks.length.{x/y}.{position}` a [``][grid::unit] for the +#' base size of the segments in the orthogonal direction. +#' +#' ## As a legend guide +#' +#' * `legend.ticks` an [``][ggplot2::element_line] for display +#' of the segments. +#' * `legend.ticks.length` a [``][grid::unit] for the +#' base size of the segments in the orthogonal direction. +#' +#' @examples +#' # Building a key +#' key <- key_segment_manual( +#' value = c(1.6, 1.6, 3.4, 5.2), +#' value_end = c(7.0, 7.0, 3.4, 5.2), +#' oppo = c(1.0, 2.0, 0.0, 0.0), +#' oppo_end = c(1.0, 2.0, 3.0, 3.0) +#' ) +#' +#' # Using the primitive in a plot +#' ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' scale_x_continuous( +#' guide = primitive_segments(key = key) +#' ) +primitive_segments <- function(key = NULL, space = rel(10), vanish = FALSE, + theme = NULL, position = waiver()) { + check_unit(space, allow_rel = TRUE) + + if (inherits(key, "hclust")) { + key <- key_dendro(key) + } + + new_guide( + key = key, + space = space, + vanish = vanish, + theme = theme, + position = position, + available_aes = c("any", "x", "y", "r", "theta"), + super = PrimitiveSegments + ) +} + +# Class ------------------------------------------------------------------- + +PrimitiveSegments <- ggproto( + "PrimitiveSegments", Guide, + + params = new_params(key = NULL, space = rel(10), vanish = FALSE), + + hashables = exprs(key), + + elements = list( + position = list(line = "axis.ticks", size = "axis.ticks.length"), + legend = list(line = "legend.ticks", size = "legend.ticks.length") + ), + + extract_key = function(scale, aesthetic, key, ...) { + key <- standard_extract_key(scale, aesthetic, key, ...) + remove <- character() + if (all(c("value", "value_end") %in% names(key))) { + value <- vec_interleave(key$value, key$value_end) + remove <- c(remove, c("value", "value_end")) + } + if (all(c("oppo", "oppo_end") %in% names(key))) { + oppo <- vec_interleave(key$oppo, key$oppo_end) + remove <- c(remove, c("oppo", "oppo_end")) + } + key[remove] <- NULL + new <- data_frame0(value = value, oppo = oppo) + i <- rep(vec_seq_along(key), each = 2) + new[names(key)] <- key[i, , drop = FALSE] + new$group <- new$group %||% i + new$oppo <- rescale(new$oppo, from = range(new$oppo, 0)) + if (aesthetic == "x") { + new <- rename(new, c("value", "oppo"), c("x", "y")) + } else if (aesthetic == "y") { + new <- rename(new, c("value", "oppo"), c("y", "x")) + } else { + new <- rename(new, "value", aesthetic) + new$.value <- new[[aesthetic]] + } + new + }, + + extract_params = primitive_extract_params, + + transform = function(self, params, coord, panel_params) { + key <- params$key + position <- params$position + aesthetic <- params$aesthetic + mult <- 10 + + opposite <- setdiff(c("x", "y"), aesthetic) + is_radius <- "theta.range" %in% names(panel_params) & !is_theta(position) + if (is_radius) { + range <- panel_params$r.range + value <- squish_infinite(key[[aesthetic]], range) + value <- rescale(value, panel_params$inner_radius, range) + value <- rescale(value + 0.5, from = panel_params$bbox$x) + key[[aesthetic]] <- value + if (position == "left") { + key[[opposite]] <- 1 - key[[opposite]] + } + if (aesthetic == "x") { + key <- rename(key, c("x", "y"), c("y", "x")) + } + params$key <- key + return(params) + } + + range <- switch( + position, + top = , bottom = "y.range", + left = , right = "x.range", + theta = , theta.sec = "r.range" + ) + range <- panel_params[[range]] + + margin_lower <- function(value) range[1] - value * diff(range) / mult + margin_upper <- function(value) range[2] + value * diff(range) / mult + + key[[opposite]] <- switch( + position, + bottom = , theta.sec = , left = margin_lower(key[[opposite]]), + top = , theta = , right = margin_upper(key[[opposite]]), + key[[opposite]] + ) + + key <- coord_munch(coord, key, panel_params) + + key[[opposite]] <- switch( + position, + left = , bottom = key[[opposite]] * mult + 1, + top = , right = key[[opposite]] * mult - mult, + key[[opposite]] + ) + + if (!is_theta(position)) { + return(vec_assign(params, "key", list(key))) + } + + radius <- panel_params$inner_radius + if (position == "theta") { + key$adjust <- (key$r - radius[2]) * (2 * mult / radius[2]) + key$r <- radius[2] + } else { + key$adjust <- (key$r - radius[1]) / diff(radius) * -mult + key$r <- radius[1] + } + bbox <- panel_params$bbox + key$x <- rescale(key$r * sin(key$theta) + 0.5, from = bbox$x) + key$y <- rescale(key$r * cos(key$theta) + 0.5, from = bbox$y) + params$center <- c(rescale(0.5, from = bbox$x), rescale(0.5, from = bbox$y)) + + params$key <- key + params + }, + + setup_params = primitive_setup_params, + setup_elements = primitive_setup_elements, + override_elements = function(params, elements, theme) { + size <- params$space + if (is.rel(size)) { + size <- unclass(size) * elements$size + } + elements$size <- convertUnit(size, "cm", valueOnly = TRUE) + elements + }, + + build_ticks = function(key, elements, params, position = params$position) { + if (is_empty(key)) { + return(zeroGrob()) + } + + x <- unit(key$x, "npc") + y <- unit(key$y, "npc") + + if (is_theta(position)) { + vanish <- position == "theta.sec" && isTRUE(params$vanish) + theta <- key$theta + as.numeric(position == "theta.sec") * pi + offset <- elements$offset + + if (!vanish) { + offset <- key$adjust * elements$size + offset + } + if (any(offset != 0)) { + x <- x + unit(sin(theta) * offset, "cm") + y <- y + unit(cos(theta) * offset, "cm") + } + if (vanish) { + cx <- unit(params$center[1] * key$adjust, "npc") + cy <- unit(params$center[2] * key$adjust, "npc") + x <- (x * (1 - key$adjust)) + cx + y <- (y * (1 - key$adjust)) + cy + } + } + + element_grob( + elements$line, x = x, y = y, + id.lengths = vec_run_sizes(key$group) + ) + }, + + draw = function(self, theme, position = NULL, direction = NULL, + params = self$params) { + + params <- replace_null(params, position = position, direction = direction) + params <- self$setup_params(params) + + elems <- self$setup_elements(params, self$elements, theme) + elems <- self$override_elements(params, elems, theme) + segments <- self$build_ticks(params$key, elems, params) + + primitive_grob( + grob = segments, + size = unit(elems$size, "cm"), + position = params$position, + name = "segments" + ) + } +) diff --git a/R/scale_dendro.R b/R/scale_dendro.R new file mode 100644 index 0000000..82631ce --- /dev/null +++ b/R/scale_dendro.R @@ -0,0 +1,162 @@ +# Constructors ------------------------------------------------------------ + +#' Dendrogram scales +#' +#' These are speciality scales for use with hierarchically clustered data. The +#' scale automatically orders the limits according to the clustering result +#' and comes with a [dendrogram axis][guide_axis_dendro()]. +#' +#' @param clust A data structure that can be coerced to an +#' [``][stats::hclust] object through +#' [`as.hclust()`][stats::as.hclust]. +#' @inheritDotParams ggplot2::discrete_scale -scale_name -limits +#' @inheritParams ggplot2::scale_x_discrete +#' +#' @details +#' The scale limits are determined by the order and labels in the `clust` +#' argument. While `limits` is not an argument in these scales, the `breaks` +#' argument can still be used to selectively omit some breaks and the `labels` +#' can be used for formatting purposes. +#' +#' @return A `` object that can be added to a plot. +#' @seealso [guide_axis_dendro()] +#' @export +#' +#' @examples +#' # Hierarchically cluster data, separately for rows and columns +#' car_clust <- hclust(dist(scale(mtcars)), "ave") +#' var_clust <- hclust(dist(scale(t(mtcars))), "ave") +#' +#' long_mtcars <- data.frame( +#' car = rownames(mtcars)[row(mtcars)], +#' var = colnames(mtcars)[col(mtcars)], +#' value = as.vector(scale(mtcars)) +#' ) +#' +#' # A standard heatmap adorned with dendrograms +#' p <- ggplot(long_mtcars, aes(var, car, fill = value)) + +#' geom_tile() + +#' scale_x_dendro(var_clust) + +#' scale_y_dendro(car_clust) +#' p +#' +#' # Styling the dendrograms +#' p + +#' guides( +#' y = guide_axis_dendro(key_dendro(type = "triangle")), +#' x = guide_axis_dendro(space = rel(5)) +#' ) + +#' theme( +#' axis.text.y.left = element_text(margin = margin(r = 3, l = 3)), +#' axis.ticks.y = element_line("red"), +#' axis.ticks.x = element_line(linetype = "dotted") +#' ) +#' +#' # In polar coordinates, plus some formatting +#' p + +#' coord_radial( +#' theta = "y", inner.radius = 0.5, +#' start = 0.25 * pi, end = 1.75 * pi +#' ) + +#' guides( +#' theta = primitive_labels(angle = 90), +#' theta.sec = primitive_segments("dendro", vanish = TRUE), +#' r = guide_axis_dendro(angle = 0) +#' ) +scale_x_dendro <- function(clust, ..., expand = waiver(), guide = "axis_dendro", + position = "bottom") { + + clust <- validate_clust(clust) + limits <- validate_clust_limits(clust) + + args <- list2(...) + check_dendro_args(args) + + sc <- inject(discrete_scale( + aesthetics = c( + "x", "xmin", "xmax", "xend", "xintercept", + "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper", "x0" + ), + palette = pal_identity(), + scale_name = missing_arg(), + limits = limits, + !!!args, + guide = guide, + expand = expand, + position = position, + super = ScaleDiscretePosition + )) + sc$range_c <- ContinuousRange$new() + sc$clust <- clust + sc +} + +#' @rdname scale_x_dendro +#' @export +scale_y_dendro <- function(clust, ..., expand = waiver(), guide = "axis_dendro", + position = "left") { + clust <- validate_clust(clust) + limits <- validate_clust_limits(clust) + + args <- list2(...) + check_dendro_args(args) + + sc <- inject(discrete_scale( + aesthetics = c( + "y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", + "lower", "middle", "upper", "y0" + ), + palette = seq_len, + scale_name = missing_arg(), + limits = limits, + !!!args, + guide = guide, + expand = expand, + position = position, + super = ScaleDiscretePosition + )) + sc$range_c <- ContinuousRange$new() + sc$clust <- clust + sc +} + + +# Helpers ----------------------------------------------------------------- + +validate_clust <- function(clust, .call = caller_env()) { + try_fetch( + stats::as.hclust(clust), + error = function(cnd) { + cli::cli_abort( + "The {.arg clust} argument should be convertable to an {.cls hclust} + object.", parent = cnd, call = .call + ) + } + ) +} + +validate_clust_limits <- function(clust, .call = caller_env()) { + labels <- clust$labels %||% seq_along(clust$order) + labels <- labels[clust$order] + function(x) { + union(labels, x) + } +} + +check_dendro_args <- function(args, .call = caller_env()) { + if ("limits" %in% names(args)) { + cli::cli_abort( + "Function does not accept {.arg limits} argument: it is derived from the + labels and order in the {.arg clust} argument.", + call = .call + ) + } + if ("palette" %in% names(args)) { + cli::cli_abort( + "Function does not accept {.arg palette} argument: the scale requires + fixed spacing between items.", + call = .call + ) + } + invisible() +} diff --git a/R/utils-checks.R b/R/utils-checks.R index f96bd5b..264d63f 100644 --- a/R/utils-checks.R +++ b/R/utils-checks.R @@ -75,13 +75,13 @@ check_grob <- function(x, allow_null = FALSE, call = caller_env(), ) } -check_unit <- function(x, allow_null = FALSE, call = caller_env(), - arg = caller_arg(x)) { +check_unit <- function(x, allow_null = FALSE, allow_rel = FALSE, + call = caller_env(), arg = caller_arg(x)) { if (!missing(x)) { if (is.unit(x)) { return(invisible(NULL)) } - if (allow_null && is_null(x)) { + if (allow_null && is_null(x) || allow_rel && is.rel(x)) { return(invisible(NULL)) } } diff --git a/R/utils-text.R b/R/utils-text.R index 0b71afd..5a05d0b 100644 --- a/R/utils-text.R +++ b/R/utils-text.R @@ -91,24 +91,3 @@ 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 -} diff --git a/R/utils.R b/R/utils.R index 8c6632a..152410f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -280,3 +280,25 @@ get_just <- function(element) { element$vjust %||% 0.5 ) } + +.label_params <- setdiff(fn_fmls_names(element_text), c("margin", "debug", "inherit.blank")) +.line_params <- c("colour", "color", "linewidth", "linetype") + +extra_args <- function(..., .valid_args = .label_params, 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), .valid_args) + 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 +} diff --git a/_pkgdown.yml b/_pkgdown.yml index e6e7f42..70c282f 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -44,6 +44,7 @@ reference: - bracket_options - cap_options - theme_guide + - scale_x_dendro news: releases: diff --git a/man/guide_axis_base.Rd b/man/guide_axis_base.Rd index d562763..55d7191 100644 --- a/man/guide_axis_base.Rd +++ b/man/guide_axis_base.Rd @@ -123,6 +123,7 @@ ggplot(msleep, aes(bodywt, brainwt)) + } \seealso{ Other standalone guides: +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, diff --git a/man/guide_axis_dendro.Rd b/man/guide_axis_dendro.Rd new file mode 100644 index 0000000..2597c85 --- /dev/null +++ b/man/guide_axis_dendro.Rd @@ -0,0 +1,124 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide_axis_dendro.R +\name{guide_axis_dendro} +\alias{guide_axis_dendro} +\title{Dendrogram guide} +\usage{ +guide_axis_dendro( + key = "dendro", + title = waiver(), + theme = NULL, + space = rel(10), + vanish = TRUE, + n.dodge = 1, + angle = waiver(), + check.overlap = FALSE, + ticks = "none", + axis_line = "none", + order = 0, + position = waiver() +) +} +\arguments{ +\item{key}{A \link[=key_segments]{segment key} specification. See more information +in the linked topic. Alternatively, an object of class +\code{\link[stats:hclust]{}} that automatically invokes \code{key_dendro()}.} + +\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{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{space}{Either a \code{\link[grid:unit]{}} or \code{\link[ggplot2:element]{}} +object of length 1 determining the space allocated in the orthogonal +direction. When the \code{space} argument is of class \verb{} (default) the +base size is taken from the tick length theme setting.} + +\item{vanish}{Only relevant when the guide is used in the secondary theta +position: a \verb{} on whether the continue to draw the segments +until they meed in the center (\code{TRUE}) or strictly observe the \code{space} +setting (\code{FALSE}).} + +\item{n.dodge}{An positive \verb{} setting the number of layers text +labels can occupy to avoid overlapping labels.} + +\item{angle}{A specification for the text angle. Compared to setting the \code{angle} argument +in \code{\link[ggplot2:element]{element_text()}}, this argument uses some +heuristics to automatically pick the \code{hjust} and \code{vjust} that you +probably want. Can be one of the following: +\itemize{ +\item \code{NULL} to take angles and justification settings directly from the theme. +\item \code{\link[ggplot2:waiver]{waiver()}} to allow reasonable defaults in special +cases. +\item A \verb{} between -360 and 360 for the text angle in degrees. +}} + +\item{check.overlap}{A \verb{} indicating whether to check for and +omit overlapping text. If \code{TRUE}, first, last and middle labels are +recursively prioritised in that order. If \code{FALSE}, all labels are drawn.} + +\item{ticks, axis_line}{Guides to use as ticks or axis lines. Defaults to +drawing no ticks or axis lines. Can be specified as one of the following: +\itemize{ +\item A \verb{} class object. +\item A \verb{} that returns a \verb{} class object. +\item A \verb{} naming such a function, without the \code{guide_} or +\code{primitive_} prefix. +}} + +\item{order}{A positive \verb{} that specifies the order of this guide among +multiple guides. This controls in which order guides are merged if there +are multiple guides for the same position. If \code{0} (default), the order is +determined by a hashing indicative settings of a guide.} + +\item{position}{A \verb{} giving the location of the guide. Can be one of \code{"top"}, +\code{"bottom"}, \code{"left"} or \code{"right"}.} +} +\value{ +A \verb{} object. +} +\description{ +This axis is a speciality axis for discrete data that has been +hierarchically clustered. Please be aware that the guide cannot affect the +scale limits, which should be set appropriately. This guide will give +misleading results when this step is skipped! +} +\examples{ +# Hierarchically cluster data +clust <- hclust(dist(scale(mtcars)), "ave") + +# Using the guide along with appropriate limits +p <- ggplot(mtcars, aes(disp, rownames(mtcars))) + + geom_col() + + scale_y_discrete(limits = clust$labels[clust$order]) + +# Standard usage +p + guides(y = guide_axis_dendro(clust)) + +# Adding ticks and axis line +p + guides(y = guide_axis_dendro(clust, ticks = "ticks", axis_line = "line")) + + theme(axis.line = element_line()) + +# Controlling space allocated to dendrogram +p + guides(y = guide_axis_dendro(clust, space = unit(4, "cm"))) + + theme(axis.ticks.y.left = element_line("red")) + +# If want just the dendrograme, use `primitive_segments()` +p + guides(y = primitive_segments(clust), y.sec = "axis") +} +\seealso{ +Other standalone guides: +\code{\link{guide_axis_base}()}, +\code{\link{guide_axis_nested}()}, +\code{\link{guide_colbar}()}, +\code{\link{guide_colring}()}, +\code{\link{guide_colsteps}()}, +\code{\link{guide_legend_base}()}, +\code{\link{guide_legend_cross}()}, +\code{\link{guide_legend_group}()} +} +\concept{standalone guides} diff --git a/man/guide_axis_nested.Rd b/man/guide_axis_nested.Rd index 83c194b..a42e997 100644 --- a/man/guide_axis_nested.Rd +++ b/man/guide_axis_nested.Rd @@ -162,6 +162,7 @@ ggplot(mpg, aes(displ, hwy)) + \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, \code{\link{guide_colsteps}()}, diff --git a/man/guide_colbar.Rd b/man/guide_colbar.Rd index 9339db9..5ab923d 100644 --- a/man/guide_colbar.Rd +++ b/man/guide_colbar.Rd @@ -156,6 +156,7 @@ ggplot(msleep, aes(sleep_total, sleep_rem)) + \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colring}()}, \code{\link{guide_colsteps}()}, diff --git a/man/guide_colring.Rd b/man/guide_colring.Rd index 863bb4a..c9ec3bc 100644 --- a/man/guide_colring.Rd +++ b/man/guide_colring.Rd @@ -108,6 +108,7 @@ p + guides(colour = guide_colring(angle = 0)) \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colsteps}()}, diff --git a/man/guide_colsteps.Rd b/man/guide_colsteps.Rd index a95f808..318df2e 100644 --- a/man/guide_colsteps.Rd +++ b/man/guide_colsteps.Rd @@ -153,6 +153,7 @@ p + scale_colour_viridis_b( \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, diff --git a/man/guide_legend_base.Rd b/man/guide_legend_base.Rd index 574dae4..fc567a9 100644 --- a/man/guide_legend_base.Rd +++ b/man/guide_legend_base.Rd @@ -106,6 +106,7 @@ p + guides(shape = guide_legend_base(design = design)) \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, diff --git a/man/guide_legend_cross.Rd b/man/guide_legend_cross.Rd index 34270df..10a5012 100644 --- a/man/guide_legend_cross.Rd +++ b/man/guide_legend_cross.Rd @@ -107,6 +107,7 @@ ggplot(mpg, aes(displ, hwy)) + \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, diff --git a/man/guide_legend_group.Rd b/man/guide_legend_group.Rd index 2a3cf7c..8070886 100644 --- a/man/guide_legend_group.Rd +++ b/man/guide_legend_group.Rd @@ -97,6 +97,7 @@ p + guides(colour = "legend_group") + \seealso{ Other standalone guides: \code{\link{guide_axis_base}()}, +\code{\link{guide_axis_dendro}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, diff --git a/man/key_group.Rd b/man/key_group.Rd index 004576d..f69056b 100644 --- a/man/key_group.Rd +++ b/man/key_group.Rd @@ -71,6 +71,7 @@ key(template) \seealso{ Other keys: \code{\link{key_range}}, +\code{\link{key_segments}}, \code{\link{key_specialty}}, \code{\link{key_standard}} } diff --git a/man/key_range.Rd b/man/key_range.Rd index b5911fa..a10d488 100644 --- a/man/key_range.Rd +++ b/man/key_range.Rd @@ -97,6 +97,7 @@ key_range_map(presidential, start = start, end = end, name = name) \seealso{ Other keys: \code{\link{key_group}}, +\code{\link{key_segments}}, \code{\link{key_specialty}}, \code{\link{key_standard}} } diff --git a/man/key_segments.Rd b/man/key_segments.Rd new file mode 100644 index 0000000..c604bae --- /dev/null +++ b/man/key_segments.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/key-segment.R +\name{key_segments} +\alias{key_segments} +\alias{key_segment_manual} +\alias{key_segment_map} +\alias{key_dendro} +\title{Segment keys} +\usage{ +key_segment_manual(value, oppo, value_end = value, oppo_end = oppo, ...) + +key_segment_map(data, ..., .call = caller_env()) + +key_dendro(dendro = NULL, type = "rectangle") +} +\arguments{ +\item{value, value_end}{A vector that is interpreted to be along the scale +that the guide codifies.} + +\item{oppo, oppo_end}{A vector that is interpreted to be orthogonal to the +\code{value} and \code{value_end} variables.} + +\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_segments_map()}, these \emph{must} contain \code{value} and \code{oppo} mappings.} + +\item{data}{A \verb{} or similar object coerced by +\code{\link[ggplot2:fortify]{fortify()}} to a \verb{}, in which the \code{mapping} +argument is evaluated.} + +\item{.call}{A \link[rlang:topic-error-call]{call} to display in messages.} + +\item{dendro}{A data structure that can be coerced to a dendrogram through +the \code{\link[stats:dendrogram]{as.dendrogram()}} function. When \code{NULL} +(default) an attempt is made to search for such data in the scale.} + +\item{type}{A string, either \code{"rectangle"} or \code{"triangle"}, indicating the +shape of edges between nodes of the dendrogram.} +} +\value{ +For \code{key_segments_manual()} and \code{key_segments_map()}, a \verb{} with +the \verb{} class. +} +\description{ +These functions are helper functions for working with segment data as keys +in guides. They all share the goal of creating a guide key, but have +different methods: +\itemize{ +\item \code{key_segment_manual()} directly uses user-provided vectors to set segments. +\item \code{key_segment_map()} makes mappings from a \verb{} to set segments. +\item \code{key_dendro()} is a specialty case for coercing dendrogram data to segments. +Be aware that setting the key alone cannot affect the scale limits, and +will give misleading results when used incorrectly! +} +} +\examples{ +# Giving vectors directly +key_segment_manual( + value = 0:1, value_end = 2:3, + oppo = 1:0, oppo_end = 3:2 +) + +# Taking columns of a data frame +data <- data.frame(x = 0:1, y = 1:0, xend = 2:3, yend = 3:2) +key_segment_map(data, value = x, oppo = y, value_end = xend, oppo_end = yend) + +# Using dendrogram data +clust <- hclust(dist(USArrests), "ave") +key_dendro(clust)(scale_x_discrete()) +} +\seealso{ +Other keys: +\code{\link{key_group}}, +\code{\link{key_range}}, +\code{\link{key_specialty}}, +\code{\link{key_standard}} +} +\concept{keys} diff --git a/man/key_specialty.Rd b/man/key_specialty.Rd index 067cc88..b7dd91d 100644 --- a/man/key_specialty.Rd +++ b/man/key_specialty.Rd @@ -52,6 +52,7 @@ key_bins()(template) Other keys: \code{\link{key_group}}, \code{\link{key_range}}, +\code{\link{key_segments}}, \code{\link{key_standard}} } \concept{keys} diff --git a/man/key_standard.Rd b/man/key_standard.Rd index 4f2c5f4..a6d3f47 100644 --- a/man/key_standard.Rd +++ b/man/key_standard.Rd @@ -125,6 +125,7 @@ key_none() Other keys: \code{\link{key_group}}, \code{\link{key_range}}, +\code{\link{key_segments}}, \code{\link{key_specialty}} } \concept{keys} diff --git a/man/primitive_box.Rd b/man/primitive_box.Rd index 1875a8f..ff338a0 100644 --- a/man/primitive_box.Rd +++ b/man/primitive_box.Rd @@ -109,6 +109,7 @@ Other primitives: \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} diff --git a/man/primitive_bracket.Rd b/man/primitive_bracket.Rd index 9fbfd41..a884f8f 100644 --- a/man/primitive_bracket.Rd +++ b/man/primitive_bracket.Rd @@ -118,6 +118,7 @@ Other primitives: \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} diff --git a/man/primitive_fence.Rd b/man/primitive_fence.Rd index 1e598c8..2b166d7 100644 --- a/man/primitive_fence.Rd +++ b/man/primitive_fence.Rd @@ -118,6 +118,7 @@ Other primitives: \code{\link{primitive_bracket}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} diff --git a/man/primitive_labels.Rd b/man/primitive_labels.Rd index 7ec5736..47bafe3 100644 --- a/man/primitive_labels.Rd +++ b/man/primitive_labels.Rd @@ -85,6 +85,7 @@ Other primitives: \code{\link{primitive_bracket}()}, \code{\link{primitive_fence}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} diff --git a/man/primitive_line.Rd b/man/primitive_line.Rd index 94c2a28..dd7fa2e 100644 --- a/man/primitive_line.Rd +++ b/man/primitive_line.Rd @@ -79,6 +79,7 @@ Other primitives: \code{\link{primitive_bracket}()}, \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} diff --git a/man/primitive_segments.Rd b/man/primitive_segments.Rd new file mode 100644 index 0000000..ab81bc1 --- /dev/null +++ b/man/primitive_segments.Rd @@ -0,0 +1,94 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/primitive-segments.R +\name{primitive_segments} +\alias{primitive_segments} +\title{Guide primitives: segments} +\usage{ +primitive_segments( + key = NULL, + space = rel(10), + vanish = FALSE, + theme = NULL, + position = waiver() +) +} +\arguments{ +\item{key}{A \link[=key_segments]{segment key} specification. See more information +in the linked topic. Alternatively, an object of class +\code{\link[stats:hclust]{}} that automatically invokes \code{key_dendro()}.} + +\item{space}{Either a \code{\link[grid:unit]{}} or \code{\link[ggplot2:element]{}} +object of length 1 determining the space allocated in the orthogonal +direction. When the \code{space} argument is of class \verb{} (default) the +base size is taken from the tick length theme setting.} + +\item{vanish}{Only relevant when the guide is used in the secondary theta +position: a \verb{} on whether the continue to draw the segments +until they meed in the center (\code{TRUE}) or strictly observe the \code{space} +setting (\code{FALSE}).} + +\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"}.} +} +\value{ +A \verb{} primitive guide that can be used inside other +guides. +} +\description{ +This function constructs a \link[=guide-primitives]{guide primitive}. +} +\section{Styling options}{ +Below are the \link[ggplot2:theme]{theme} options that determine the style of +this guide, which may differ depending on whether the guide is used in an +axis or in a legend context. +\subsection{As an axis guide}{ +\itemize{ +\item \verb{axis.ticks.\{x/y\}.\{position\}} an \code{\link[ggplot2:element]{}} +for display of the segments. +\item \verb{axis.ticks.length.\{x/y\}.\{position\}} a \code{\link[grid:unit]{}} for the +base size of the segments in the orthogonal direction. +} +} + +\subsection{As a legend guide}{ +\itemize{ +\item \code{legend.ticks} an \code{\link[ggplot2:element]{}} for display +of the segments. +\item \code{legend.ticks.length} a \code{\link[grid:unit]{}} for the +base size of the segments in the orthogonal direction. +} +} +} + +\examples{ +# Building a key +key <- key_segment_manual( + value = c(1.6, 1.6, 3.4, 5.2), + value_end = c(7.0, 7.0, 3.4, 5.2), + oppo = c(1.0, 2.0, 0.0, 0.0), + oppo_end = c(1.0, 2.0, 3.0, 3.0) +) + +# Using the primitive in a plot +ggplot(mpg, aes(displ, hwy)) + + geom_point() + + scale_x_continuous( + guide = primitive_segments(key = key) + ) +} +\seealso{ +Other primitives: +\code{\link{primitive_box}()}, +\code{\link{primitive_bracket}()}, +\code{\link{primitive_fence}()}, +\code{\link{primitive_labels}()}, +\code{\link{primitive_line}()}, +\code{\link{primitive_spacer}()}, +\code{\link{primitive_ticks}()}, +\code{\link{primitive_title}()} +} +\concept{primitives} diff --git a/man/primitive_spacer.Rd b/man/primitive_spacer.Rd index a37f026..c681751 100644 --- a/man/primitive_spacer.Rd +++ b/man/primitive_spacer.Rd @@ -57,6 +57,7 @@ Other primitives: \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_ticks}()}, \code{\link{primitive_title}()} } diff --git a/man/primitive_ticks.Rd b/man/primitive_ticks.Rd index 214a1e4..b235e38 100644 --- a/man/primitive_ticks.Rd +++ b/man/primitive_ticks.Rd @@ -84,6 +84,7 @@ Other primitives: \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_title}()} } diff --git a/man/primitive_title.Rd b/man/primitive_title.Rd index 4e8db18..3a066b5 100644 --- a/man/primitive_title.Rd +++ b/man/primitive_title.Rd @@ -79,6 +79,7 @@ Other primitives: \code{\link{primitive_fence}()}, \code{\link{primitive_labels}()}, \code{\link{primitive_line}()}, +\code{\link{primitive_segments}()}, \code{\link{primitive_spacer}()}, \code{\link{primitive_ticks}()} } diff --git a/man/scale_x_dendro.Rd b/man/scale_x_dendro.Rd new file mode 100644 index 0000000..fde248f --- /dev/null +++ b/man/scale_x_dendro.Rd @@ -0,0 +1,145 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale_dendro.R +\name{scale_x_dendro} +\alias{scale_x_dendro} +\alias{scale_y_dendro} +\title{Dendrogram scales} +\usage{ +scale_x_dendro( + clust, + ..., + expand = waiver(), + guide = "axis_dendro", + position = "bottom" +) + +scale_y_dendro( + clust, + ..., + expand = waiver(), + guide = "axis_dendro", + position = "left" +) +} +\arguments{ +\item{clust}{A data structure that can be coerced to an +\code{\link[stats:hclust]{}} object through +\code{\link[stats:as.hclust]{as.hclust()}}.} + +\item{...}{ + Arguments passed on to \code{\link[ggplot2:discrete_scale]{ggplot2::discrete_scale}} + \describe{ + \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} + \item{\code{palette}}{A palette function that when called with a single integer +argument (the number of levels in the scale) returns the values that +they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} + \item{\code{name}}{The name of the scale. Used as the axis or legend title. If +\code{waiver()}, the default, the name of the scale is taken from the first +mapping used for that aesthetic. If \code{NULL}, the legend title will be +omitted.} + \item{\code{breaks}}{One of: +\itemize{ +\item \code{NULL} for no breaks +\item \code{waiver()} for the default breaks (the scale limits) +\item A character vector of breaks +\item A function that takes the limits as input and returns breaks +as output. Also accepts rlang \link[rlang:as_function]{lambda} function +notation. +}} + \item{\code{labels}}{One of: +\itemize{ +\item \code{NULL} for no labels +\item \code{waiver()} for the default labels computed by the +transformation object +\item A character vector giving labels (must be same length as \code{breaks}) +\item An expression vector (must be the same length as breaks). See ?plotmath for details. +\item A function that takes the breaks as input and returns labels +as output. Also accepts rlang \link[rlang:as_function]{lambda} function +notation. +}} + \item{\code{na.translate}}{Unlike continuous scales, discrete scales can easily show +missing values, and do so by default. If you want to remove missing values +from a discrete scale, specify \code{na.translate = FALSE}.} + \item{\code{na.value}}{If \code{na.translate = TRUE}, what aesthetic value should the +missing values be displayed as? Does not apply to position scales +where \code{NA} is always placed at the far right.} + \item{\code{drop}}{Should unused factor levels be omitted from the scale? +The default, \code{TRUE}, uses the levels that appear in the data; +\code{FALSE} includes the levels in the factor. Please note that to display +every level in a legend, the layer should use \code{show.legend = TRUE}.} + \item{\code{call}}{The \code{call} used to construct the scale for reporting messages.} + \item{\code{super}}{The super class to use for the constructed scale} + }} + +\item{expand}{For position scales, a vector of range expansion constants used to add some +padding around the data to ensure that they are placed some distance +away from the axes. Use the convenience function \code{\link[ggplot2:expansion]{expansion()}} +to generate the values for the \code{expand} argument. The defaults are to +expand the scale by 5\% on each side for continuous variables, and by +0.6 units on each side for discrete variables.} + +\item{guide}{A function used to create a guide or its name. See +\code{\link[ggplot2:guides]{guides()}} for more information.} + +\item{position}{For position scales, The position of the axis. +\code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} +} +\value{ +A \verb{} object that can be added to a plot. +} +\description{ +These are speciality scales for use with hierarchically clustered data. The +scale automatically orders the limits according to the clustering result +and comes with a \link[=guide_axis_dendro]{dendrogram axis}. +} +\details{ +The scale limits are determined by the order and labels in the \code{clust} +argument. While \code{limits} is not an argument in these scales, the \code{breaks} +argument can still be used to selectively omit some breaks and the \code{labels} +can be used for formatting purposes. +} +\examples{ +# Hierarchically cluster data, separately for rows and columns +car_clust <- hclust(dist(scale(mtcars)), "ave") +var_clust <- hclust(dist(scale(t(mtcars))), "ave") + +long_mtcars <- data.frame( + car = rownames(mtcars)[row(mtcars)], + var = colnames(mtcars)[col(mtcars)], + value = as.vector(scale(mtcars)) +) + +# A standard heatmap adorned with dendrograms +p <- ggplot(long_mtcars, aes(var, car, fill = value)) + + geom_tile() + + scale_x_dendro(var_clust) + + scale_y_dendro(car_clust) +p + +# Styling the dendrograms +p + + guides( + y = guide_axis_dendro(key_dendro(type = "triangle")), + x = guide_axis_dendro(space = rel(5)) + ) + + theme( + axis.text.y.left = element_text(margin = margin(r = 3, l = 3)), + axis.ticks.y = element_line("red"), + axis.ticks.x = element_line(linetype = "dotted") + ) + +# In polar coordinates, plus some formatting +p + + coord_radial( + theta = "y", inner.radius = 0.5, + start = 0.25 * pi, end = 1.75 * pi + ) + + guides( + theta = primitive_labels(angle = 90), + theta.sec = primitive_segments("dendro", vanish = TRUE), + r = guide_axis_dendro(angle = 0) + ) +} +\seealso{ +\code{\link[=guide_axis_dendro]{guide_axis_dendro()}} +} diff --git a/tests/testthat/_snaps/primitive-segments/primitive-segments-cartesian.svg b/tests/testthat/_snaps/primitive-segments/primitive-segments-cartesian.svg new file mode 100644 index 0000000..e2706d3 --- /dev/null +++ b/tests/testthat/_snaps/primitive-segments/primitive-segments-cartesian.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +displ +hwy +primitive_segments cartesian + + diff --git a/tests/testthat/_snaps/primitive-segments/primitive-segments-legend.svg b/tests/testthat/_snaps/primitive-segments/primitive-segments-legend.svg new file mode 100644 index 0000000..ac4ed76 --- /dev/null +++ b/tests/testthat/_snaps/primitive-segments/primitive-segments-legend.svg @@ -0,0 +1,97 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + +100 +200 +300 +400 +disp +mpg + + + + + + + + +primitive_segments legend + + diff --git a/tests/testthat/_snaps/primitive-segments/primitive-segments-radial.svg b/tests/testthat/_snaps/primitive-segments/primitive-segments-radial.svg new file mode 100644 index 0000000..9850eea --- /dev/null +++ b/tests/testthat/_snaps/primitive-segments/primitive-segments-radial.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +displ +hwy +primitive_segments radial + + diff --git a/tests/testthat/_snaps/scale_dendro/scale-dendro-cartesian.svg b/tests/testthat/_snaps/scale_dendro/scale-dendro-cartesian.svg new file mode 100644 index 0000000..b481369 --- /dev/null +++ b/tests/testthat/_snaps/scale_dendro/scale-dendro-cartesian.svg @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3 +1 +2 + + + + +4 +3 +1 +2 + + + + + + + + + + + + + + + + + +4 +3 +1 +2 + + + + + + + + + + + + +3 +1 +2 + + + + + + + + +scale_dendro cartesian + + diff --git a/tests/testthat/_snaps/scale_dendro/scale-dendro-radial.svg b/tests/testthat/_snaps/scale_dendro/scale-dendro-radial.svg new file mode 100644 index 0000000..b0435ac --- /dev/null +++ b/tests/testthat/_snaps/scale_dendro/scale-dendro-radial.svg @@ -0,0 +1,100 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3 +1 +2 + + + + + + + + + + + + +3 +1 +2 + + + + + + + + +4 +3 +1 +2 + + + + + + + + + + + + + + + + + +4 +3 +1 +2 + + + + + + +x +y +scale_dendro radial + + diff --git a/tests/testthat/test-key-segment.R b/tests/testthat/test-key-segment.R new file mode 100644 index 0000000..3e19654 --- /dev/null +++ b/tests/testthat/test-key-segment.R @@ -0,0 +1,48 @@ + +test_that("key_segment_manual works as intended", { + + test <- key_segment_manual(c("A", "B"), 1:2, c("B", "C"), 3:4, linetype = 1:2) + expect_s3_class(test, 'key_segment') + + expect_equal(test$value, c("A", "B")) + expect_equal(test$value_end, c("B", "C")) + expect_equal(test$oppo, 1:2) + expect_equal(test$oppo_end, 3:4) + expect_equal(test$.linetype, 1:2) +}) + +test_that("key_segment_map works as intended", { + + data <- data.frame( + x = c("A", "B"), y = 1:2, xend = c("B", "C"), yend = 3:4 + ) + + test <- key_segment_map( + data, value = x, oppo = y, value_end = xend, oppo_end = yend, + linetype = 1:2, color = "blue" + ) + + expect_equal(test$value, c("A", "B")) + expect_equal(test$value_end, c("B", "C")) + expect_equal(test$oppo, 1:2) + expect_equal(test$oppo_end, 3:4) + expect_equal(test$.linetype, 1:2) + expect_equal(test$.colour, c("blue", "blue")) +}) + +test_that("key_dendro works as intended", { + + dummy <- scale_x_discrete() + d <- hclust(dist(matrix(1:9, 3))) + ptype <- data.frame( + value = double(), oppo = double(), + value_end = double(), oppo_end = double() + ) + + test <- key_dendro(d, type = "rectangle")(dummy) + expect_vector(test, ptype, size = 8) + + test <- key_dendro(d, type = "triangle")(dummy) + expect_vector(test, ptype, size = 4) + +}) diff --git a/tests/testthat/test-primitive-segments.R b/tests/testthat/test-primitive-segments.R new file mode 100644 index 0000000..969fc0e --- /dev/null +++ b/tests/testthat/test-primitive-segments.R @@ -0,0 +1,67 @@ + +test_that("primitive_segments works as axis", { + + base <- ggplot(mpg, aes(displ, hwy)) + + geom_blank() + + theme_test() + + theme( + panel.background = element_rect(fill = NA, colour = "grey80"), + panel.grid.major = element_line(colour = "grey90"), + panel.border = element_blank(), + axis.line = element_line() + ) + + hkey <- key_segment_manual( + value = c(2, 4, 6, 1.6, 1.6), + value_end = c(2, 4, 6, 7.0, 7.0), + oppo = c(0, 0, 0, 1, 2), + oppo_end = c(3, 3, 3, 1, 2) + ) + + vkey <- key_segment_manual( + value = c(20, 30, 30, 40), + value_end = c(30, 40, 20, 30), + oppo = 0, oppo_end = 1 + ) + + p <- base + + guides( + x = primitive_segments(key = hkey), + y = primitive_segments(key = vkey), + x.sec = primitive_segments(key = hkey), + y.sec = primitive_segments(key = vkey) + ) + + vdiffr::expect_doppelganger("primitive_segments cartesian", p) + + p <- base + + coord_radial(start = 0.25 * pi, end = 1.75 * pi, inner.radius = 0.5) + + guides( + theta = primitive_segments(key = hkey), + r = primitive_segments(key = vkey), + theta.sec = primitive_segments(key = hkey), + r.sec = primitive_segments(key = vkey) + ) + + vdiffr::expect_doppelganger("primitive_segments radial", p) + +}) + +test_that("primitive_segments works as a legend", { + + key <- key_segment_manual( + value = c(100, 200, 200, 300), + value_end = c(200, 300, 100, 200), + oppo = 0, oppo_end = 1 + ) + + p <- ggplot(mtcars) + + aes(x = disp, y = mpg, colour = hp, fill = hp) + + geom_point() + + guides( + colour = primitive_segments(key = key), + fill = primitive_segments(key = key, position = "bottom") + ) + + vdiffr::expect_doppelganger("primitive_segments legend", p) +}) diff --git a/tests/testthat/test-scale_dendro.R b/tests/testthat/test-scale_dendro.R new file mode 100644 index 0000000..a3da7ca --- /dev/null +++ b/tests/testthat/test-scale_dendro.R @@ -0,0 +1,60 @@ +test_clust <- function(n) { + m <- matrix(NA_real_, nrow = n, ncol = n) + m[lower.tri(m)] <- seq_len(sum(lower.tri(m))) + hclust(as.dist(m), method = "ave") +} + +test_that("scale_xy_dendro throw appropriate error messages", { + + clust <- test_clust(3) + + expect_error( + scale_x_dendro(NULL), + "argument should be convertable" + ) + expect_error( + scale_y_dendro(clust, limits = 1:5), + "it is derived from the labels" + ) + expect_error( + scale_x_dendro(clust, palette = 1:5), + "requires fixed spacing" + ) + +}) + +test_that("scale_xy_dendro looks correct", { + + xclust <- test_clust(3) + yclust <- test_clust(4) + + base <- ggplot() + + scale_x_dendro(xclust) + + scale_y_dendro(yclust) + + theme( + panel.background = element_rect(fill = NA, colour = "grey80"), + panel.grid.major = element_line(colour = "grey90"), + panel.border = element_blank(), + axis.line = element_line() + ) + + p <- base + + coord_cartesian(xlim = c(0, 4), ylim = c(1, 4)) + + guides( + x.sec = guide_axis_dendro(key = key_dendro(type = "triangle")), + y.sec = guide_axis_dendro(space = rel(5), ticks = "ticks", axis_line = "line") + ) + + vdiffr::expect_doppelganger("scale_dendro cartesian", p) + + p <- base + + expand_limits(x = c(0, 4), y = c(1, 4)) + + coord_radial(start = 0.25 * pi, end = 1.75 * pi, inner.radius = 0.5) + + guides( + r.sec = guide_axis_dendro(key = key_dendro(type = "triangle"), ticks = "ticks", axis_line = "line"), + theta.sec = guide_axis_dendro(ticks = "ticks", axis_line = "line") + ) + + vdiffr::expect_doppelganger("scale_dendro radial", p) + +}) diff --git a/vignettes/articles/tour.Rmd b/vignettes/articles/tour.Rmd index e680be3..6a41b69 100644 --- a/vignettes/articles/tour.Rmd +++ b/vignettes/articles/tour.Rmd @@ -227,6 +227,49 @@ presidents <- key_range_map( eco + guides(x = guide_axis_nested(key = presidents)) ``` +### Dendrograms + +Dendrograms are a popular method of displaying the results of hierarchical clustering. +A very standard way of computing hierarchical clusters is to compute a distance metric of the data with `dist()` and forwarding the +result to `hclust()`. +The default plot method shows the dendrogram. + +```{r} +clust <- hclust(dist(scale(mtcars)), method = "ave") +plot(clust) +``` + +Other packages have many more options to display dendrograms, notably [ggdendro](https://andrie.github.io/ggdendro/) or [dendextend](https://talgalili.github.io/dendextend/). +The legendry package has no ambition to be the best dendrogram visualiser, but does find dendrograms to be use useful annotation. +To use dendrograms, you can provide an object produced by `hclust` to `scale_(x/y)_dendro()`. +This ensures that the scale follows the order of the clustering result and by default uses `guide_axis_dendro()` to display the dendrogram next to the labels. + +```{r} +ggplot(mtcars, aes(mpg, rownames(mtcars))) + + geom_col() + + scale_y_dendro(clust) +``` + +The `guide_axis_dendro()` function can be decomposed into labels and the segments. +You can use `primitive_segments("dendro")` to not display labels, which may convenient if you rather place the labels at the opposite end of the panel. +In the plot below we use the raw segments to draw a radial dendrogram. +The `vanish = TRUE` option indicates that we should fit the dendrogram so that the root of the tree is in the middle, which is only ever relevant for secondary theta axes. + +```{r} +ggplot(mtcars, aes(mpg, rownames(mtcars))) + + geom_col() + + scale_y_dendro(clust) + + coord_radial(theta = "y", inner.radius = 0.5) + + guides( + theta = guide_axis_base(angle = 90), + theta.sec = primitive_segments("dendro", vanish = TRUE), + r = "none" + ) + + theme( + axis.title = element_blank(), + plot.margin = margin(t = 50, b = 50) + ) +``` ## Colours