R/labels.R

In ggplot2: Create Elegant Data Visualisations Using the Grammar of Graphics

#' Update axis/legend labels
#'
#' @param p plot to modify
#' @param labels named list of new labels
#' @keywords internal
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' update_labels(p, list(x = "New x"))
#' update_labels(p, list(x = expression(x / y ^ 2)))
#' update_labels(p, list(x = "New x", y = "New Y"))
#' update_labels(p, list(colour = "Fail silently"))
update_labels <- function(p, labels) {
  p <- plot_clone(p)
  p@labels <- labs(!!!defaults(labels, p@labels))
  p
}

# Called in `ggplot_build()` to set default labels not specified by user.
setup_plot_labels <- function(plot, layers, data) {
  # Initiate empty labels
  labels <- list()

  # Find labels from every layer
  for (i in seq_along(layers)) {
    layer <- layers[[i]]

    mapping <- layer$computed_mapping
    if (inherits(mapping, "unlabelled")) {
      next
    }
    mapping <- mapping[have_name(mapping)]

    mapping <- strip_stage(mapping)
    mapping <- strip_dots(mapping, strip_pronoun = TRUE)

    exclude <- names(layer$aes_params)
    mapping <- mapping[setdiff(names(mapping), exclude)]

    # Acquire default labels
    mapping_default <- make_labels(mapping)
    stat_default <- lapply(
      make_labels(layer$stat$default_aes),
      function(l) {
        attr(l, "fallback") <- TRUE
        l
      }
    )
    default <- defaults(mapping_default, stat_default)

    # Search for label attribute in symbolic mappings
    symbolic <- vapply(
      mapping, FUN.VALUE = logical(1),
      function(x) is_quosure(x) && quo_is_symbol(x)
    )
    symbols <- intersect(names(mapping)[symbolic], names(data[[i]]))
    attribs <- lapply(setNames(nm = symbols), function(x) {
      attr(data[[i]][[x]], "label", exact = TRUE)
    })
    attribs <- attribs[lengths(attribs) > 0]
    layer_labels <- defaults(attribs, default)

    # Set label priority:
    # 1. Existing labels that aren't fallback labels
    # 2. The labels of this layer, including fallback labels
    # 3. Existing fallback labels
    current <- labels
    fallbacks <- vapply(current, function(l) isTRUE(attr(l, "fallback")), logical(1))

    labels <- defaults(current[!fallbacks], layer_labels)
    if (any(fallbacks)) {
      labels <- defaults(labels, current)
    }
  }

  # Warn for spurious labels that don't have a mapping.
  # Note: sometimes, 'x' and 'y' might not have a mapping, like in
  # `geom_function()`. We can display these labels anyway, so we include them.
  plot_labels  <- plot@labels
  known_labels <- c(names(labels), fn_fmls_names(labs), "x", "y")
  extra_labels <- names(plot_labels)[lengths(plot_labels) > 0]
  extra_labels <- setdiff(extra_labels, known_labels)

  if (length(extra_labels) > 0) {

    warn_labels <- plot_labels[extra_labels]
    warn_labels <- ifelse(
      vapply(warn_labels, is.function, logical(1)),
      "{.cls function}",
      paste0("{.val ", warn_labels, "}")
    )

    extra_labels <- paste0("{.field ", extra_labels, "} : ", warn_labels)
    names(extra_labels) <- rep("*", length(extra_labels))

    cli::cli_inform(c(
      "Ignoring unknown labels:",
      extra_labels
    ))
  }

  # User labels can be functions, so apply these to the default labels
  plot_labels <- lapply(setNames(nm = names(plot_labels)), function(nm) {
    label <- plot_labels[[nm]]
    if (!is.function(label)) {
      return(label)
    }
    label(labels[[nm]] %||% "")
  })

  dict <- plot_labels$dictionary
  if (length(dict) > 0) {
    labels <- lapply(labels, function(x) {
      dict <- dict[names(dict) %in% x]
      x[match(names(dict), x)] <- dict
      x
    })
  }

  labs(!!!defaults(plot_labels, labels))
}

