Add alt-text functionality (#4482)

Author: thomasp85

NAMESPACE

@@ -46,6 +46,9 @@ S3method(fortify,sfg)
 S3method(fortify,summary.glht)
 S3method(fortify,tbl)
 S3method(fortify,tbl_df)
+S3method(get_alt_text,ggplot)
+S3method(get_alt_text,ggplot_built)
+S3method(get_alt_text,gtable)
 S3method(ggplot,"function")
 S3method(ggplot,default)
 S3method(ggplot_add,"NULL")
@@ -390,6 +393,7 @@ export(geom_text)
 export(geom_tile)
 export(geom_violin)
 export(geom_vline)
+export(get_alt_text)
 export(get_element_tree)
 export(gg_dep)
 export(ggplot)

NEWS.md

@@ -4,6 +4,11 @@ small selection of feature refinements.
 
 ## Features
 
+* Alt-text can now be added to a plot using the `alt` label, i.e 
+  `+ labs(alt = ...)`. Currently this alt text is not automatically propagated, 
+  but we plan to integrate into Shiny, RMarkdown, and other tools in the future. 
+  (@thomasp85, #4477)
+
 * Add support for the BrailleR package for creating descriptions of the plot
   when rendered (@thomasp85, #4459)
 

R/labels.r

@@ -43,6 +43,8 @@ update_labels <- function(p, labels) {
 #'        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 alt,alt_insight Text used for the generation of alt-text for the plot.
+#'        See [get_alt_text] for examples.
 #' @param ... A list of new name-value pairs. The name should be an aesthetic.
 #' @export
 #' @examples
@@ -67,9 +69,11 @@ update_labels <- function(p, labels) {
 #' p +
 #'  labs(title = "title") +
 #'  labs(title = NULL)
-labs <- function(..., title = waiver(), subtitle = waiver(), caption = waiver(), tag = waiver()) {
+labs <- function(..., title = waiver(), subtitle = waiver(), caption = waiver(),
+                 tag = 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, .ignore_empty = "all")
+  args <- dots_list(..., title = title, subtitle = subtitle, caption = caption,
+    tag = tag, alt = alt, alt_insight = alt_insight, .ignore_empty = "all")
 
   is_waive <- vapply(args, is.waive, logical(1))
   args <- args[!is_waive]
@@ -97,3 +101,147 @@ ylab <- function(label) {
 ggtitle <- function(label, subtitle = waiver()) {
   labs(title = label, subtitle = subtitle)
 }
+
+#' 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
+#' @param ... Currently ignored
+#'
+#' @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 <- function(p, ...) {
+  UseMethod("get_alt_text")
+}
+#' @export
+get_alt_text.ggplot <- function(p, ...) {
+  p$labels[["alt"]] %||% ""
+}
+#' @export
+get_alt_text.ggplot_built <- function(p, ...) {
+  p$plot$labels[["alt"]] %||% ""
+}
+#' @export
+get_alt_text.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
+  title <- glue(glue_collapse(
+    sub("\\.?$", "", c(p$labels$title, p$labels$subtitle)),
+    last = ": "
+  ), ". ")
+  title <- safe_string(title)
+
+  # Get axes descriptions
+  axes <- glue(" showing ", glue_collapse(
+    c(scale_description(p, "x"), scale_description(p, "y")),
+    last = " and "
+  ))
+  axes <- safe_string(axes)
+
+  # Get layer types
+  layers <- vapply(p$layers, function(l) snake_class(l$geom), character(1))
+  layers <- sub("_", " ", sub("^geom_", "", unique(layers)))
+  layers <- glue(
+    " using ",
+    if (length(layers) == 1) "a " else "",
+    glue_collapse(layers, sep = ", ", last = " and "),
+    " layer",
+    if (length(layers) == 1) "" else "s",
+  )
+  layers <- safe_string(layers)
+
+  # Combine
+  alt <- glue_collapse(
+    c(glue("{title}A plot{axes}{layers}"), p$labels$alt_insight),
+    last = ". "
+  )
+  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)
+  }
+  glue("{lab} on {type} {name}-axis")
+}

R/plot-build.r

@@ -105,6 +105,9 @@ ggplot_build.ggplot <- function(plot) {
   # Let Layout modify data before rendering
   data <- layout$finish_data(data)
 
+  # Consolidate alt-text
+  plot$labels$alt <- get_alt_text(plot)
+
   structure(
     list(data = data, layout = layout, plot = plot),
     class = "ggplot_built"
@@ -402,6 +405,10 @@ ggplot_gtable.ggplot_built <- function(data) {
     plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),]
     plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))]
   }
+
+  # add alt-text as attribute
+  attr(plot_table, "alt-label") <- plot$labels$alt
+
   plot_table
 }
 

man/get_alt_text.Rd

@@ -62,6 +62,14 @@ test_that("Labels from default stat mapping are overwritten by default labels",
   expect_equal(p$labels$colour, "drv")
 })
 
+test_that("alt text is returned", {
+  p <- ggplot(mtcars, aes(mpg, disp)) +
+    geom_point()
+  expect_equal(get_alt_text(p), "")
+  p <- p + labs(alt = "An alt text")
+  expect_equal(get_alt_text(p), "An alt text")
+})
+
 
 # Visual tests ------------------------------------------------------------