Labeling small strata

Jason Cory Brunson

2023-02-05

Setup

This brief vignette uses the vaccinations dataset included in {ggalluvial}. As in the technical introduction, the order of the levels is reversed to be more intuitive. Objects from other {ggplot2} extensions are accessed via :: and :::.

knitr::opts_chunk$set(fig.width = 6, fig.height = 4, fig.align = "center")
library(ggalluvial)

## Loading required package: ggplot2

data(vaccinations)
vaccinations <- transform(vaccinations,
                          response = factor(response, rev(levels(response))))

Problem

The issue on the table: Strata are most helpful when they’re overlaid with text labels. Yet the strata often vary in height, and the labels in length, to such a degree that fitting the text inside the strata at a uniform size renders them illegible. In principle, the user could treat size as a variable aesthetic and manually fit text to strata, but this is cumbersome, and doesn’t help anyway in cases where large text is needed.

To illustrate the problem, check out the plot below. It’s by no means an egregious case, but it’ll do. (For a more practical example, see this question on StackOverflow, which prompted this vignette.)

ggplot(vaccinations,
       aes(x = survey, stratum = response, alluvium = subject, y = freq,
           fill = response, label = response)) +
  scale_x_discrete(expand = c(.1, 0)) +
  geom_flow(width = 1/4) +
  geom_stratum(alpha = .5, width = 1/4) +
  geom_text(stat = "stratum", size = 4) +
  theme(legend.position = "none") +
  ggtitle("vaccination survey responses", "labeled using `geom_text()`")

Fix

One option is to simply omit those labels that don’t fit within their strata. In response to an issue, v0.9.2 includes parameters in stat_stratum() to exclude strata outside a specified height range; while few would use this to omit the rectangles themselves, it can be used in tandem with geom_text() to shirk this problem, at least when the labels are concise:

ggplot(vaccinations,
       aes(x = survey, stratum = response, alluvium = subject, y = freq,
           fill = response, label = response)) +
  scale_x_discrete(expand = c(.1, 0)) +
  geom_flow(width = 1/4) +
  geom_stratum(alpha = .5, width = 1/4) +
  geom_text(stat = "stratum", size = 4, min.y = 100) +
  theme(legend.position = "none") +
  ggtitle(
    "vaccination survey responses",
    "labeled using `geom_text()` with `min.y = 100`"
  )

This is a useful fix for some cases. Still, if the goal is a publication-ready graphic, then it reaffirms the need for more adaptable and elegant solutions. Fortunately, two wonderful packages deliver with, shall we say, flowing colors.

Solutions

Two {ggplot2} extensions are well-suited to this problem: {ggrepel} and {ggfittext}. They provide new geom layers that use the output of existing stat layers to situate text: ggrepel::geom_text_repel() takes the same aesthetics as ggplot2::geom_text(), namely x, y, and label. In contrast, ggfittext::geom_fit_text() only specifically requires label but also needs enough information to determine the rectangle that will contain the text. This can be encoded as xmin and xmax or as x and width for the horizontal direction, and as ymin and ymax or as y and height for the vertical direction. Conveniently, ggalluvial::stat_stratum() produces more than enough information for both geoms, including x, xmin, xmax, and their vertical counterparts.

All this can be gleaned from the ggproto objects that construct the layers:

print(ggrepel::GeomTextRepel$required_aes)

## [1] "x"     "y"     "label"

print(ggfittext:::GeomFitText$required_aes)

## [1] "label"

print(ggfittext:::GeomFitText$setup_data)

