R/ord_labels.R

In david-barnett/microViz: Microbiome Data Analysis and Visualization

# internal functions for adding labels for arrows/vectors to ordination plots
# and below that the user facing *_lab_style helper functions

#' Draw labels on ggplot ordination at tips of arrows/segments/vectors
#'
#' @param p ggplot ordination
#' @param data positions of label reference points on axes
#' @param renamer
#' function (originally user-provided, e.g. taxon_renamer)
#' that modifies original labels (as taken from rownames of data)
#' @param styleList list of aesthetics e.g. generated by a *_lab_style helper
#' @param axesNames names of axes to plot
#' @param defaultStyles
#' default label style list (either tax_lab_style() or constraint_lab_style())
#'
#' @return ggplot
#' @noRd
ord_labels <- function(p,
                       data,
                       renamer,
                       styleList,
                       axesNames,
                       defaultStyles = tax_lab_style()) {
  # list of non-style arguments (not provided by user)
  args <- list(
    data = data, label = renamer(rownames(data)),
    mapping = ggplot2::aes(x = .data[[axesNames[1]]], y = .data[[axesNames[2]]])
  )
  # overwrite (some) default style aspects with whatever user provided
  styles <- defaultStyles
  styles[names(styleList)] <- styleList

  # use special elements and delete them from styles list before use
  # handle type: label or text
  if (identical(styles[["type"]], "text")) {
    geomFun <- ggplot2::geom_text
  } else if (identical(styles[["type"]], "richtext")) {
    rlang::check_installed("ggtext", reason = "to use type = 'richtext'")
    geomFun <- ggtext::geom_richtext
  } else if (identical(styles[["type"]], "label")) {
    if (styles[["max_angle"]] > 0) {
      rlang::check_installed("ggtext", reason = "to rotate type = 'label'")
      geomFun <- ggtext::geom_richtext
    } else {
      geomFun <- ggplot2::geom_label
    }
  } else {
    stop("tax_lab_style() `type` argument must be 'text' or 'label'")
  }

  # calculate angles if max_angle not zero
  if (styles[["max_angle"]] > 0) {
    styles[["angle"]] <- textAngleCalc(
      xvec = data[[axesNames[1]]], yvec = data[[axesNames[2]]],
      perpendicular = styles[["perpendicular"]],
      ratio = styles[["aspect_ratio"]], max = styles[["max_angle"]]
    )
  }

  # calculate hjust vector if justify is "side", not "center"
  if (styles[["justify"]] %in% c("side", "sides")) {
    styles[["hjust"]] <- textHjustCalc(xvec = data[[axesNames[1]]])
  } else if (!styles[["justify"]] %in% c("center", "centre")) {
    stop("tax_lab_style() `justify` argument must be 'side' or 'center'")
  }

  # remove special/non-aesthetic entries in style list
  styles[c(
    "type", "max_angle", "perpendicular", "aspect_ratio", "justify"
  )] <- NULL

  # add labels and return plot
  p <- p + do.call(what = geomFun, args = c(args, styles))
  return(p)
}


