R/geom-vwxspline.R

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

#' Offset-Spline Curve with Variable-Width
#' @description A variable-width X-spline where the main line is described
#' by x/y position points and the width describes offset of position points .
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_polygon
#' @param open a logical value indicating whether to connect the last
#' location back to the first location to produce a closed line.
#' @param width_units the units of line, detail see \code{\link[grid]{unit}}.
#' @param shape a numeric value (or one per location) that controls the shape of
#' the X-spline curve relative to the locations.
#' @param rep_ends  a logical value indicating whether to replicate the first
#' and last control points.
#' @param lineend the line ending style; one of "round" (default), "mitre", "butt",
#' or "square".
#' @param mitre_limit a numeric that controls when a mitre join is converted to
#' a bevel join or a mitre ending is converted to a square ending.
#' @param debug a logical value indicating whether to produce graphical debugging output.
#' @section Aesthetics:
#' \code{geom_vwxspline()} understands the following aesthetics (required
#' aesthetics are in bold):
#'     \itemize{
#'       \item \strong{\code{x}}
#'       \item \strong{\code{y}}
#'       \item \code{angle}
#'       \item \code{alpha}
#'       \item \code{colour}
#'       \item \code{dist}
#'       \item \code{fill}
#'       \item \code{linetype}
#'       \item \code{size}
#'       \item \code{width}
#'    }
#' @seealso \code{\link[vwline]{vwXsplineGrob}}.
#' @importFrom ggplot2 layer
#' @rdname geom_vwxspline
#' @export
#' @examples
#' df <- data.frame(
#'   x = c(0, 0.5, 1),
#'   y = 0.5,
#'   width = c(0, 0.5, 0)
#' )
#'
#' ggplot(df, aes(x, y, width = width)) + geom_vwxspline()
#' ggplot(df, aes(x, y, width = width)) + geom_vwxspline(width_units = "native")
#'
#' df2 <- data.frame(
#'   x = 0:3 / 3,
#'   y = c(0.5, 0.7, 0.3, 0.5),
#'   width = c(0, 0.5, 0.5, 0)
#' )
#'
#' ggplot(df2, aes(x, y, width = width)) + geom_vwxspline()
#' ggplot(df2, aes(x, y, width = width)) + geom_vwxspline(width_units = "native")
geom_vwxspline <- function(mapping = NULL,
                           data = NULL,
                           stat = "identity",
                           position = "identity",
                           ...,
                           open = TRUE,
                           width_units = "cm",
                           shape = 1,
                           rep_ends = TRUE,
                           lineend = "butt",
                           mitre_limit = 4,
                           debug = FALSE,
                           na.rm = FALSE,
                           show.legend = NA,
                           inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomVwXspline,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      open = open,
      width_units = width_units,
      shape = shape,
      rep_ends = rep_ends,
      lineend = lineend,
      mitre_limit = mitre_limit,
      debug = debug,
      na.rm = na.rm,
      ...
    )
  )
}

#' @importFrom ggplot2 ggproto Geom zeroGrob draw_key_polygon
#' @importFrom grid gpar grobTree is.unit unit
#' @importFrom vwline vwXsplineGrob vwPath
#' @importFrom scales alpha
#' @rdname geom_vwxspline
#' @format NULL
#' @usage NULL
#' @export
GeomVwXspline <- ggproto(
  "GeomVwXspline", Geom,
  draw_panel = function(data, panel_params, coord, open = TRUE, width0 = NULL,
                        width_units = "cm", shape = 1, rep_ends = TRUE, lineend = "butt",
                        mitre_limit = 4, render = vwPath(), debug = FALSE) {
    data <- coord$transform(data, panel_params)
    if(!is.null(data$group) && length(unique(data$group)) > 1) {
      data <- split(data, data$group)
      grobs <- lapply(data, function(.data) {
        n <- nrow(.data)
        if (n < 3) return(ggplot2::zeroGrob())
        first_row = .data[1, , drop = FALSE]
        width <- width0 %||% grid::unit(.data$width, width_units)
        if(!is.unit(width)) {
          width <- grid::unit(width, width_units)
        }
        vwXsplineGrob(
          .data$x, .data$y, width, default.units = "native", shape = shape,
          open = open, repEnds = rep_ends, angle = .data$angle, lineend = lineend,
          mitrelimit = mitre_limit, render = render, debug = debug,
          gp = gpar(
            col = scales::alpha(first_row$colour, first_row$alpha),
            fill = scales::alpha(first_row$fill, first_row$alpha),
            lwd = first_row$size * ggplot2::.pt,
            lty = first_row$linetype
          )
        )
      })
      ggname("geom_vwxspline", do.call("grobTree", grobs))
    } else {
      n <- nrow(data)
      if (n < 3)
        return(ggplot2::zeroGrob())
      first_row = data[1, , drop = FALSE]
      width <- width0 %||% grid::unit(data$width, width_units)
      if(!is.unit(width)) {
        width <- grid::unit(width, width_units)
      }
      ggname(
        "geom_vwxspline",
        vwXsplineGrob(
          data$x, data$y, width, default.units = "native", shape = shape,
          open = open, repEnds = rep_ends, angle = data$angle, lineend = lineend,
          mitrelimit = mitre_limit, render = render, debug = debug,
          gp = gpar(
            col = scales::alpha(first_row$colour, first_row$alpha),
            fill = scales::alpha(first_row$fill, first_row$alpha),
            lwd = first_row$size * ggplot2::.pt,
            lty = first_row$linetype
          )
        )
      )
    }
  },

  default_aes = aes(colour = NA, fill = "grey35", size = 0.25, linetype = 1,
                    alpha = NA, angle = "perp", width = 1, dist = NULL),
  required_aes = c("x", "y"),

  draw_key = draw_key_polygon
)