R/geom-vwcurve.R

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

#' Curve with Variable-Width
#' @description A variable-width curve where the main line is a series of
#' straight line segments that are assumed to be a flattened approximation to
#' a smooth curve, and the width of curve can be mapping to a numeric variable
#' or be specified by a unit object.
#' @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 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_vwcurve()} 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{fill}
#'       \item \code{linetype}
#'       \item \code{size}
#'       \item \code{width}
#'    }
#' @seealso \code{\link[vwline]{vwcurveGrob}}.
#' @importFrom ggplot2 layer
#' @rdname geom_vwcurve
#' @export
#' @examples
#' df <- data.frame(
#'   x = 1:10,
#'   y = 1:10,
#'   width = runif(10, 0, 1)
#' )
#' ggplot(df, aes(x, y)) + geom_vwcurve()
#' ggplot(df, aes(x, y, width = width)) + geom_vwcurve()
#' ggplot(df, aes(x, y, width = width)) + geom_vwcurve(width_units = "inches")
#'
#' d <- density(rnorm(200))
#' df2 <- data.frame(
#'   x = (d$x - min(d$x)) / diff(range(d$x)),
#'   y = 0.5,
#'   width = 0.2 * d$y / max(d$y)
#' )
#' ggplot(df2, aes(x, y, width = width)) + geom_vwcurve(width_units = "native")
geom_vwcurve <- function(mapping = NULL,
                        data = NULL,
                        stat = "identity",
                        position = "identity",
                        ...,
                        open = TRUE,
                        width_units = "cm",
                        lineend = "butt",
                        mitre_limit = 4,
                        debug = FALSE,
                        na.rm = FALSE,
                        show.legend = NA,
                        inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomVwcurve,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      open = open,
      width_units = width_units,
      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 widthSpec vwcurveGrob vwPolygon vwPath
#' @importFrom scales alpha
#' @rdname geom_vwcurve
#' @format NULL
#' @usage NULL
#' @export
GeomVwcurve <- ggproto(
  "GeomVwcurve", Geom,
  draw_panel = function(data, panel_params, coord, open = TRUE, width0 = NULL,
                        width_units = "cm", lineend = "butt", mitre_limit = 4,
                        render=if (open) vwPolygon else 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 < 2) return(ggplot2::zeroGrob())
        first_row = .data[1, , drop = FALSE]
        width <- width0 %||% grid::unit(.data$width, width_units)
        if(grid::is.unit(width)) {
          width <- grid::unit(width, width_units)
        }
        vwcurveGrob(
          .data$x, .data$y, width, default.units = "native", open = open,
          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_vwcurve", do.call("grobTree", grobs))
    } else {
      n <- nrow(data)
      if (n < 2)
        return(ggplot2::zeroGrob())
      first_row = data[1, , drop = FALSE]

      width <- width0 %||% grid::unit(data$width, width_units)
      if(grid::is.unit(width)) {
        width <- grid::unit(width, width_units)
      }

      ggname(
        "geom_vwcurve",
        vwcurveGrob(
          data$x, data$y, width, default.units = "native", open = open,
          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),
  required_aes = c("x", "y"),

  draw_key = draw_key_polygon
)