R/geom-pointline.r

In lemon: Freshing Up your 'ggplot2' Plots

#' @include ggplot2.r
NULL

#' Connected points
#'
#' \code{geom_pointpath} combines \code{\link[ggplot2]{geom_point}} and
#' \code{\link[ggplot2]{geom_path}}, such that a) when jittering is used,
#' both lines and points stay connected, and b) provides a visual effect
#' by adding a small gap between the point and the end of line.
#' \code{geom_pointline} combines \code{\link[ggplot2]{geom_point}} and
#' \code{\link[ggplot2]{geom_path}}.
#'
#' \code{geom_pointpath} connects the observations in the same order in which
#' they appear in the data.
#' \code{geom_pointline} connects them in order of the variable on the x-axis.
#'
#' Both \code{geom_pointpath} and \code{geom_pointline} will only
#' connect observations within the same group! However,
#' if \code{linecolour} is \emph{not} \code{waiver()}, connections
#' will be made between groups, but possible in an incorrect order.
#'
#'
#'
#'
#'
#' @section Aesthetics:
#' \code{geom_pointline} and \code{geom_pointpath} understands the following
#' aesthetics (required aesthetics are in bold):
#' \itemize{
#'   \item \strong{x}
#'   \item \strong{y}
#'   \item alpha
#'   \item colour -- sets colour of point. Only affects line if \code{linecolour=waiver()}.
#'   \item stroke
#'   \item shape
#'   \item stroke
#'   \item group
#'   \item linetype
#'   \item size -- only affects point size. Width of line is set with
#'         \code{linesize} and cannot be linked to an aesthetic.
#' }
#' @param mapping Set of aesthetic mappings created by \code{\link[ggplot2]{aes}}
#'   or \code{\link[ggplot2]{aes_}}.
#' @param data The data to be displayed in this layer.
#' @param stat The statistical transformation to use on the data for this layer,
#'   as a string.
#' @param position Position adjustment, either as a string, or the result of a
#'   call to a position adjustment function
#'   (e.g. \code{\link[ggplot2]{position_jitter}}).
#'   Both lines and points gets the same adjustment
#'   (\emph{this} is where the function excels over \code{geom_point() + geom_line()}).
#' @param ... other arguments passed on to \code{\link[ggplot2]{layer}}.
#' @param lineend Line end style (round, butt, square).
#' @param linejoin Line join style (round, mintre, bevel).
#' @param linemitre Line mitre limit (number greater than 1).
#' @param arrow Arrow specification, as created by \code{\link[grid]{arrow}}.
#' @param na.rm If \code{FALSE} (default), missing values are removed with a warning.
#'   If \code{TRUE}, missing values are silently removed.
#' @param show.legend Logical. Should this layer be included in the legends?
#'   \code{NA} (default), includes if any aesthetics are mapped.
#'   \code{FALSE} never includes, and \code{TRUE} always includes.
#' @param inherit.aes If \code{FALSE}, overrides the default aesthetic, rather
#'   than combining with them. This is most useful for helper functions that
#'   define both data and aesthetics and shouldn't inherit behaviour from the
#'   default plot specification.
#' @param linesize Width of of line.
#' @param distance Gap size between point and end of lines;
#'   use \code{\link[grid]{unit}}. Is converted to 'pt' if given as simple numeric.
#'   When \code{NULL} or \code{NA}, gapping and \code{shorten}/\code{treshold}
#'   is disabled. To keep the latter, set to 0.
#' @param shorten,threshold When points are closer than \code{threshold},
#'   shorten the line by the proportion in \code{shorten} instead of adding
#'   a gap by \code{distance}.
#' @param linecolour,linecolor When not \code{waiver()}, the line is drawn with
#'   this colour instead of that set by aesthetic \code{colour}.
#'
#' @example inst/examples/geom-pointline-ex.r
#' @export
geom_pointpath <- function(mapping = NULL, data = NULL, stat = "identity",
                      position = "identity", na.rm = FALSE,
                      show.legend = NA, inherit.aes = TRUE,
                      distance = unit(3, 'pt'),
                      shorten = 0.5,
                      threshold = 0.1,
                      lineend = "butt",
                      linejoin = "round",
                      linemitre = 1,
                      linesize = 0.5,
                      linecolour = waiver(),
                      linecolor = waiver(),
                      arrow = NULL,
                      ...) {
  if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomPointPath,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      distance = distance,
      shorten = shorten,
      threshold = threshold,
      lineend = lineend,
      linejoin = linejoin,
      linemitre = linemitre,
      linesize = linesize,
      linecolour = linecolour,
      arrow = arrow,
      ...
    )
  )
}

