R/geom-vwline.R

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

#' Segment with Variable-Width
#' @description A variable-width line where the main line is a series of straight
#' line segments and the width is specified at each vertex and linearly interpolated
#' along each segment.
#' @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 step_width a logical value indicating whether widths are fixed along
#' the length of a segment.
#' @param linejoin the line join style; one of "round" (default), "mitre", or "bevel".
#' @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_vwline()} 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}
#'       \item \code{width}
#'       \item \code{width_left}
#'       \item \code{width_right}
#'    }
#' @seealso \code{\link[vwline]{vwlineGrob}}, \code{\link[vwline]{widthSpec}},
#'     \code{\link[grid]{unit}}
#' @importFrom ggplot2 layer
#' @rdname geom_vwline
#' @export
#' @examples
#' df <- data.frame(
#'   x = 1:10,
#'   y = 1:10,
#'   width = runif(10, 0, 1)
#' )
#' ggplot(df, aes(x, y)) + geom_vwline()
#' ggplot(df, aes(x, y, width = width)) + geom_vwline()
#' ggplot(df, aes(x, y, width = width)) + geom_vwline(width_units = "inches")
geom_vwline <- function(mapping = NULL,
                        data = NULL,
                        stat = "identity",
                        position = "identity",
                        ...,
                        open = TRUE,
                        width_units = "cm",
                        step_width = FALSE,
                        linejoin = "round",
                        lineend = "butt",
                        mitre_limit = 4,
                        debug = FALSE,
                        na.rm = FALSE,
                        show.legend = NA,
                        inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomVwline,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      open = open,
      width_units = width_units,
      step_width = step_width,
      linejoin = linejoin,
      lineend = lineend,
      mitre_limit = mitre_limit,
      debug = debug,
      na.rm = na.rm,
      ...
    )
  )
}

#' @importFrom ggplot2 ggproto Geom zeroGrob draw_key_polygon
#' @importFrom grid gpar grobTree
#' @importFrom vwline widthSpec vwlineGrob
#' @importFrom scales alpha
#' @rdname geom_vwline
#' @format NULL
#' @usage NULL
#' @export
GeomVwline <- ggproto(
  "GeomVwline", Geom,
  draw_panel = function(data, panel_params, coord, open = TRUE, width0 = NULL,
                        width_units = "cm", step_width = FALSE, linejoin = "round",
                        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 %||%
          if(!is.null(.data$width_right) && !is.null(.data$width_left)) {
            widthSpec(list(left = .data$width_left,
                           right = .data$width_right), width_units)
          } else {
            widthSpec(.data$width, width_units)
          }

        if(!inherits(width, "widthSpec")) {
          width <- widthSpec(width, width_units)
        }

        vwlineGrob(
          .data$x, .data$y, width, default.units = "native", open = open,
          linejoin = linejoin, lineend = lineend, mitrelimit = mitre_limit,
          stepWidth = step_width, 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_vwline", do.call("grobTree", grobs))
    } else {
      n <- nrow(data)
      if (n < 2)
        return(ggplot2::zeroGrob())
      first_row = data[1, , drop = FALSE]

      width <- width0 %||%
        if(!is.null(data$width_right) && !is.null(data$width_left)) {
          widthSpec(list(left = data$width_left,
                         right = data$width_right), width_units)
        } else {
          widthSpec(data$width, width_units)
        }
      if(!inherits(width, "widthSpec")) {
        width <- widthSpec(width, width_units)
      }

      ggname(
        "geom_vwline",
        vwlineGrob(
        data$x, data$y, width, default.units = "native", open = open,
        linejoin = linejoin, lineend = lineend, mitrelimit = mitre_limit,
        stepWidth = step_width, 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, width = 1, width_left = NULL, width_right = NULL),
  required_aes = c("x", "y"),

  draw_key = draw_key_polygon
)