#' Modify axis, legend, and plot labels
#'
#' Good labels are critical for making your plots accessible to a wider
#' audience. Always ensure the axis and legend labels display the full
#' variable name. Use the plot `title` and `subtitle` to explain the
#' main findings. It's common to use the `caption` to provide information
#' about the data source. `tag` can be used for adding identification tags
#' to differentiate between multiple plots.
#'
#' You can also set axis and legend labels in the individual scales (using
#' the first argument, the `name`). If you're changing other scale options, this
#' is recommended.
#'
#' If a plot already has a title, subtitle, caption, etc., and you want to
#' remove it, you can do so by setting the respective argument to `NULL`. For
#' example, if plot `p` has a subtitle, then `p + labs(subtitle = NULL)` will
#' remove the subtitle from the plot.
#'
#' @param label The title of the respective axis (for `xlab()` or `ylab()`) or
#'        of the plot (for `ggtitle()`).
#' @param title The text for the title.
#' @param subtitle The text for the subtitle for the plot which will be
#'        displayed below the title.
#' @param caption The text for the caption which will be displayed in the
#'        bottom-right of the plot by default.
#' @param tag The text for the tag label which will be displayed at the
#'        top-left of the plot by default.
#' @param dictionary A named character vector to serve as dictionary.
#'        Automatically derived labels, such as those based on variables will
#'        be matched with `names(dictionary)` and replaced by the matching
#'        entry in `dictionary`.
#' @param alt,alt_insight Text used for the generation of alt-text for the plot.
#'        See [get_alt_text] for examples. `alt` can also be a function that
#'        takes the plot as input and returns text as output. `alt` also accepts
#'        rlang [lambda][rlang::as_function()] function notation.
#' @param ... A list of new name-value pairs. The name should be an aesthetic.
#' @export
#'
#' @seealso
#' The `r link_book("plot and axis titles section", "annotations#sec-titles")`
#' @examples
#' p <- ggplot(mtcars, aes(mpg, wt, colour = cyl)) + geom_point()
#' p + labs(colour = "Cylinders")
#' p + labs(x = "New x label")
#'
#' # Set labels by variable name instead of aesthetic
#' p + labs(dict = c(
#'   disp = "Displacment", # Not in use
#'   cyl  = "Number of cylinders",
#'   mpg  = "Miles per gallon",
#'   wt   = "Weight (1000 lbs)"
#' ))
#'
#' # The plot title appears at the top-left, with the subtitle
#' # display in smaller text underneath it
#' p + labs(title = "New plot title")
#' p + labs(title = "New plot title", subtitle = "A subtitle")
#'
#' # The caption appears in the bottom-right, and is often used for
#' # sources, notes or copyright
#' p + labs(caption = "(based on data from ...)")
#'
#' # The plot tag appears at the top-left, and is typically used
#' # for labelling a subplot with a letter.
#' p + labs(title = "title", tag = "A")
#'
#' # If you want to remove a label, set it to NULL.
#' p +
#'  labs(title = "title") +
#'  labs(title = NULL)
labs <- function(..., title = waiver(), subtitle = waiver(),
                 caption = waiver(), tag = waiver(), dictionary = waiver(),
                 alt = waiver(), alt_insight = waiver()) {
  # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ...
  args <- dots_list(..., title = title, subtitle = subtitle, caption = caption,
                    tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight,
                    dictionary = dictionary, .ignore_empty = "all")

  is_waive <- vapply(args, is_waiver, logical(1))
  args <- args[!is_waive]
  # remove duplicated arguments
  args <- args[!duplicated(names(args))]
  args <- rename_aes(args)
  class_labels(args)
}

#' @rdname labs
#' @export
#' @description
#' `r lifecycle::badge("superseded")`: `xlab()`, `ylab()` and `ggtitle()` are
#' superseded. It is recommended to use the `labs(x, y, title, subtitle)`
#' arguments instead.
xlab <- function(label) {
  lifecycle::signal_stage("superseded", "xlab()", "labs(x)")
  labs(x = label)
}

#' @rdname labs
#' @export
ylab <- function(label) {
  lifecycle::signal_stage("superseded", "ylab()", "labs(y)")
  labs(y = label)
}

#' @rdname labs
#' @export
ggtitle <- function(label, subtitle = waiver()) {
  lifecycle::signal_stage("superseded", "ggtitle()", I("labs(title, subtitle)"))
  labs(title = label, subtitle = subtitle)
}

#' @rdname labs
#' @export
#' @param plot A ggplot object
#' @description
#' `get_labs()` retrieves completed labels from a plot.
get_labs <- function(plot = get_last_plot()) {
  plot <- ggplot_build(plot)

  labs <- plot@plot@labels

  xy_labs <- rename(
    c(x = plot@layout$resolve_label(plot@layout$panel_scales_x[[1]], labs),
      y = plot@layout$resolve_label(plot@layout$panel_scales_y[[1]], labs)),
    c(x.primary = "x", x.secondary = "x.sec",
      y.primary = "y", y.secondary = "y.sec")
  )

  labs <- defaults(xy_labs, labs)

  guides <- plot@plot@guides
  if (length(guides$aesthetics) == 0) {
    return(labs)
  }

  for (aes in guides$aesthetics) {
    param <- guides$get_params(aes)
    aes   <- param$aesthetic # Can have length > 1 when guide was merged
    title <- vec_set_names(rep(list(param$title), length(aes)), aes)
    labs  <- defaults(title, labs)
  }
  labs
}