## <ggproto method>
##   <Wrapper function>
##     function (...) 
## setup_data(...)
## 
##   <Inner function (f)>
##     function (data, params) 
## {
##     if (!(("xmin" %in% names(data) & "xmax" %in% names(data)) | 
##         ("x" %in% names(data)))) {
##         stop("geom_fit_text needs either 'xmin' and 'xmax', or 'x'", 
##             .call = FALSE)
##     }
##     if (!("ymin" %in% names(data) & "ymax" %in% names(data) | 
##         "y" %in% names(data))) {
##         stop("geom_fit_text needs either 'ymin' and 'ymax', or 'y'", 
##             .call = FALSE)
##     }
##     if ((!is.null(params$width)) & (!"unit" %in% class(params$width))) {
##         data$xmin <- data$x - params$width/2
##         data$xmax <- data$x + params$width/2
##     }
##     if ((!is.null(params$height)) & (!"unit" %in% class(params$height))) {
##         data$ymin <- data$y - params$height/2
##         data$ymax <- data$y + params$height/2
##     }
##     if (is.null(params$width) & !"xmin" %in% names(data)) {
##         data$width <- ggplot2::resolution(data$x, FALSE) * 0.9
##         data$xmin <- data$x - data$width/2
##         data$xmax <- data$x + data$width/2
##         data$width <- NULL
##     }
##     if (is.null(params$height) & !"ymin" %in% names(data)) {
##         data$height <- ggplot2::resolution(data$y, FALSE) * 0.9
##         data$ymin <- data$y - data$height/2
##         data$ymax <- data$y + data$height/2
##         data$height <- NULL
##     }
##     if (!is.null(params$formatter)) {
##         if (!is.function(params$formatter)) {
##             stop("`formatter` must be a function")
##         }
##         formatted_labels <- sapply(data$label, params$formatter, 
##             USE.NAMES = FALSE)
##         if ((!length(formatted_labels) == length(data$label)) | 
##             (!is.character(formatted_labels))) {
##             stop("`formatter` must produce a character vector of same length as input")
##         }
##         data$label <- formatted_labels
##     }
##     data
## }

print(StatStratum$compute_panel)

## <ggproto method>
##   <Wrapper function>
##     function (...) 
## compute_panel(..., self = self)
## 
##   <Inner function (f)>
##     function (self, data, scales, decreasing = NULL, reverse = NULL, 
##     absolute = NULL, discern = FALSE, distill = first, negate.strata = NULL, 
##     infer.label = FALSE, label.strata = NULL, min.y = NULL, max.y = NULL, 
##     min.height = NULL, max.height = NULL) 
## {
##     if (is.null(decreasing)) 
##         decreasing <- ggalluvial_opt("decreasing")
##     if (is.null(reverse)) 
##         reverse <- ggalluvial_opt("reverse")
##     if (is.null(absolute)) 
##         absolute <- ggalluvial_opt("absolute")
##     if (!is.null(label.strata)) {
##         defunct_parameter("label.strata", msg = "use `aes(label = after_stat(stratum))`.")
##         infer.label <- label.strata
##     }
##     if (infer.label) {
##         deprecate_parameter("infer.label", msg = "Use `aes(label = after_stat(stratum))`.")
##         if (is.null(data$label)) {
##             data$label <- data$stratum
##         }
##         else {
##             warning("Aesthetic `label` is specified, ", "so parameter `infer.label` will be ignored.")
##         }
##     }
##     diff_aes <- intersect(c(.color_diff_aesthetics, .text_aesthetics), 
##         names(data))
##     data$yneg <- data$y < 0
##     data$lode <- data$alluvium
##     distill <- distill_fun(distill)
##     weight <- data$weight
##     data$weight <- NULL
##     if (is.null(weight)) 
##         weight <- 1
##     data$n <- weight
##     data$count <- data$y * weight
##     by_vars <- c("x", "yneg", "stratum")
##     only_vars <- c(diff_aes)
##     sum_vars <- c("y", "n", "count")
##     if (!is.null(data$lode)) {
##         agg_lode <- stats::aggregate(data[, "lode", drop = FALSE], 
##             data[, by_vars], distill)
##     }
##     if (length(only_vars) > 0) {
##         agg_only <- stats::aggregate(data[, only_vars, drop = FALSE], 
##             data[, by_vars], only)
##     }
##     data <- stats::aggregate(data[, sum_vars], data[, by_vars], 
##         sum)
##     if (!is.null(data$lode)) {
##         data <- merge(data, agg_lode)
##     }
##     if (length(only_vars) > 0) {
##         data <- merge(data, agg_only)
##     }
##     data <- subset(data, y != 0)
##     data <- deposit_data(data, decreasing, reverse, absolute)
##     x_sums <- tapply(abs(data$count), data$x, sum, na.rm = TRUE)
##     data$prop <- data$count/x_sums[match(as.character(data$x), 
##         names(x_sums))]
##     data <- data[with(data, order(deposit)), , drop = FALSE]
##     data$ycum <- NA
##     for (xx in unique(data$x)) {
##         for (yn in c(FALSE, TRUE)) {
##             ww <- which(data$x == xx & data$yneg == yn)
##             data$ycum[ww] <- cumulate(data$y[ww])
##         }
##     }
##     data$ymin <- data$ycum - abs(data$y)/2
##     data$ymax <- data$ycum + abs(data$y)/2
##     data$y <- data$ycum
##     data$yneg <- NULL
##     data$ycum <- NULL
##     if (!is.null(min.height)) {
##         deprecate_parameter("min.height", "min.y")
##         min.y <- min.height
##     }
##     if (!is.null(max.height)) {
##         deprecate_parameter("max.height", "max.y")
##         max.y <- max.height
##     }
##     if (!is.null(min.y)) 
##         data <- subset(data, ymax - ymin >= min.y)
##     if (!is.null(max.y)) 
##         data <- subset(data, ymax - ymin <= max.y)
##     data
## }

