R/geom-quad-line.R

In houyunhuang/ggvwline: Extending 'ggplot2' to Draw Variable-Width Lines

#' Quadratic Bezier Spline
#' @description The quadratic bezier spline layer function is used to draw
#' bezier curve.
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_path
#' @param step_fn a function (defaults to \code{\link[gridBezier]{nSteps}}) to
#' generate values of t at which the curve will be evaluated for drawing.
#' @section Aesthetics:
#' \code{geom_quad_line()} understands the following aesthetics (required
#' aesthetics are in bold):
#'     \itemize{
#'       \item \strong{\code{x}}
#'       \item \strong{\code{y}}
#'       \item \code{alpha}
#'       \item \code{colour}
#'       \item \code{fill}
#'       \item \code{linetype}
#'       \item \code{size}
#'    }
#' @importFrom ggplot2 layer
#' @seealso \code{\link[gridBezier]{quadGrob}}.
#' @rdname geom_quad_line
#' @export
#' @examples
#' df <- data.frame(
#'   x = rnorm(9),
#'   y = rnorm(9)
#' )
#' ggplot(df, aes(x, y)) + geom_quad_line()
#' ggplot(df[1:8, ], aes(x, y)) + geom_quad_line(fill = "red", open = FALSE)
geom_quad_line <- function(mapping = NULL,
                        data = NULL,
                        stat = "identity",
                        position = "identity",
                        ...,
                        step_fn = nSteps(100),
                        na.rm = FALSE,
                        show.legend = NA,
                        inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomQuadLine,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      step_fn = step_fn,
      na.rm = na.rm,
      ...
    )
  )
}

#' @importFrom ggplot2 ggproto GeomPath zeroGrob draw_key_path
#' @importFrom grid gpar
#' @importFrom gridBezier quadGrob nSteps
#' @importFrom scales alpha
#' @rdname geom_quad_line
#' @format NULL
#' @usage NULL
#' @export
GeomQuadLine <- ggproto(
  "GeomQuadLine", GeomPath,
  draw_panel = function(data, panel_params, coord, open = TRUE,
                        step_fn = nSteps(100), lineend = "butt") {
    if (!coord$is_linear()) {
      warning("geom_quad_line is not implemented for non-linear coordinates",
              call. = FALSE)
    }
    data <- coord$transform(data, panel_params)

    if(open) {
      if(nrow(data) < 3 || (nrow(data) %% 2) != 1)
        return(zeroGrob())
    } else {
      if(nrow(data) < 2 || (nrow(data) %% 2) != 0)
        return(zeroGrob())
    }

    quadGrob(
      data$x, data$y, default.units = "native",
      open = open, stepFn = step_fn,
      gp = gpar(
        col = scales::alpha(data$colour, data$alpha),
        fill = scales::alpha(data$fill, data$alpha),
        lwd = data$size * ggplot2::.pt,
        lty = data$linetype,
        lineend = lineend)
    )
  },

  default_aes = aes(colour = "black", fill = NA, size = 0.25, linetype = 1,
                    alpha = NA),
  required_aes = c("x", "y"),

  draw_key = draw_key_path
)