#' @title Helpers for ord_plot label adjustments
#' @description
#' Consider moving these functions to tax_lab_style() man page/.R file.
#'
#' See functions section.
#'
#' @param xvec numeric vector of values used for x axis
#' @param yvec numeric vector of values used for y axis
#' @param max
#' maximum absolute numeric value of angle in degrees to return
#' (for rotating text/labels)
#' @param ratio
#' adjustment for aspect ratio of plot when setting a fixed coordinate aspect
#' ratio with coord_fixed (advised)
#' @param adjust logical, apply hjust or not (FALSE means return only 0.5)
#'
#' @return
#' numeric vector representing either angles to rotate geom_text
#' labels, or hjust values
#' @export
#' @keywords internal
#' @describeIn
#' ord_plot-label-helpers
#' Calculate rotation of text labels for ordination plot
#'
#' @examples
#' library(ggplot2)
#' library(dplyr)
#'
#' # create basic ggplot for labelling
#'
#' df <- mtcars %>% mutate(across(everything(), scale))
#'
#' p <- ggplot(df, aes(mpg, hp, label = rownames(df))) +
#'   geom_segment(xend = 0, yend = 0, color = "lightgrey") +
#'   annotate(x = 0, y = 0, geom = "point", size = 4) +
#'   theme_minimal()
#'
#' p
#'
#' # calculate new variable within aes mapping non-standard evaluation
#' p +
#'   geom_text(size = 2.5, mapping = aes(angle = textAngleCalc(mpg, hp))) +
#'   coord_fixed(ratio = 1)
#'
#' # equivalent: calculate variable outside aes by referring to dataframe again
#' p +
#'   geom_text(size = 2.5, angle = textAngleCalc(df$mpg, df$hp)) +
#'   coord_fixed(ratio = 1)
#'
#' # fixing aspect ratio is important
#' # see how angles may be incorrect otherwise
#' p +
#'   geom_text(size = 2.5, mapping = aes(angle = textAngleCalc(mpg, hp)))
#'
#' # ratio argument allows matching angles with alternative aspect ratio
#' p +
#'   geom_text(size = 2.5, angle = textAngleCalc(df$mpg, df$hp, ratio = .5)) +
#'   coord_fixed(ratio = .5)
#'
#' p +
#'   geom_text(size = 2.5, angle = textAngleCalc(df$mpg, df$hp, ratio = 1.5)) +
#'   coord_fixed(ratio = 1.5)
#'
#' # perpendicular argument makes text perpendicular instead of parallel
#' p +
#'   geom_text(
#'     check_overlap = TRUE, size = 2.5,
#'     angle = textAngleCalc(df$mpg, df$hp, perpendicular = TRUE, ratio = 1.5)
#'   ) +
#'   coord_fixed(ratio = 1.5, clip = "off")
#'
#' # max angle limits extreme text angles
#' p +
#'   geom_text(
#'     size = 2.5, check_overlap = TRUE,
#'     angle = textAngleCalc(df$mpg, df$hp, ratio = 2, max = 10),
#'     hjust = textHjustCalc(xvec = df$mpg, adjust = TRUE)
#'   ) +
#'   coord_fixed(ratio = 2, clip = "off")
textAngleCalc <- function(xvec, yvec,
                          max = 90, ratio = 1,
                          perpendicular = FALSE) {
  if (!is.numeric(xvec)) rlang::abort("xvec must be a numeric vector")
  if (!is.numeric(yvec)) rlang::abort("yvec must be a numeric vector")

  # strip attributes, otherwise dplyr::if_else complains if a vec was scaled
  xvec <- as.vector(xvec)
  yvec <- as.vector(yvec)

  # replace exact zeros
  xvec[xvec == 0] <- 1e-6

  # calculate angles of vectors and convert to degrees from radians
  degs <- (180 / pi) * atan(ratio * yvec / xvec)

  # make angles perpendicular if requested
  if (isTRUE(perpendicular)) {
    degs <- degs + ((-sign(degs)) * 90)
  }

  # ensure maximum desired angle is not exceeded
  degs <- dplyr::if_else(abs(degs) > max, true = sign(degs) * max, false = degs)

  return(degs)
}

#' @export
#' @keywords internal
#' @describeIn
#' ord_plot-label-helpers
#' Calculate hjust of text labels for ordination plot
textHjustCalc <- function(xvec, adjust = TRUE) {
  if (!is.numeric(xvec)) rlang::abort("xvec must be a numeric vector")

  # strip attributes, otherwise dplyr::if_else complains if a vec was scaled
  xvec <- as.vector(xvec)

  if (isTRUE(adjust)) {
    hjust <- dplyr::if_else(xvec < 0, true = 1, false = 0)
  } else {
    hjust <- 0.5
  }
  return(hjust)
}