#' @section Geoms:
#' The geom-objects here extends `ggplot2::Geom`
#' allowing us to produce the geoms for
#' [geom_pointline],
#' [geom_pointpath], [geom_pointrangeline], and [geom_siderange].
#'
#' See `geom-pointline.r` and `geom-siderange.r`.
#'
#' @md
#' @rdname lemon-ggproto
#' @keywords internal
#' @format NULL
#' @usage NULL
#' @export
#' @import ggplot2
#' @import gtable
#' @import grid
GeomPointPath <- ggplot2::ggproto('GeomPointPath',
  `_inherit`=ggplot2::GeomPoint,
  required_aes = c("x", "y"),
  non_missing_aes = c("size", "shape", "colour"),
  default_aes = aes(
    shape = 19, colour = "black", size = 1.5, fill = NA,
    alpha = NA, stroke = 0.5,
    linetype = 1
  ),

  draw_panel = function(data, panel_params, coord, na.rm = FALSE,
                        distance = grid::unit(3, 'pt'),
                        shorten = 0.5,
                        threshold = 0.1,
                        linesize = 0.5,
                        linecolour = waiver(),
                        arrow = NULL,
                        lineend = "butt", linejoin = "round", linemitre = 1
                        ) {
    # Test input parameters
    if (is.null(distance) || is.na(distance)) {
      distance=grid::unit(0, 'pt')
      threshold = 0
    }
    if (!grid::is.unit(distance) && is.numeric(distance))
      distance <- grid::unit(distance, 'pt')

    # Contents of GeomPoint$draw_panel in geom-point.r
    coords <- coord$transform(data, panel_params)
    coords_p <- coords
    gr_points <- ggplot2:::ggname("geom_point",
           grid::pointsGrob(
             coords$x, coords$y,
             pch = coords$shape,
             gp = grid::gpar(
               col = alpha(coords$colour, coords$alpha),
               fill = alpha(coords$fill, coords$alpha),
               # Stroke is added around the outside of the point
               fontsize = coords$size * .pt + coords$stroke * .stroke / 2,
               lwd = coords$stroke * .stroke / 2
             )
           )
    )
    # gr_points <- GeomPoint$draw_panel(data, panel_params, coord, na.rm)

    # Contents of GeomPath$draw_panel in geom-path
    if (!anyDuplicated(data$group)) {
      message_wrap("geom_path: Each group consists of only one observation. ",
                   "Do you need to adjust the group aesthetic?")
    }

    # must be sorted on group
    data <- data[order(data$group), , drop = FALSE]
    munched <- ggplot2::coord_munch(coord, data, panel_params)

    # Silently drop lines with less than two points, preserving order
    rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
    munched <- munched[rows >= 2, ]
    if (nrow(munched) < 2) return(zeroGrob())

    # Work out whether we should use lines or segments
    attr <- plyr::ddply(munched, "group", function(df) {
      linetype <- unique(df$linetype)
      data.frame(
        solid = identical(linetype, 1) || identical(linetype, "solid"),
        constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1
      )
    })
    solid_lines <- all(attr$solid)
    constant <- all(attr$constant)
    if (!solid_lines && !constant) {
      stop("geom_path: If you are using dotted or dashed lines",
           ", colour, size and linetype must be constant over the line",
           call. = FALSE)
    }

    # Work out grouping variables for grobs
    n <- nrow(munched)
    group_diff <- munched$group[-1] != munched$group[-n]
    munched$end <-   c(group_diff, TRUE)

    munched <- within(munched, {
      x1 = c(x[-1], NA);
      y1 = c(y[-1], NA);
      deltax = x1 - x;
      deltay = y1 - y;
      length <- sqrt(deltax**2 + deltay**2);
    })
    munched <- munched[-nrow(munched), ]

    if (any(munched$length > threshold, na.rm=TRUE)) {
      # Calculate angle between each pair of points and move endpoints:
      if (as.numeric(distance) != 0) {
        df <- within(munched[munched$length > threshold,], {
          theta = atan2(deltay, deltax);
          size = grid::unit(size, 'pt');
          x = grid::unit(x, 'native') + size*cos(theta) + distance*cos(theta);
          x1 = grid::unit(x1, 'native') - size*cos(theta) - distance*cos(theta);
          y = grid::unit(y, 'native') + size*sin(theta) + distance*sin(theta);
          y1 = grid::unit(y1, 'native') - size*sin(theta) - distance*sin(theta);
        })
      } else {
        df <- within(munched[munched$length > threshold,], {
          x = grid::unit(x, 'native');
          x1 = grid::unit(x1, 'native');
          y = grid::unit(y, 'native');
          y1 = grid::unit(y1, 'native');
        })
      }

      gr_distant <- with(df[!df$end,], grid::segmentsGrob(
        x0=x, y0=y, x1=x1, y1=y1,
        arrow = arrow,
        gp = grid::gpar(
          col = ggplot2::alpha(colour, alpha),
          fill = ggplot2::alpha(colour, alpha),
          lwd = linesize * .pt,
          lty = linetype,
          lineend = lineend,
          linejoin = linejoin,
          linemitre = linemitre
        )
      ))
      if (!is.waive(linecolour))
        gr_distant$gp$col <- linecolour
    } else {
      gr_distant <- zeroGrob()
    }

    if (threshold > 0 && any(munched$length <= threshold, na.rm=TRUE)) {
      df <- within(munched[munched$length <= threshold,], {
        x  = x + shorten/2 * deltax; x = grid::unit(x, 'native');
        y  = y + shorten/2 * deltay; y = grid::unit(y, 'native');
        x1 = x1 - shorten/2 * deltax; x1 = grid::unit(x1, 'native');
        y1 = y1 - shorten/2 * deltay; y1 = grid::unit(y1, 'native');
      })

      gr_short <- with(df[!df$end, ], grid::segmentsGrob(
        x0=x, y0=y, x1=x1, y1=y1,
        arrow = arrow,
        gp = grid::gpar(
          col = ggplot2::alpha(colour, alpha),
          fill = ggplot2::alpha(colour, alpha),
          lwd = linesize * .pt,
          lty = linetype,
          lineend = lineend,
          linejoin = linejoin,
          linemitre = linemitre
        )
      ))
      if (!is.waive(linecolour))
        gr_short$gp$col <- linecolour
    } else {
      gr_short <- zeroGrob()
    }

    grid::gList(gr_points, gr_distant, gr_short)
  },

  draw_key = ggplot2::draw_key_point
)


