R/geom_wiggle.R

In thackl/gggenomes: A Grammar of Graphics for Comparative Genomics

#' Draw wiggle ribbons or lines
#'
#' @param bounds geom_wiggle uses mid, low and high boundary values for plotting wiggle data. Can
#'   be both a function or a vector returning those three values. Defaults to
#'   [Hmisc::smedian.hilow].
#' @param height distance in plot between lowest and highest point of the wiggle data.
#' @param offset distance between seq center and wiggle mid/start.
#' @section Aesthetics: `geom_wiggle()` and `geom_coverage()` understand aesthetics depending on the
#'   chosen underlying ggplot geom, by default [ggplot2::geom_ribbon()]. Other
#'   options that play well are for example [ggplot2::geom_line()],
#'   [ggplot2::geom_linerange()], [ggplot2::geom_point()]. The only required
#'   aesthetic is:
#'   * **z**
#' @export
#' @examples
#' # Plot varying GC-content along sequences as ribbon
#' gggenomes(seqs=emale_seqs, feats=emale_gc) +
#'   geom_wiggle(aes(z=score)) +
#'   geom_seq()
#'
#' # customize color and position
#' gggenomes(genes=emale_genes, seqs=emale_seqs, feats=emale_gc) +
#'   geom_wiggle(aes(z=score), fill="lavenderblush3", offset=-.3, height=.5) +
#'   geom_seq() + geom_gene()
#'
#' # GC-content as line and with variable color
#' gggenomes(seqs=emale_seqs, feats=emale_gc) +
#'   geom_wiggle(aes(z=score, color=score), geom="line", bounds=c(.5,0,1)) +
#'   geom_seq() +
#'   scale_colour_viridis_b(option="A")
#'
#' # or as lineranges
#' gggenomes(seqs=emale_seqs, feats=emale_gc) +
#'   geom_wiggle(aes(z=score, color=score), geom="linerange") +
#'   geom_seq() +
#'   scale_colour_viridis_b(option="A")
geom_wiggle <- function(mapping = NULL, data = feats(), stat="wiggle",
    geom="ribbon", position = "identity", na.rm = FALSE, show.legend = NA,
    inherit.aes = TRUE, offset = 0, height = .8,
    bounds = Hmisc::smedian.hilow, ...) {
  default_aes <- aes(x=(.data$x+.data$xend)/2, y=.data$y, group=.data$seq_id)
  mapping <- aes_intersect(mapping, default_aes)

  layer(
    geom = geom, mapping = mapping, data = data, stat = stat,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, offset=offset, height=height, bounds=bounds, ...)
  )
}

StatWiggle <- ggproto("StatWiggle", Stat,
  setup_params = function(data, params) {
    # make sure this is a function even if a vector was supplied
    bf <- as_bounds(params$bounds)
    if (environmentName(environment(bf)) == "Hmisc" && !requireNamespace("Hmisc", quietly=TRUE))
      abort("Hmisc package required for default wiggle bounds. Overwrite with custom bounds or bounds-function")
    bs <- bf(data$z)

    if(length(bs) != 3) abort("Bounds need to return exactly three numbers: mid, low, high")
    inform(c("wiggle bounds", paste(c("mid: ", "low: ", "high:"), unname(bs))))

    params$rescale <- params$height / diff(bs[2:3])
    params$mid <- bs[1] * params$rescale
    params
  },
  compute_group = function(data, scales,height=NA, bounds=NA, offset=0, mid=NA, rescale=NA){
    data$ymin <- data$y + offset
    data$y <- data$z * rescale - mid + data$ymin
    data$ymax <- data$y
    data
  },
  required_aes = c("x", "y", "z")
)

as_bounds <- function(.f, ...) {
  UseMethod("as_bounds")
}
as_bounds.default <- purrr__as_mapper.default
as_bounds.numeric <- function(.f){
  function(...) .f
}