R/geom-brush-xspline.R

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

#' X-Spline Curve with Brush
#' @description The main curve is described by x/y position points and a variable-size
#' brush is used to sweep a variable-width line from the main curve.
#' @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, details see \code{\link[grid]{unit}}.
#' @param width_shape the shape parameter for the width spline.
#' @param rep a logical value indicating whether to repeat the widths along the full
#'     length of the line.
#' @param shape a numeric value (or one per location) that controls the shape of
#'     the X-spline curve relative to the locations.
#' @param debug a logical value indicating whether to produce graphical debugging output.
#' @section Aesthetics:
#' \code{geom_brush_xspline()} 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{space}
#'       \item \code{width}
#'    }
#' @seealso \code{\link[vwline]{brushXsplineGrob}}, \code{\link[vwline]{widthSpline}},
#'     \code{\link[vwline]{BezierWidth}}.
#' @importFrom ggplot2 layer
#' @rdname geom_brush_xspline
#' @export
#' @examples
#' df <- data.frame(
#'   x = 0:3 / 3,
#'   y = c(0.5, 0.7, 0.3, 0.5),
#'   width = c(1.5, 0, 1.5, 0)
#' )
#'
#' ggplot(df, aes(x, y, width = width)) + geom_brush_xspline()
#'
#' width <- widthSpline(grid::unit(c(0, 1, 0), "cm"), d=1:3 / 4, rep = TRUE)
#' ggplot(df, aes(x, y)) + geom_brush_xspline(width0 = width)
geom_brush_xspline <- function(mapping = NULL,
                             data = NULL,
                             stat = "identity",
                             position = "identity",
                             ...,
                             open = TRUE,
                             width_units = "cm",
                             width_shape = -1,
                             rep = FALSE,
                             shape = 1,
                             debug = FALSE,
                             na.rm = FALSE,
                             show.legend = NA,
                             inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomBrushXspline,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      open = open,
      width_units = width_units,
      width_shape = width_shape,
      rep = rep,
      shape = shape,
      debug = debug,
      na.rm = na.rm,
      ...
    )
  )
}

#' @importFrom ggplot2 ggproto Geom zeroGrob draw_key_polygon
#' @importFrom grid gpar grobTree is.unit unit
#' @importFrom vwline widthSpline brushXsplineGrob verticalBrush vwPath
#' @importFrom scales alpha
#' @rdname geom_brush_xspline
#' @format NULL
#' @usage NULL
#' @export
GeomBrushXspline <- ggproto(
  "GeomBrushXspline", Geom,
  draw_panel = function(data, panel_params, coord, open = TRUE, brush = verticalBrush,
                        width0 = NULL, width_units = "cm", width_fun = "spline", width_shape = -1,
                        rep = FALSE, shape = 1, spacing = NULL, render = vwPath(),debug = FALSE) {
    width_fun <- match.arg(width_fun, c("spline", "bezier"))
    width_fun <- switch(width_fun,
                        spline = "widthSpline",
                        bezier = "BezierWidth")
    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 < 2) return(ggplot2::zeroGrob())
        first_row = .data[1, , drop = FALSE]
        args <- if(width_fun == "BezierWidth") {
          list(w = .data$width, default.units = width_units, d = .data$dist,
               rep = rep)
        } else {
          list(w = .data$width, default.units = width_units, d = .data$dist,
               shape = shape, rep = rep)
        }
        width <- width0 %||% do.call(width_fun, args)

        if (!inherits(width, "widthSpline") && !inherits(width, "BezierWidth")) {
          width <- widthSpline(width, width_units)
        }

        spacing <- spacing %||% .data$space
        if(!is.null(spacing) && !is.unit(spacing)) {
          spacing <- grid::unit(spacing, width_units)
        }

        brushXsplineGrob(
          brush, .data$x, .data$y, width, default.units = "native", shape = shape,
          angle = .data$angle, open = open, spacing = spacing, 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_brush_xspline", do.call("grobTree", grobs))
    } else {
      n <- nrow(data)
      if (n < 2)
        return(ggplot2::zeroGrob())
      first_row = data[1, , drop = FALSE]
      args <- if(width_fun == "BezierWidth") {
        list(w = data$width, default.units = width_units, d = data$dist,
             rep = rep)
      } else {
        list(w = data$width, default.units = width_units, d = data$dist,
             shape = shape, rep = rep)
      }
      width <- width0 %||% do.call(width_fun, args)

      if (!inherits(width, "widthSpline") && !inherits(width, "BezierWidth")) {
        width <- widthSpline(width, width_units)
      }

      spacing <- spacing %||% data$space
      if(!is.null(spacing) && !is.unit(spacing)) {
        spacing <- grid::unit(spacing, width_units)
      }

      ggname(
        "geom_brush_xspline",
        brushXsplineGrob(
          brush, data$x, data$y, width, default.units = "native", shape = shape,
          angle = data$angle, open = open, spacing = spacing, 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", space = NULL, width = 1,
                    dist = NULL),
  required_aes = c("x", "y"),

  draw_key = draw_key_polygon
)