#' Extract alt text from a plot
#'
#' This function returns a text that can be used as alt-text in webpages etc.
#' Currently it will use the `alt` label, added with `+ labs(alt = <...>)`, or
#' a return an empty string, but in the future it might try to generate an alt
#' text from the information stored in the plot.
#'
#' @param p a ggplot object
#' @inheritParams rlang::args_dots_used
#'
#' @return A text string
#'
#' @export
#' @aliases alt_text
#'
#' @examples
#' p <- ggplot(mpg, aes(displ, hwy)) +
#'   geom_point()
#'
#' # Returns an empty string
#' get_alt_text(p)
#'
#' # A user provided alt text
#' p <- p + labs(
#'   alt = paste("A scatterplot showing the negative correlation between engine",
#'               "displacement as a function of highway miles per gallon")
#' )
#'
#' get_alt_text(p)
#'
get_alt_text <- S7::new_generic("get_alt_text", "p", fun = function(p, ...) {
  warn_dots_used()
  S7::S7_dispatch()
})

S7::method(get_alt_text, class_ggplot) <- function(p, ...) {
  alt <- p@labels[["alt"]] %||% ""
  if (!is.function(alt)) {
    return(alt)
  }
  p@labels[["alt"]] <- NULL
  build <- ggplot_build(p)
  build@plot@labels[["alt"]] <- alt
  get_alt_text(build)
}

S7::method(get_alt_text, class_ggplot_built) <- function(p, ...) {
  alt <- p@plot@labels[["alt"]] %||% ""
  p@plot@labels[["alt"]] <- NULL
  if (is.function(alt)) alt(p@plot) else alt
}

S7::method(get_alt_text, class_gtable) <- function(p, ...) {
  attr(p, "alt-label") %||% ""
}

#' Generate an alt text from a plot
#'
#' This function returns a text that can be used as alt-text in webpages etc.
#' It will synthesize one from the information in the plot itself, but you can
#' add a conclusion to the synthesized text using `+ labs(alt_insight = <...>)`.
#'
#' There is no way an automatically generated description can compete with one
#' written by a human with knowledge of what the plot shows and in which
#' context. We urge users to write their own alt text if at all possible.
#' Guidance to how an effective alt-text is written can be found in
#' [Writing Alt Text for Data Visualization](https://medium.com/nightingale/writing-alt-text-for-data-visualization-2a218ef43f81)
#' and [Effective Practices for Description of Science Content within Digital Talking Books](https://www.wgbh.org/foundation/ncam/guidelines/effective-practices-for-description-of-science-content-within-digital-talking-books)
#'
#' @param p a ggplot object
#'
#' @return A text string
#'
#' @noRd
#'
#' @examples
#' p <- ggplot(mpg, aes(displ, hwy)) +
#'   geom_point()
#'
#' get_alt_text(p)
#'
#' p <- p + ggtitle("The relationship between displacement and yield in cars")
#' get_alt_text(p)
#'
#' # It will use scale information if available
#' p <- p + scale_x_continuous("highway miles per gallon")
#' get_alt_text(p)
#'
#' # Add a short description of the main conclusion of the plot
#' p <- p + labs(alt_insight = "The higher the yield, the lower the displacement")
#' get_alt_text(p)
#'
#' # A user provided alt text takes precedence
#' p <- p + labs(
#'   alt = paste("A scatterplot showing the negative correlation between engine",
#'               "displacement as a function of highway miles per gallon")
#' )
#'
#' get_alt_text(p)
#'
generate_alt_text <- function(p) {
  # Combine titles
  if (!is.null(p@labels$title %||% p@labels$subtitle)) {
    title <- sub("\\.?$", "", c(p@labels$title, p@labels$subtitle))
    if (length(title) == 2) {
      title <- paste0(title[1], ": ", title[2])
    }
    title <- paste0(title, ". ")
    title <- safe_string(title)
  } else {
    title <- ""
  }


  # Get axes descriptions
  axes <- paste0(" showing ", scale_description(p, "x"), " and ", scale_description(p, "y"))
  axes <- safe_string(axes)

  # Get layer types
  layers <- vapply(p@layers, function(l) snake_class(l$geom), character(1))
  layers <- sub("_", " ", sub("^geom_", "", unique0(layers)))
  if (length(layers) == 1) {
    layers <- paste0(" using a ", layers, " layer")
  } else {
    layers <- paste0(" using ", oxford_comma(layers), " layers")
  }
  layers <- safe_string(layers)

  # Combine
  alt <- paste0(title, "A plot", axes, layers, ".")
  if (!is.null(p@labels$alt_insight)) {
    alt <- paste0(alt, " ", p@labels$alt_insight)
  }
  as.character(alt)
}
safe_string <- function(string) {
  if (length(string) == 0) "" else string
}
scale_description <- function(p, name) {
  scale <- p@scales$get_scales(name)
  if (is.null(scale)) {
    lab <- p@labels[[name]]
    type <- "the"
  } else {
    lab <- scale$make_title(scale$name %|W|% p@labels[[name]])
    type <- "a continuous"
    if (scale$is_discrete()) type <- "a discrete"
    if (inherits(scale, "ScaleBinned")) type <- "a binned"
  }
  if (is.null(lab)) {
    return(NULL)
  }
  paste0(lab, " on ", type, " ", name, "-axis")
}