Add strategies to deal with overlapping text in draw_axis() (#3375)

* add visual test cases for basic axis drawing

* add check.overlap option for removing overlapping axis labels (recursively prioritizing the "middle" label)

* add axis label rotation and heuristics to set best hjust and vjust to draw_axis()

* add support for axis label dodging into multiple rows/cols

* update documentation for new axis options

Author: paleolimbot

R/guides-axis.r

@@ -4,11 +4,20 @@
 #' @param break_position position of ticks
 #' @param break_labels labels at ticks
 #' @param axis_position position of axis (top, bottom, left or right)
-#' @param theme A [theme()] object
+#' @param theme A complete [theme()] object
+#' @param check.overlap silently remove overlapping labels,
+#'   (recursively) prioritizing the first, last, and middle labels.
+#' @param angle Compared to setting the angle in [theme()] / [element_text()],
+#'   this also uses some heuristics to automatically pick the `hjust` and `vjust` that
+#'   you probably want.
+#' @param n_dodge The number of rows (for vertical axes) or columns (for
+#'   horizontal axes) that should be used to render the labels. This is
+#'   useful for displaying labels that would otherwise overlap.
 #'
 #' @noRd
 #'
-draw_axis <- function(break_positions, break_labels, axis_position, theme) {
+draw_axis <- function(break_positions, break_labels, axis_position, theme,
+                      check.overlap = FALSE, angle = NULL, n_dodge = 1) {
 
   axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left"))
   aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y"
@@ -24,17 +33,24 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme) {
   tick_length <- calc_element(tick_length_element_name, theme)
   label_element <- calc_element(label_element_name, theme)
 
+  # override label element parameters for rotation
+  if (inherits(label_element, "element_text")) {
+    label_element <- merge_element(
+      axis_label_element_overrides(axis_position, angle),
+      label_element
+    )
+  }
+
   # conditionally set parameters that depend on axis orientation
   is_vertical <- axis_position %in% c("left",  "right")
 
   position_dim <- if (is_vertical) "y" else "x"
   non_position_dim <- if (is_vertical) "x" else "y"
   position_size <- if (is_vertical) "height" else "width"
   non_position_size <- if (is_vertical) "width" else "height"
-  label_margin_name <- if (is_vertical) "margin_x" else "margin_y"
   gtable_element <- if (is_vertical) gtable_row else gtable_col
   measure_gtable <- if (is_vertical) gtable_width else gtable_height
-  measure_labels <- if (is_vertical) grobWidth else grobHeight
+  measure_labels_non_pos <- if (is_vertical) grobWidth else grobHeight
 
   # conditionally set parameters that depend on which side of the panel
   # the axis is on
@@ -47,8 +63,6 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme) {
   # conditionally set the gtable ordering
   labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable
 
-  table_order <- if (labels_first_gtable) c("labels", "ticks") else c("ticks", "labels")
-
   # set common parameters
   n_breaks <- length(break_positions)
   opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right")
@@ -80,12 +94,19 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme) {
     }
   }
 
-  labels_grob <- exec(
-    element_grob, label_element,
-    !!position_dim := unit(break_positions, "native"),
-    !!label_margin_name := TRUE,
-    label = break_labels
-  )
+  # calculate multiple rows/columns of labels (which is usually 1)
+  dodge_pos <- rep(seq_len(n_dodge), length.out = n_breaks)
+  dodge_indices <- split(seq_len(n_breaks), dodge_pos)
+
+  label_grobs <- lapply(dodge_indices, function(indices) {
+    draw_axis_labels(
+      break_positions = break_positions[indices],
+      break_labels = break_labels[indices],
+      label_element = label_element,
+      is_vertical = is_vertical,
+      check.overlap = check.overlap
+    )
+  })
 
   ticks_grob <- exec(
     element_grob, tick_element,
@@ -98,14 +119,21 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme) {
   )
 
   # create gtable
-  table_order_int <- match(table_order, c("labels", "ticks"))
   non_position_sizes <- paste0(non_position_size, "s")
+  label_dims <- do.call(unit.c, lapply(label_grobs, measure_labels_non_pos))
+  grobs <- c(list(ticks_grob), label_grobs)
+  grob_dims <- unit.c(tick_length, label_dims)
+
+  if (labels_first_gtable) {
+    grobs <- rev(grobs)
+    grob_dims <- rev(grob_dims)
+  }
 
   gt <- exec(
     gtable_element,
     name = "axis",
-    grobs = list(labels_grob, ticks_grob)[table_order_int],
-    !!non_position_sizes := unit.c(measure_labels(labels_grob), tick_length)[table_order_int],
+    grobs = grobs,
+    !!non_position_sizes := grob_dims,
     !!position_size := unit(1, "npc")
   )
 
@@ -124,3 +152,106 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme) {
     vp = justvp
   )
 }