I reached the specific solutions through trial and error. They may not be the best tricks for most cases, but they demonstrate what these packages can do. For many more examples, see the respective package vignettes: for {ggrepel}, and for {ggfittext}.

Solution 1: {ggrepel}

{ggrepel} is most often (in my experience) used to repel text away from symbols in a scatterplot, in whatever directions prevent them from overlapping the symbols and each other. In this case, however, it makes much more sense to align them vertically a fixed horizontal distance (nudge_x) away from the strata and repel them vertically from each other (direction = "y") just enough to print them without overlap. It takes an extra bit of effort to render text only for the strata at the first (or at the last) axis, but the result is worth it.

ggplot(vaccinations,
       aes(x = survey, stratum = response, alluvium = subject, y = freq,
           fill = response)) +
  scale_x_discrete(expand = c(.4, 0)) +
  geom_flow(width = 1/4) +
  geom_stratum(alpha = .5, width = 1/4) +
  scale_linetype_manual(values = c("blank", "solid")) +
  ggrepel::geom_text_repel(
    aes(label = ifelse(as.numeric(survey) == 1, as.character(response), NA)),
    stat = "stratum", size = 4, direction = "y", nudge_x = -.5
  ) +
  ggrepel::geom_text_repel(
    aes(label = ifelse(as.numeric(survey) == 3, as.character(response), NA)),
    stat = "stratum", size = 4, direction = "y", nudge_x = .5
  ) +
  theme(legend.position = "none") +
  ggtitle("vaccination survey responses", "labeled using `geom_text_repel()`")

## Warning: Removed 8 rows containing missing values (`geom_text_repel()`).
## Removed 8 rows containing missing values (`geom_text_repel()`).

Solution 2: {ggfittext}

{ggfittext} is simplicity itself: The strata are just rectangles, so no more parameter specifications are necessary to fit the text into them. One key parameter is min.size, which defaults to 4 and controls how small the text is allowed to get without being omitted.

ggplot(vaccinations,
       aes(x = survey, stratum = response, alluvium = subject, y = freq,
           fill = response, label = response)) +
  scale_x_discrete(expand = c(.1, 0)) +
  geom_flow(width = 1/4) +
  geom_stratum(alpha = .5, width = 1/4) +
  ggfittext::geom_fit_text(stat = "stratum", width = 1/4, min.size = 3) +
  theme(legend.position = "none") +
  ggtitle("vaccination survey responses", "labeled using `geom_fit_text()`")

Note that this solution requires {ggfittext} v0.6.0.

Appendix

sessioninfo::session_info()

