R/spline.R

In TransProR: Analysis and Visualization of Multi-Omics Data

#' X-spline Statistic for ggplot2 (adapted from ggalt)
#'
#' This statistic adds an X-spline interpolation to your ggplot2 plots, allowing for smooth curves through a series of points.
#' The implementation is adapted from the \code{stat_xspline} function in the \pkg{ggalt} package (GPL-3), originally authored by Bob Rudis.
#'
#' @section License and Attribution:
#' This code is adapted from the \pkg{ggalt} package (\url{https://github.com/hrbrmstr/ggalt}), which is licensed under GPL-3.
#' Original author: Bob Rudis (\email{bob@@rud.is}).
#' 
#' @importFrom ggplot2 layer ggproto Stat
#' @importFrom graphics xspline plot.new
#' @importFrom grDevices png dev.off
#' 
#' @param mapping Set of aesthetic mappings created by \code{aes()} or \code{aes_()}.
#' @param data The data to be displayed in this layer.
#' @param geom The geometric object to use display the data.
#' @param position Position adjustment, either as a string, or the result of a call to a position adjustment function.
#' @param na.rm If \code{FALSE} (the default), removes missing values with a warning. If \code{TRUE} silently removes missing values.
#' @param show.legend logical. Should this layer be included in the legends?
#' @param inherit.aes If \code{FALSE}, overrides the default aesthetics, rather than combining with them.
#' @param spline_shape Numeric value controlling the shape of the spline. Default is -0.25.
#' @param open Logical. If \code{TRUE}, the spline is open; if \code{FALSE}, it is closed.
#' @param rep_ends Logical. If \code{TRUE}, the end points are repeated.
#' @param ... Other arguments passed on to \code{layer()}.
#'
#' @section Computed variables:
#' \itemize{
#'   \item{x} X coordinates of the spline.
#'   \item{y} Y coordinates of the spline.
#' }
#'
#' @return A ggplot2 layer that can be added to a plot.
#'
#' @examples
#' \donttest{
#' library(ggplot2)
#' df <- data.frame(x = 1:10, y = cumsum(rnorm(10)))
#' ggplot(df, aes(x, y)) +
#'   geom_point() +
#'   stat_xspline(spline_shape = 0.5)
#' }
#'
#' @export
stat_xspline <- function(mapping = NULL, data = NULL, geom = "line",
                     position = "identity", na.rm = TRUE, show.legend = NA, inherit.aes = TRUE,
                     spline_shape=-0.25, open=TRUE, rep_ends=TRUE, ...) {
  ggplot2::layer(
    stat = StatXspline,
    data = data,
    mapping = mapping,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(spline_shape=spline_shape,
                  open=open,
                  na.rm = na.rm,
                  rep_ends=rep_ends,
                  ...
    )
  )
}

#' @rdname stat_xspline
#' @format NULL
#' @usage NULL
#' @export
StatXspline <- ggplot2::ggproto("StatXspline", ggplot2::Stat,
  required_aes = c("x", "y"),
  compute_group = function(self, data, scales, params,
                           spline_shape=-0.25, open=TRUE, rep_ends=TRUE) {
    tf <- tempfile(fileext=".png")
    grDevices::png(tf)
    graphics::plot.new()
    tmp <- graphics::xspline(data$x, data$y, spline_shape, open, rep_ends, draw=FALSE, NA, NA)
    invisible(grDevices::dev.off())
    unlink(tf)
    data.frame(x=tmp$x, y=tmp$y)
  }
)