#' @export
#  @inheritParams geom_pointpath
#' @rdname geom_pointpath
geom_pointline <- function(mapping = NULL, data = NULL, stat = "identity",
                           position = "identity", na.rm = FALSE,
                           show.legend = NA, inherit.aes = TRUE,
                           distance = unit(3, 'pt'),
                           shorten = 0.5,
                           threshold = 0.1,
                           lineend = "butt",
                           linejoin = "round",
                           linemitre = 1,
                           linesize = 0.5,
                           linecolour = waiver(),
                           linecolor = waiver(),
                           arrow = NULL,
                           ...) {

  if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomPointLine,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      distance = distance,
      shorten = shorten,
      threshold = threshold,
      lineend = lineend,
      linejoin = linejoin,
      linemitre = linemitre,
      linesize = 0.5,
      linecolour = linecolour,
      arrow = arrow,
      ...
    )
  )
}

#' @rdname lemon-ggproto
#' @keywords internal
#' @format NULL
#' @usage NULL
#' @export
#' @import ggplot2
#' @import gtable
GeomPointLine <- ggproto("GeomPointLine", GeomPointPath,
    setup_data = function(data, params) {
      data[order(data$PANEL, data$group, data$x), ]
    }
)




#  @inheritParams geom_pointpath
#' @rdname geom_pointpath
geom_pointrangeline <- function(mapping = NULL, data = NULL, stat = "identity",
                                position = "identity", na.rm = FALSE,
                                show.legend = NA, inherit.aes = TRUE,
                                distance = unit(3, 'pt'),
                                lineend = "butt",
                                linejoin = "round",
                                linemitre = 1,
                                linesize = 0.5,
                                linecolour = waiver(),
                                linecolor = waiver(),
                                arrow = NULL,
                                ...) {
  stop('geom_pointrangeline has not been implemented. Sorry')
  if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomPointRangeLine,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      distance = distance,
      lineend = lineend,
      linejoin = linejoin,
      linemitre = linemitre,
      linesize = 0.5,
      linecolour = linecolour,
      arrow = arrow,
      ...
    )
  )
}

#' @rdname lemon-ggproto
#' @keywords internal
#' @format NULL
#' @usage NULL
#  @export
#' @import ggplot2
#' @import gtable
GeomPointRangeLine <- ggproto("GeomPointRangeLine", GeomPointLine,
  required_aes = c("x", "y", "ymin", "ymax"),

  setup_data = function(data, params) {
    data[order(data$PANEL, data$group, data$x), ]
  },
  draw_panel = function(data, panel_params, coord, na.rm = FALSE,
                        distance = grid::unit(3, 'pt'), linesize = 0.5,
                        linecolour = waiver(),
                        arrow = NULL,
                        lineend = "butt", linejoin = "round", linemitre = 1
  ) {
    data <- transform(data, xend = x, y = ymin, yend = ymax)
    grid::gList(ggname("geom_linerange", GeomSegment$draw_panel(data, panel_params, coord)),
                GeomPointLine$draw_panel(data, panel_params, coord,
                                         na.rm=na.rm, distance=distance,
                                         linesize=linesize, linecolour=linecolour,
                                         arrow=arrow, lineend=lineend,
                                         linejoin=linejoin, linemitre=linemitre)
    )
  }
)