#' @name Ordination-labels
#' @rdname Ordination-labels
#' @aliases tax_lab_style constraint_lab_style
#' @title Create list for ord_plot() *_lab_style arguments
#'
#' @description
#' Customise taxa and constraint labels on your ordination plots.
#' Choose 'text' or 'label' type, rotate and/or justify the text/labels
#' and set aesthetic appearances using `tax_lab_style()` or
#' `constraint_lab_style()`.
#'
#' @param type
#' 'label', 'text' or 'richtext'
#' ('richtext' also used if 'label' type are rotated, when max_angle > 0)
#' @param max_angle
#' maximum angle of rotation to allow to match vector angle
#' (requires ggtext package to rotate "label" type)
#' @param perpendicular
#' if TRUE, sets rotated labels perpendicular to desired angle, not parallel
#' @param aspect_ratio
#' aspect ratio of plot (y/x) must also be used in coord_fixed() ratio argument
#' (must be set when rotated labels are used, to ensure match to arrow angles)
#' @param justify
#' "center", "side", or "auto"?
#' Should the text/label align with the arrows at the text center or text sides
#' (uses hjust, if 'auto', picks based on whether max_angle is greater than 0)
#' @param size fixed size of text or label
#' @param alpha fixed alpha of text or label
#' @param colour fixed colour of text or label
#' @param ...
#' further named arguments passed to geom_text, geom_label or geom_richtext
#'
#' @return named list
#' @export
#'
#' @examples
#' # These examples show styling of taxa labels with tax_lab_style().
#' # The same options are available for constraint labels in constrained
#' # ordinations. constraint_lab_style() just has different default settings.
#'
#' library(ggplot2)
#'
#' # get example inflammatory bowel disease stool dataset from corncob package
#' data("ibd", package = "microViz")
#'
#' # filter out rare taxa and clean up names etc
#' ibd <- ibd %>%
#'   tax_filter(min_prevalence = 3) %>%
#'   tax_fix() %>%
#'   phyloseq_validate()
#'
#' # calculate a centered-log-ratio transformed PCA ordination
#' ibd_ord <- ibd %>%
#'   tax_transform("clr", rank = "Genus") %>%
#'   ord_calc("PCA")
#'
#' # basic plot with default label style
#' ibd_ord %>% ord_plot(color = "ibd", plot_taxa = 1:10)
#'
#' # Rotating labels: requires the ggtext package #
#' # A fixed coordinate ratio must be set to ensure label rotation
#' # matches the vectors. It is also helpful to set the vector and label length
#' # multipliers manually for a good look. Rotated labels are justified to the
#' # 'sides' automatically by tax_lab_style() with justify = 'auto'
#' ibd_ord %>%
#'   ord_plot(
#'     color = "ibd", plot_taxa = 1:7,
#'     tax_vec_length = 1.3, tax_lab_length = 1.3,
#'     tax_lab_style = tax_lab_style(max_angle = 90)
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' # You can use text instead of labels
#' # - a bold fontface helps text to stand out
#' # - see ?ggplot2::geom_text for all settings available
#' ibd_ord %>%
#'   ord_plot(
#'     color = "ibd", plot_taxa = 1:7,
#'     tax_vec_length = 1.3, tax_lab_length = 1.4,
#'     tax_lab_style = tax_lab_style(
#'       type = "text", max_angle = 90, size = 2.5, fontface = "bold.italic"
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' # With text you can prevent overlaps with check_overlap = TRUE
#' ibd_ord %>%
#'   ord_plot(
#'     color = "ibd", plot_taxa = 1:12,
#'     tax_vec_length = 1.3, tax_lab_length = 1.4,
#'     tax_lab_style = tax_lab_style(
#'       type = "text", max_angle = 90, size = 3, fontface = "bold.italic",
#'       check_overlap = TRUE
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' # With labels, you can reduce the padding and line weight to free space
#' # but check_overlap is not available
#' # see ?ggtext::geom_richtext for more possibilities
#' ibd_ord %>%
#'   ord_plot(
#'     color = "ibd", plot_taxa = 1:7,
#'     tax_vec_length = 1.3, tax_lab_length = 1.35,
#'     tax_lab_style = tax_lab_style(
#'       max_angle = 90, fontface = "italic", size = 2.5, fill = "grey95",
#'       label.size = 0.1, # width outline
#'       label.padding = unit(0.1, "lines"),
#'       label.r = unit(0, "lines") # reduces rounding of corners to radius 0
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' # Perpendicular angled labels/text are possible
#' ibd_ord %>%
#'   ord_plot(
#'     color = "ibd", plot_taxa = 1:12,
#'     tax_lab_style = tax_lab_style(
#'       type = "text", max_angle = 90, perpendicular = TRUE, size = 3,
#'       check_overlap = TRUE
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#'
#' # You can limit and/or attenuate the angle of rotation by:
#' #  - setting a lower max_angle
#' #  - decreasing the aspect_ratio in the tax_lab_style call
#' ibd_ord %>%
#'   ord_plot(
#'     shape = "circle", color = "ibd", plot_taxa = 1:7,
#'     tax_vec_length = 1.3, tax_lab_length = 1.3,
#'     tax_lab_style = tax_lab_style(
#'       max_angle = 10, size = 2, label.size = 0.1,
#'       label.padding = unit(0.1, "lines"), label.r = unit(0, "lines")
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' ibd_ord %>%
#'   ord_plot(
#'     shape = "circle", color = "ibd", plot_taxa = 1:7,
#'     tax_vec_length = 1.3, tax_lab_length = 1.3,
#'     tax_lab_style = tax_lab_style(
#'       max_angle = 90, size = 2, label.size = 0.1, aspect_ratio = 0.5,
#'       label.padding = unit(0.1, "lines"), label.r = unit(0, "lines")
#'     )
#'   ) +
#'   coord_fixed(ratio = 1, clip = "off", xlim = c(-3.5, 3.5))
#'
#' # another example with some extras #
#' ibd_ord %>%
#'   ord_plot(
#'     shape = "circle filled", fill = "ibd",
#'     plot_taxa = 1:10,
#'     taxon_renamer = function(x) stringr::str_replace_all(x, "_", " "),
#'     tax_vec_length = 2, tax_lab_length = 2.1,
#'     tax_lab_style = tax_lab_style(
#'       type = "text", max_angle = 90, size = 2.5,
#'       fontface = "bold.italic", check_overlap = TRUE
#'     )
#'   ) +
#'   coord_fixed(1, clip = "off", xlim = c(-5, 5)) +
#'   theme(legend.position = c(0.8, 0.2), legend.background = element_rect()) +
#'   stat_chull(mapping = aes(colour = ibd, fill = ibd), alpha = 0.1)
tax_lab_style <- function(type = "label",
                          max_angle = 0,
                          perpendicular = FALSE,
                          aspect_ratio = 1,
                          justify = "auto",
                          size = 2,
                          alpha = 1,
                          colour = "black",
                          ...) {
  out <- lab_style(
    type = type,
    max_angle = max_angle,
    perpendicular = perpendicular,
    aspect_ratio = aspect_ratio,
    justify = justify,
    size = size,
    alpha = alpha,
    colour = colour,
    ...
  )
  return(out)
}