## ─ Session info ───────────────────────────────────────────────────────────────
##  setting  value
##  version  R version 4.2.1 (2022-06-23)
##  os       macOS Catalina 10.15.7
##  system   x86_64, darwin17.0
##  ui       X11
##  language en
##  collate  en_US.UTF-8
##  ctype    en_US.UTF-8
##  tz       America/New_York
##  date     2023-02-05
##  pandoc   2.19.2 @ /Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools/ (via rmarkdown)
## 
## ─ Packages ───────────────────────────────────────────────────────────────────
##  package     * version date (UTC) lib source
##  bslib         0.4.2   2022-12-16 [2] CRAN (R 4.2.0)
##  cachem        1.0.6   2021-08-19 [2] CRAN (R 4.2.0)
##  cli           3.6.0   2023-01-09 [2] CRAN (R 4.2.0)
##  colorspace    2.1-0   2023-01-23 [2] CRAN (R 4.2.0)
##  desc          1.4.2   2022-09-08 [2] CRAN (R 4.2.0)
##  digest        0.6.31  2022-12-11 [2] CRAN (R 4.2.0)
##  dplyr         1.1.0   2023-01-29 [2] CRAN (R 4.2.0)
##  evaluate      0.20    2023-01-17 [2] CRAN (R 4.2.0)
##  fansi         1.0.4   2023-01-22 [2] CRAN (R 4.2.0)
##  farver        2.1.1   2022-07-06 [2] CRAN (R 4.2.0)
##  fastmap       1.1.0   2021-01-25 [2] CRAN (R 4.2.0)
##  fs            1.6.0   2023-01-23 [2] CRAN (R 4.2.0)
##  generics      0.1.3   2022-07-05 [2] CRAN (R 4.2.0)
##  ggalluvial  * 0.12.4  2023-02-05 [1] local
##  ggfittext     0.9.1   2021-01-30 [2] CRAN (R 4.2.0)
##  ggplot2     * 3.4.0   2022-11-04 [2] CRAN (R 4.2.1)
##  ggrepel       0.9.2   2022-11-06 [2] CRAN (R 4.2.0)
##  glue          1.6.2   2022-02-24 [2] CRAN (R 4.2.0)
##  gtable        0.3.1   2022-09-01 [2] CRAN (R 4.2.0)
##  highr         0.10    2022-12-22 [2] CRAN (R 4.2.0)
##  htmltools     0.5.4   2022-12-07 [2] CRAN (R 4.2.0)
##  jquerylib     0.1.4   2021-04-26 [2] CRAN (R 4.2.0)
##  jsonlite      1.8.4   2022-12-06 [2] CRAN (R 4.2.0)
##  knitr         1.42    2023-01-25 [2] CRAN (R 4.2.0)
##  labeling      0.4.2   2020-10-20 [2] CRAN (R 4.2.0)
##  lifecycle     1.0.3   2022-10-07 [2] CRAN (R 4.2.0)
##  magrittr      2.0.3   2022-03-30 [2] CRAN (R 4.2.0)
##  memoise       2.0.1   2021-11-26 [2] CRAN (R 4.2.0)
##  munsell       0.5.0   2018-06-12 [2] CRAN (R 4.2.0)
##  pillar        1.8.1   2022-08-19 [2] CRAN (R 4.2.0)
##  pkgconfig     2.0.3   2019-09-22 [2] CRAN (R 4.2.0)
##  pkgdown       2.0.7   2022-12-14 [2] CRAN (R 4.2.0)
##  purrr         1.0.1   2023-01-10 [2] CRAN (R 4.2.0)
##  R6            2.5.1   2021-08-19 [2] CRAN (R 4.2.0)
##  ragg          1.2.5   2023-01-12 [2] CRAN (R 4.2.0)
##  Rcpp          1.0.10  2023-01-22 [2] CRAN (R 4.2.1)
##  rlang         1.0.6   2022-09-24 [2] CRAN (R 4.2.0)
##  rmarkdown     2.20    2023-01-19 [2] CRAN (R 4.2.0)
##  rprojroot     2.0.3   2022-04-02 [2] CRAN (R 4.2.0)
##  rstudioapi    0.14    2022-08-22 [2] CRAN (R 4.2.0)
##  sass          0.4.5   2023-01-24 [2] CRAN (R 4.2.0)
##  scales        1.2.1   2022-08-20 [2] CRAN (R 4.2.0)
##  sessioninfo   1.2.2   2021-12-06 [2] CRAN (R 4.2.0)
##  stringi       1.7.12  2023-01-11 [2] CRAN (R 4.2.0)
##  stringr       1.5.0   2022-12-02 [2] CRAN (R 4.2.0)
##  systemfonts   1.0.4   2022-02-11 [2] CRAN (R 4.2.0)
##  textshaping   0.3.6   2021-10-13 [2] CRAN (R 4.2.0)
##  tibble        3.1.8   2022-07-22 [2] CRAN (R 4.2.0)
##  tidyr         1.3.0   2023-01-24 [2] CRAN (R 4.2.0)
##  tidyselect    1.2.0   2022-10-10 [2] CRAN (R 4.2.0)
##  utf8          1.2.3   2023-01-31 [2] CRAN (R 4.2.1)
##  vctrs         0.5.2   2023-01-23 [2] CRAN (R 4.2.0)
##  withr         2.5.0   2022-03-03 [2] CRAN (R 4.2.0)
##  xfun          0.37    2023-01-31 [2] CRAN (R 4.2.1)
##  yaml          2.3.7   2023-01-23 [2] CRAN (R 4.2.0)
## 
##  [1] /private/var/folders/k6/l4mq9ctj3219429xnvqpdbxm8tckkx/T/RtmpByirPq/temp_libpath286664e155c7
##  [2] /Library/Frameworks/R.framework/Versions/4.2/Resources/library
## 
## ──────────────────────────────────────────────────────────────────────────────