R/ord_arrows.R

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

# helper functions for adding arrows/segments/vectors to ordination plots

#' draw arrows/segments originating from origin point on ggplot ordination
#'
#' @param p ggplot ordination
#' @param data positions of segment endpoints on axes
#' @param styleList list of aesthetics e.g. generated by a vec_* helper
#' @param axesNames names of axes to plot
#'
#' @return ggplot
#' @noRd
ord_arrows <- function(p, data, styleList, axesNames, defaultStyles) {
  args <- list(
    data = data, x = 0, y = 0, mapping = ggplot2::aes(
      xend = .data[[axesNames[1]]], yend = .data[[axesNames[2]]],
    )
  )
  styles <- defaultStyles
  styles[names(styleList)] <- styleList
  p <- p + do.call(what = ggplot2::geom_segment, args = c(args, styles))
  return(p)
}

#' @title Create ordination plot vector styling lists
#'
#' @description
#' Used by ord_plot, see examples there.
#'
#' @param linewidth width of vector
#' @param alpha opacity of vector
#' @param colour colour of vector
#' @param arrow arrow style specified with grid::arrow() or NULL for no arrow
#' @param lineend Line end style (round, butt, square).
#' @param linejoin Line join style (round, mitre, bevel).
#' @param ... further arguments passed to geom_segment
#'
#' @return list

## vector style helpers -------------------------------------------------------

#' @export
#' @rdname ord_arrows
#' @name Ordination-arrows
vec_constraint <- function(linewidth = 1, alpha = 0.8, colour = "brown",
                           arrow = grid::arrow(
                             length = grid::unit(0.005, units = "npc"),
                             type = "closed", angle = 30
                           ),
                           lineend = "round", linejoin = "mitre",
                           ...) {
  vecCheckArgList(list(
    linewidth = linewidth, alpha = alpha, arrow = arrow, colour = colour,
    lineend = lineend, linejoin = linejoin, ...
  ))
}

#' @export
#' @rdname ord_arrows
vec_tax_sel <- function(linewidth = 0.5, alpha = 1, colour = "black",
                        arrow = grid::arrow(
                          length = grid::unit(0.005, units = "npc"),
                          type = "closed", angle = 30
                        ),
                        lineend = "round", linejoin = "mitre",
                        ...) {
  vecCheckArgList(list(
    linewidth = linewidth, alpha = alpha, arrow = arrow, colour = colour,
    lineend = lineend, linejoin = linejoin, ...
  ))
}

#' @export
#' @rdname ord_arrows
vec_tax_all <- function(linewidth = 0.5, alpha = 0.25, arrow = NULL, ...) {
  vecCheckArgList(list(linewidth = linewidth, alpha = alpha, arrow = arrow, ...))
}

# avoid ggplot2 version issues: size aesthetic changing to new linewidth aesthetic
# and check arrow is NULL or an arrow
vecCheckArgList <- function(argList) {
  if (utils::packageVersion("ggplot2") < "3.4.0") {
    if (is.null(argList[["size"]])) argList[["size"]] <- argList[["linewidth"]]
    argList[["linewidth"]] <- NULL
  } else {
    if (!is.null(argList[["size"]])) {
      rlang::warn(
        "Since ggplot2 v3.4.0, you should use 'linewidth' instead of 'size'",
        .frequency = "regularly", .frequency_id = "linewidth_ord_arrows"
      )
      argList[["linewidth"]] <- argList[["size"]]
    }
    argList[["size"]] <- NULL
  }
  if (!is.null(argList[["arrow"]]) && !inherits(argList[["arrow"]], "arrow")) {
    rlang::abort(
      "arrow must be `NULL` or an 'arrow' object (made with `grid::arrow`)",
      call = rlang::caller_env(1)
    )
  }
  return(argList)
}