#' Label facets with a string template.
#'
#' \code{label_glue} returns a labeller function that you can give to the
#' \code{labeller} argument of a \code{facet_*} function. If you're using
#' \code{label_glue} with \code{facet_wrap} or you're individually supplying
#' labellers to each variable, you only need one string template. If you're
#' using it with \code{facet_grid} directly, you need to give two templates:
#' \code{rows} and \code{cols}.
#'
#' If you're using the labeller with \code{facet_wrap}, you can also use these
#' variables in \code{glue} strings:
#' \itemize{
#' \item \code{.n} to add numbers to each facet;
#' \item \code{.l} or \code{.L} to add lower- or uppercase letters
#' \item \code{.r} or \code{.R} to add lower or uppercase roman numerals.
#' }
#' @param rows A string to be used as the template by \code{glue}.
#' @param cols A string to be used as the template by \code{glue}.
#'
#' @return A labelling function that you can give to the \code{labeller} argument
#' of a \code{facet_*} function.
#' @examples
#' library(ggplot2)
#' library(stickylabeller)
#'
#' # wrap facet columns in braces to refer to their values in the labels
#' p1 <- ggplot(iris, aes(x = Sepal.Length, y = Petal.Length)) + geom_point()
#' p1 + facet_wrap(
#' ~ Species,
#' labeller = label_glue('Sepal and petal lengths in {Species} plants'))
#'
#' # distinguish panels with .n (numbers), .l (lowercase), .L (uppercase),
#' # .r or .R (lower- or uppercase roman) if you're using facet_wrap
#' p1 + facet_wrap(
#' ~ Species,
#' labeller = label_glue('({.n}) {Species}'))
#'
#' # you can also use label_glue with facet_grid
#' p2 <- ggplot(mtcars, aes(x = disp, y = mpg)) + geom_point()
#' p2 + facet_grid(
#' gear ~ cyl,
#' labeller = label_glue(
#' rows = '{gear} gears',
#' cols = '{cyl} cylinders'))
#'
#' # you can add summary statistics in a couple of ways. the easiest (in terms
#' # of plot code) is to join a summary back into the original data and to add
#' # the new columns in the facet spec
#' library(dplyr)
#' cyl_stats <- mtcars %>%
#' group_by(cyl) %>%
#' summarise(cyl_n = n(), cyl_meanmpg = sprintf('%#.2f', mean(mpg)))
#' mtcars_joined <- mtcars %>% inner_join(cyl_stats)
#'
#' p3 <- ggplot(mtcars_joined, aes(x = disp, y = mpg)) + geom_point()
#' p3 + facet_wrap(
#' ~ cyl + cyl_n + cyl_meanmpg,
#' labeller = label_glue(
#' '({.l}) {cyl} cylinders\n(n = {cyl_n}, mean = {cyl_meanmpg})'))
#'
#'
#' @export
label_glue <- function(rows, cols) {
# here's the inner function. label_glue returns this, but it can access the
# template string given when the user calls label_glue
label_glue_inner <- function(labels) {
facet_type <- attr(labels, "facet")
if (!is.null(facet_type) & facet_type == "wrap") {
# for facet_wrap, convert incoming labels to strings
# and add extra columns for numbering
facet_count <- nrow(labels)
template <- rows
labels <- lapply(labels, as.character)
labels[[".n"]] <- as.character(seq_len(facet_count))
labels[[".l"]] <- make_letters(seq_len(facet_count))
labels[[".L"]] <- toupper(make_letters(seq_len(facet_count)))
labels[[".r"]] <- tolower(as.character(utils::as.roman(1:facet_count)))
labels[[".R"]] <- as.character(utils::as.roman(1:facet_count))
} else if (!is.null(facet_type) & facet_type == "grid") {
if (numbering_present(cols) | numbering_present(rows)) {
stop(paste("Error: the column or row label contains .n, .l or .L.",
"label_glue can currently only number the facets in facet_wrap.",
"For more info, see",
"https://github.com/rensa/stickylabeller/issues/1"))
}
facet_direction <- attr(labels, "type")
if (facet_direction == "rows") {
template <- rows
} else if (facet_direction == "cols") {
template <- cols
} else {
stop(paste("Error: unrecognised facet_direction in label_guide. This",
"is probably a bug in stickylabeller. Please report it to",
"https://github.com/rensa/stickylabeller/issues"))
}
labels = lapply(labels, as.character)
} else {
# if no facet type is specified (eg. inside labeller wrapper), just do
# the basics
if (numbering_present(rows)) {
stop(paste("Error: the column or row label contains .n, .l or .L.",
"label_glue can currently only number the facets in facet_wrap.",
"For more info, see",
"https://github.com/rensa/stickylabeller/issues/1"))
}
template <- rows
labels = lapply(labels, as.character)
}
return(list(unname(glue::glue_data(labels, template))))
}
class(label_glue_inner) <- c("function", "labeller")
return(label_glue_inner)
}
# helper functions ============================================================
# numbering_present: quick regex to catch numbering variables when they
# aren't supported
numbering_present <- function(template) {
# TODO - need a more sophisticated regex that can catch more complex
# expressions including numbering columns
return(grepl("{[\\s\\W]*\\.[nlLrR](?!\\w)[\\s\\W]*}", template, perl = TRUE))
}
# make_letters: builds a sequence of letters to extend past 26 facets
# adapted from cellranger::letter_to_num
make_letters <- function(y) {
jfun <- function(div) {
if (is.na(div)) return(NA_character_)
ret <- integer()
while (div > 0) {
remainder <- ((div - 1) %% 26) + 1
ret <- c(remainder, ret)
div <- (div - remainder) %/% 26
}
paste(letters[ret], collapse = "")
}
ret <- vapply(y, jfun, character(1))
if (length(ret) == 0) return(ret) # vapply doesn't always work
ifelse(ret == "", NA_character_, ret)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.