New stat: stat_connect()

DESCRIPTION

@@ -247,6 +247,7 @@ Collate:
     'stat-bindot.R'
     'stat-binhex.R'
     'stat-boxplot.R'
+    'stat-connect.R'
     'stat-contour.R'
     'stat-count.R'
     'stat-density-2d.R'

NAMESPACE

@@ -257,6 +257,7 @@ export(StatBin2d)
 export(StatBindot)
 export(StatBinhex)
 export(StatBoxplot)
+export(StatConnect)
 export(StatContour)
 export(StatContourFilled)
 export(StatCount)
@@ -684,6 +685,7 @@ export(stat_bin_2d)
 export(stat_bin_hex)
 export(stat_binhex)
 export(stat_boxplot)
+export(stat_connect)
 export(stat_contour)
 export(stat_contour_filled)
 export(stat_count)

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* New `stat_connect()` to connect points via steps or other shapes 
+  (@teunbrand, #6228)
 * Fixed regression with incorrectly drawn gridlines when using `coord_flip()` 
   (@teunbrand, #6293).
 * Deprecated functions and arguments prior to ggplot2 3.0.0 throw errors instead 

R/stat-connect.R

@@ -0,0 +1,162 @@
+#' Connect observations
+#'
+#' Connect successive points with lines of different shapes.
+#'
+#' @inheritParams layer
+#' @inheritParams geom_point
+#' @param connection A specification of how two points are connected. Can be one
+#'  of the folloing:
+#'  * A string giving a named connection. These options are:
+#'      * `"hv"` to first jump horizontally, then vertically.
+#'      * `"vh"` to first jump vertically, then horizontally.
+#'      * `"mid"` to step half-way between adjacent x-values.
+#'      * `"linear"` to use a straight segment.
+#'  * A numeric matrix with two columns giving x and y coordinates respectively.
+#'    The coordinates should describe points on a path that connect point A
+#'    at location (0, 0) and point B at location (1, 1). At least one of these
+#'    two points is expected to be included in the coordinates.
+#'
+#' @eval rd_aesthetics("stat", "connect")
+#' @export
+#'
+#' @examples
+#' ggplot(head(economics, 20), aes(date, unemploy)) +
+#'   stat_connect(connection = "hv")
+#'
+#' # Setup custom connections
+#' x <- seq(0, 1, length.out = 20)[-1]
+#' smooth <- cbind(x, scales::rescale(1 / (1 + exp(-(x * 10 - 5)))))
+#' zigzag <- cbind(c(0.4, 0.6, 1), c(0.75, 0.25, 1))
+#'
+#' ggplot(head(economics, 10), aes(date, unemploy)) +
+#'   geom_point() +
+#'   stat_connect(aes(colour = "zigzag"), connection = zigzag) +
+#'   stat_connect(aes(colour = "smooth"), connection = smooth)
+stat_connect <- function(
+    mapping = NULL,
+    data = NULL,
+    geom = "path",
+    position = "identity",
+    ...,
+    connection = "hv",
+    na.rm = FALSE,
+    show.legend = NA,
+    inherit.aes = TRUE) {
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = StatConnect,
+    geom = geom,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list2(
+      na.rm = na.rm,
+      connection = connection,
+      ...
+    )
+  )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+StatConnect <- ggproto(
+  "StatConnect", Stat,
+
+  required_aes = c("x|xmin|xmax", "y|ymin|ymax"),
+
+  setup_params = function(data, params) {
+    params$flipped_aes <- has_flipped_aes(
+      data, params,
+      range_is_orthogonal = TRUE, ambiguous = TRUE
+    )
+
+    connection <- params$connection %||% "hv"
+
+    if (is.character(connection)) {
+      check_string(connection)
+      connection <- switch(
+        arg_match0(connection, c("hv", "vh", "mid", "linear")),
+        hv     = matrix(c(1, 1, 0, 1),     2, 2),
+        vh     = matrix(c(0, 0, 0, 1),     2, 2),
+        mid    = matrix(c(0.5, 0.5, 0, 1), 2, 2),
+        linear = matrix(c(0, 1, 0, 1),     2, 2)
+      )
+    }
+
+    if (!is.matrix(connection) ||
+        !typeof(connection) %in% c("integer", "double") ||
+        !identical(dim(connection)[2], 2L)) {
+      extra <- ""
+      if (!is.null(dim(connection)[2])) {
+        extra <- paste0(" with ", dim(connection)[2], " column(s)")
+      }
+      cli::cli_abort(
+        "{.arg connection} must be a numeric {.cls matrix} with 2 columns, \\
+        not {.obj_type_friendly {connection}}{extra}."
+      )
+    }
+
+    if (any(!is.finite(connection))) {
+      cli::cli_abort(
+        "{.arg connection} cannot contain missing or other non-finite values."
+      )
+    }
+
+    if (nrow(connection) < 1) {
+      connection <- NULL
+    }
+
+    params$connection <- connection
+    params
+  },
+
+  compute_group = function(data, scales, connection = "hv", flipped_aes = FALSE) {
+
+    data <- flip_data(data, flipped_aes)
+
+    n <- nrow(data)
+    if (n <= 1) {
+      return(vec_slice(data, 0))
+    }
+
+    if (!is.matrix(connection)) {
+      return(data)
+    }
+    m <- nrow(connection)
+
+    before <- rep(seq_len(n - 1), each = m)
+    after  <- rep(seq_len(n)[-1], each = m)
+
+    data <- vec_slice(data, order(data$x %||% data$xmin))
+
+    # Interpolate x
+    # Note that `length(x) != length(xjust)`, but these are kept in sync due to
+    # the matrix recycling rules (effectively `rep(xjust, ncol(x))`)
+    x <- as.matrix(data[intersect(names(data), ggplot_global$x_aes)])
+    xjust  <- rep(connection[, 1], n - 1L)
+    x <- vec_slice(x, before) * (1 - xjust) + vec_slice(x, after) * xjust
+
+    # Interpolate y
+    y <- as.matrix(data[intersect(names(data), ggplot_global$y_aes)])
+    yjust  <- rep(connection[, 2], n - 1L)
+    y <- vec_slice(y, before) * (1 - yjust) + vec_slice(y, after) * yjust
+
+    # Reconstitute data
+    new_data <- vec_slice(data, before)
+    new_data[colnames(x)] <- split_matrix(x)
+    new_data[colnames(y)] <- split_matrix(y)
+
+    # Esnure data starts and ends are intact
+    if (!all(connection[1, ] == c(0, 0))) {
+      new_data <- vec_c(vec_slice(data, 1), new_data)
+    }
+    if (!all(connection[m, ] == c(1, 1))) {
+      new_data <- vec_c(new_data, vec_slice(data, n))
+    }
+    flip_data(new_data, flipped_aes)
+  }
+
+)

_pkgdown.yml

@@ -69,6 +69,7 @@ reference:
   - stat_unique
   - stat_sf_coordinates
   - stat_manual
+  - stat_connect
   - after_stat
 
 - subtitle: Position adjustment

tests/testthat/_snaps/stat-connect.md

@@ -0,0 +1,24 @@
+# stat_connect rejects invalid connections
+
+    Code
+      test_setup(connection = "foobar")
+    Condition
+      Error in `setup_params()`:
+      ! `connection` must be one of "hv", "vh", "mid", or "linear", not "foobar".
+
+---
+
+    Code
+      test_setup(connection = matrix(1:3, ncol = 1))
+    Condition
+      Error in `setup_params()`:
+      ! `connection` must be a numeric <matrix> with 2 columns, not an integer matrix with 1 column(s).
+
+---
+
+    Code
+      test_setup(connection = matrix(c(1:3, NA), ncol = 2))
+    Condition
+      Error in `setup_params()`:
+      ! `connection` cannot contain missing or other non-finite values.
+

tests/testthat/test-stat-connect.R

@@ -0,0 +1,85 @@
+test_that("stat_connect closes off ends", {
+
+  data <- data.frame(x = 1:3, y = c(1, 2, 0))
+
+  ld <- get_layer_data(
+    ggplot(data, aes(x, y)) +
+      stat_connect(connection = "mid")
+  )
+
+  i <- c(1L, nrow(ld))
+  j <- c(1L, nrow(data))
+  expect_equal(ld$x[i], data$x[j])
+  expect_equal(ld$y[i], data$y[j])
+
+})
+
+test_that("stat_connect works with 1-row connections", {
+  data <- data.frame(x = 1:3, y = c(1, 2, 0))
+
+  ld <- get_layer_data(
+    ggplot(data, aes(x, y)) +
+      stat_connect(connection = cbind(0.5, 0.5))
+  )
+
+  expect_equal(ld$x, c(1, 1.5, 2.5, 3))
+  expect_equal(ld$y, c(1, 1.5, 1.0, 0))
+})
+
+test_that("stat_connect works with ribbons in both orientations", {
+
+  data <- data.frame(x = 1:4, ymin = c(1, 2, 0, 1), ymax = c(3, 4, 3, 4))
+  expected <- data.frame(
+    x    = c(1, 2, 2, 3, 3, 4, 4),
+    ymin = c(1, 1, 2, 2, 0, 0, 1),
+    ymax = c(3, 3, 4, 4, 3, 3, 4)
+  )
+
+  ld <- layer_data(
+    ggplot(data, aes(x, ymin = ymin, ymax = ymax)) +
+      geom_ribbon(stat = "connect", connection = "hv")
+  )
+
+  expect_equal(ld[c("x", "ymin", "ymax")], expected)
+
+  ld <- layer_data(
+    ggplot(data, aes(y = x, xmin = ymin, xmax = ymax)) +
+      geom_ribbon(stat = "connect", connection = "hv", orientation = "y")
+  )
+
+  expect_equal(ld[c("y", "xmin", "xmax")], flip_data(expected, TRUE))
+})
+
+test_that("stat_connect rejects invalid connections", {
+
+  test_setup <- function(...) {
+    StatConnect$setup_params(NULL, list(...))
+  }
+
+  # Accept keyword parameter
+  p <- test_setup(connection = "linear")
+  expect_vector(p$connection, size = 2L, ptype = matrix(NA_real_, 0, 2))
+
+  # Accept xy coord matrix
+  p <- test_setup(connection = cbind(c(0, 1), c(0, 1)))
+  expect_vector(p$connection, size = 2L, ptype = matrix(NA_real_, 0, 2))
+
+
+  p <- test_setup(connection = matrix(NA_real_, 0, 2))
+  expect_null(p$connection)
+
+  expect_snapshot(
+    test_setup(connection = "foobar"),
+    error = TRUE
+  )
+
+  expect_snapshot(
+    test_setup(connection = matrix(1:3, ncol = 1)),
+    error = TRUE
+  )
+
+  expect_snapshot(
+    test_setup(connection = matrix(c(1:3, NA), ncol = 2)),
+    error = TRUE
+  )
+})