#' @rdname Ordination-labels
#' @export
constraint_lab_style <- function(type = "label",
                                 max_angle = 0,
                                 perpendicular = FALSE,
                                 aspect_ratio = 1,
                                 justify = "auto",
                                 size = 2.5,
                                 alpha = 1,
                                 colour = "brown",
                                 ...) {
  out <- lab_style(
    type = type,
    max_angle = max_angle,
    perpendicular = perpendicular,
    aspect_ratio = aspect_ratio,
    justify = justify,
    size = size,
    alpha = alpha,
    colour = colour,
    ...
  )
  return(out)
}

#' Workhorse internal function for tax and constraint lab_style functions
#' The exported tax and constraint functions merely differ in default values
#' @noRd
lab_style <- function(type, max_angle, aspect_ratio, justify, perpendicular,
                      size, alpha, colour, ...) {
  # check all args named
  if (length(names(list(...))) != ...length()) {
    stop(
      call. = FALSE,
      "All arguments to *_lab_style() must be named."
    )
  }

  if (!is.numeric(max_angle) || max_angle < 0 || max_angle > 90) {
    stop(
      call. = FALSE,
      "*lab_style max_angle must be a numeric value in degrees: min 0, max 90"
    )
  }

  # infer "auto" justify based on max angle
  if (identical(justify, "auto")) {
    if (max_angle > 0) justify <- "side"
    if (max_angle == 0 || perpendicular == TRUE) justify <- "center"
  }

  out <- list(
    type = type,
    max_angle = max_angle,
    perpendicular = perpendicular,
    aspect_ratio = aspect_ratio,
    justify = justify,
    size = size,
    alpha = alpha,
    colour = colour,
    ...
  )
  return(out)
}