+
+draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical,
+                             check.overlap = FALSE) {
+
+  position_dim <- if (is_vertical) "y" else "x"
+  label_margin_name <- if (is_vertical) "margin_x" else "margin_y"
+
+  n_breaks <- length(break_positions)
+  break_positions <- unit(break_positions, "native")
+
+  if (check.overlap) {
+    priority <- axis_label_priority(n_breaks)
+    break_labels <- break_labels[priority]
+    break_positions <- break_positions[priority]
+  }
+
+  labels_grob <- exec(
+    element_grob, label_element,
+    !!position_dim := break_positions,
+    !!label_margin_name := TRUE,
+    label = break_labels,
+    check.overlap = check.overlap
+  )
+}
+
+#' Determine the label priority for a given number of labels
+#'
+#' @param n The number of labels
+#'
+#' @return The vector `seq_len(n)` arranged such that the
+#'   first, last, and middle elements are recursively
+#'   placed at the beginning of the vector.
+#' @noRd
+#'
+axis_label_priority <- function(n) {
+  if (n <= 0) {
+    return(numeric(0))
+  }
+
+  c(1, n, axis_label_priority_between(1, n))
+}
+
+axis_label_priority_between <- function(x, y) {
+  n <- y - x + 1
+  if (n <= 2) {
+    return(numeric(0))
+  }
+
+  mid <- x - 1 + (n + 1) %/% 2
+  c(
+    mid,
+    axis_label_priority_between(x, mid),
+    axis_label_priority_between(mid, y)
+  )
+}
+
+#' Override axis text angle and alignment
+#'
+#' @param axis_position One of bottom, left, top, or right
+#' @param angle The text angle, or NULL to override nothing
+#'
+#' @return An [element_text()] that contains parameters that should be
+#'   overridden from the user- or theme-supplied element.
+#' @noRd
+#'
+axis_label_element_overrides <- function(axis_position, angle = NULL) {
+  if (is.null(angle)) {
+    return(element_text(angle = NULL, hjust = NULL, vjust = NULL))
+  }
+
+  # it is not worth the effort to align upside-down labels properly
+  if (angle > 90 || angle < -90) {
+    stop("`angle` must be between 90 and -90", call. = FALSE)
+  }
+
+  if (axis_position == "bottom") {
+    element_text(
+      angle = angle,
+      hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5,
+      vjust = if (abs(angle) == 90) 0.5 else 1
+    )
+  } else if (axis_position == "left") {
+    element_text(
+      angle = angle,
+      hjust = if (abs(angle) == 90) 0.5 else 1,
+      vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5,
+    )
+  } else if (axis_position == "top") {
+    element_text(
+      angle = angle,
+      hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5,
+      vjust = if (abs(angle) == 90) 0.5 else 0
+    )
+  } else if (axis_position == "right") {
+    element_text(
+      angle = angle,
+      hjust = if (abs(angle) == 90) 0.5 else 0,
+      vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5,
+    )
+  } else {
+    stop("Unrecognized position: '", axis_position, "'", call. = FALSE)
+  }
+}

R/margins.R

@@ -37,7 +37,7 @@ margin_width <- function(grob, margins) {
 #'
 #' @noRd
 title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
-                       debug = FALSE) {
+                       debug = FALSE, check.overlap = FALSE) {
 
   if (is.null(label)) return(zeroGrob())
 
@@ -56,7 +56,8 @@ title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(),
     hjust = hjust,
     vjust = vjust,
     rot = angle,
-    gp = gp
+    gp = gp,
+    check.overlap = check.overlap
   )
 
   # The grob dimensions don't include the text descenders, so these need to be added
@@ -175,7 +176,7 @@ add_margins <- function(grob, height, width, margin = NULL,
 #' @noRd
 titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(),
                       margin = NULL, margin_x = FALSE, margin_y = FALSE,
-                      debug = FALSE) {
+                      debug = FALSE, check.overlap = FALSE) {
 
   if (is.null(label))
     return(zeroGrob())
@@ -189,7 +190,8 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(),
     vjust = vjust,
     angle = angle,
     gp = gp,
-    debug = debug
+    debug = debug,
+    check.overlap = check.overlap
   )
 
   add_margins(

R/theme-elements.r

@@ -215,7 +215,7 @@ element_grob.element_text <- function(element, label = "", x = NULL, y = NULL,
 
   titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle,
     gp = modify_list(element_gp, gp), margin = margin,
-    margin_x = margin_x, margin_y = margin_y, debug = element$debug)
+    margin_x = margin_x, margin_y = margin_y, debug = element$debug, ...)
 }