# User function -----------------------------------------------------------
#' Axis guide with ticks for minor breaks
#'
#' `r lifecycle::badge("questioning")`
#' These are similar the the normal axis guides for position scales, but also
#' place tickmarks at minor break positions.
#' The function is questioned due to
#' a possible migration of guide functions after ggplot2 releases a new guide
#' system.
#'
#' @inheritParams guide_axis_truncated
#'
#' @section Theme elements:
#' This axis guide uses the following the theme elements:
#'
#' \describe{
#' \item{[`ggh4x.axis.ticks.length.minor`][theme_extensions]}{
#' An [`rel()`] object to set the size of minor ticks relative to the
#' length of major ticks (`axis.ticks.length`). Defaults to `rel(2/3)`.
#' }
#' }
#'
#' @return An *axis_minor* guide class object.
#' @export
#'
#' @family axis-guides
#'
#' @examples
#' # Using the minor breaks axis
#' p <- ggplot(iris, aes(Sepal.Width, Sepal.Length)) +
#' geom_point()
#' p + scale_y_continuous(guide = "axis_minor")
#'
#' # Minor break positions are still controlled by the scale
#' p + scale_y_continuous(guide = "axis_minor",
#' minor_breaks = seq(4, 8, by = 0.2))
#'
#' # Minor tick length is controlled relative to major ticks
#' p + scale_y_continuous(guide = "axis_minor") +
#' theme(ggh4x.axis.ticks.length.minor = rel(0.1))
guide_axis_minor <- function(
title = waiver(),
check.overlap = FALSE,
angle = NULL,
n.dodge = 1,
order = 0,
colour = NULL,
color = NULL,
trunc_lower = NULL,
trunc_upper = NULL,
position = waiver()
) {
colour <- color %||% colour
check_trunc_arg(trunc_lower, trunc_upper)
structure(
list(
title = title,
check.overlap = check.overlap,
angle = angle,
n.dodge = n.dodge,
order = order,
position = position,
trunc_lower = trunc_lower,
trunc_upper = trunc_upper,
colour = colour,
available_aes = c("x", "y"),
name = "axis"
),
class = c("guide", "axis_minor", "axis_ggh4x", "axis")
)
}
# Internals ---------------------------------------------------------------
#' @export
#' @noRd
guide_train.axis_minor <- function(
guide, scale, aesthetic = NULL
) {
aesthetic <- aesthetic %||% scale$aesthetics[1]
# Get major and minor breaks
breaks_major <- scale$get_breaks()
breaks_minor <- scale$get_breaks_minor()
# Set actual breaks to union
breaks <- union(breaks_major, breaks_minor)
is_major <- breaks %in% breaks_major
empty_ticks <- data_frame0(
aesthetic = numeric(), .value = numeric(0), .label = character(),
.minority = logical(0)
)
names(empty_ticks)[1] <- aesthetic
if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) {
cli::cli_warn(c(
"{.fn guide_axis_minor} needs appropriate scales.",
i = "Use one of {.or {.field {guide$available_aes}}}."
))
guide$key <- empty_ticks
} else if (length(breaks) == 0) {
guide$key <- empty_ticks
} else {
mapped_breaks <- if (scale$is_discrete()) {
scale$map(breaks)
} else {
breaks
}
ticks <- new_data_frame(setNames(list(mapped_breaks), aesthetic))
ticks$.value <- breaks
ticks$.label <- ""
ticks$.label[is_major] <- scale$get_labels(breaks[is_major])
ticks$.minority <- as.numeric(!is_major)
guide$key <- ticks[is.finite(ticks[[aesthetic]]), ]
}
guide$name <- paste0(guide$name, "_", aesthetic)
guide$hash <- with(guide, hash(list(title, key$.value, key$.label, name)))
guide <- truncate_guide(guide, scale, aesthetic)
guide
}
#' @export
#' @noRd
guide_gengrob.axis_minor <- function(guide, theme) {
aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1]
draw_axis_minor(
# break_positions = guide$key[[aesthetic]],
# break_labels = guide$key$.label,
key = guide$key,
axis_position = guide$position,
theme = theme,
check.overlap = guide$check.overlap,
angle = guide$angle,
n.dodge = guide$n.dodge,
minority = guide$key$.minority,
trunc = guide$trunc,
colour = guide$colour
)
}
# Helpers -----------------------------------------------------------------
draw_axis_minor <- function(
key,
axis_position,
theme,
check.overlap,
angle = NULL,
n.dodge = 1,
minority = 0,
trunc,
colour = NULL
) {
axis_position <- match.arg(substr(axis_position, 1, 1),
c("t", "b", "r", "l"))
elements <- build_axis_elements(axis_position, angle, theme, colour)
minor_len <- unclass(calc_element("ggh4x.axis.ticks.length.minor", theme))
mini_len <- unclass(calc_element("ggh4x.axis.ticks.length.mini", theme))
params <- setup_axis_params(axis_position)
line_grob <- build_trunc_axis_line(elements$line, params, trunc)
if ({n_breaks <- nrow(key)} == 0) {
out <- grid::gTree(
children = grid::gList(line_grob),
width = grid::grobWidth(line_grob),
height = grid::grobHeight(line_grob),
cl = "absoluteGrob"
)
return(out)
}
is_major <- minority == 0
label_grobs <- build_axis_labels(
elements, key = key[is_major, , drop = FALSE],
dodge = n.dodge, check.overlap = check.overlap, params = params
)
# Setup ticks
sizes <- c(1, minor_len, mini_len)
tick_grob <- build_axis_ticks_minor(elements$ticks, sizes / max(sizes),
key[[params$aes]], params, minority)
elements$tick_length <- elements$tick_length * max(sizes)
assemble_axis_grobs(ticks = tick_grob, labels = label_grobs,
lines = line_grob, elements = elements,
params = params)
}
build_axis_ticks_minor <- function(element, length, position, params,
minority = 0) {
n_breaks <- length(position)
pos <- params$pos + (params$tick_dir * length)
pos <- c(params$pos, pos)
idx <- c(do.call(rbind,
list(rep(1, n_breaks), minority + 2)[params$tick_ord]))
pos <- unit(pos[idx], "npc")
args <- list(element, unit(rep(position, each = 2), "native"),
pos, rep(2, times = n_breaks))
names(args) <- c("element", params$aes, params$non_aes, "id.lengths")
do.call(element_grob, args)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.