diff --git a/DESCRIPTION b/DESCRIPTION index 978cbf725c..67a044e27f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -207,6 +207,7 @@ Collate: 'plot.R' 'position-.R' 'position-collide.R' + 'position-connection.R' 'position-dodge.R' 'position-dodge2.R' 'position-identity.R' diff --git a/NAMESPACE b/NAMESPACE index 391f435b30..30bbbeedb6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -229,6 +229,7 @@ export(GuideNone) export(GuideOld) export(Layout) export(Position) +export(PositionConnect) export(PositionDodge) export(PositionDodge2) export(PositionFill) @@ -511,6 +512,7 @@ export(old_guide) export(panel_cols) export(panel_rows) export(pattern_alpha) +export(position_connect) export(position_dodge) export(position_dodge2) export(position_fill) diff --git a/NEWS.md b/NEWS.md index dd574ac1aa..6b79bea1cc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* New `position_connect()` to change how points on a line a connected + (@teunbrand, #6228). +* Attempt to boost detail in `coord_polar()` and `coord_radial()` near the + center (@teunbrand, #5023) * `guide_*()` can now accept two inside legend theme elements: `legend.position.inside` and `legend.justification.inside`, allowing inside legends to be placed at different positions. Only inside legends with the same diff --git a/R/position-connection.R b/R/position-connection.R new file mode 100644 index 0000000000..2373dff329 --- /dev/null +++ b/R/position-connection.R @@ -0,0 +1,157 @@ +#' Connect observations +#' +#' A line connecting two points is usually drawn as a straight segment. This +#' position adjustment gives additional options for how two points are connected. +#' +#' @param connection +#' A specification of how to points are connected. Can be one of the following: +#' * 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) to point B at location (1, 1). At least one of these two +#' points is expected to be included in the coordinates. +#' +#' @family position adjustments +#' @export +#' +#' @examples +#' # Mirroring `geom_step()` +#' ggplot(head(economics, 20), aes(date, unemploy)) + +#' geom_line(position = "connect") +#' +#' # Making a histogram without bars +#' ggplot(faithful, aes(waiting)) + +#' geom_area( +#' stat = "bin", bins = 20, pad = TRUE, +#' position = position_connect("mid") +#' ) +#' +#' # Using custom connections with a matrix. +#' # Note that point A at (0, 0) is not included, but point B at (1, 1) is. +#' zigzag <- cbind(c(0.4, 0.6, 1), c(0.75, 0.25, 1)) +#' x <- seq(0, 1, length.out = 20)[-1] +#' smooth <- cbind(x, scales::rescale(1 / (1 + exp(-(x * 10 - 5))))) +#' +#' ggplot(head(economics, 10), aes(date, unemploy)) + +#' geom_line(position = position_connect(zigzag), aes(colour = "zigzag")) + +#' geom_line(position = position_connect(smooth), aes(colour = "smooth")) + +#' geom_point() +position_connect <- function(connection = "hv") { + ggproto( + NULL, PositionConnect, + connection = connection + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionConnect <- ggproto( + "PositionConnect", Position, + connection = "hv", + setup_params = function(self, data) { + flipped_aes <- has_flipped_aes(data, ambiguous = TRUE) + connection <- validate_connection( + self$connection, + call = expr(position_connect()) + ) + if (isTRUE(flipped_aes)) { + connection <- connection[, 2:1] + } + list(flipped_aes = flipped_aes, connection = connection) + }, + compute_panel = function(data, params, scales) { + if (is.null(params$connection)) { + return(data) + } + data <- flip_data(data, params$flipped_aes) + data <- dapply(data, "group", build_connection, connection = params$connection) + flip_data(data, params$flipped_aes) + } +) + +# Ensures connection is a 2D numerical matrix with 2 columns +validate_connection <- function(connection, call = caller_env()) { + if (is.character(connection)) { + check_string(connection) + connection <- switch( + arg_match0(connection, c("hv", "vh", "mid", "linear"), error_call = call), + 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], " columns") + } + cli::cli_abort( + paste0("{.arg connection} must be a numeric {.cls matrix} with 2 columns, \\ + not {.obj_type_friendly {connection}}{extra}."), + call = call + ) + } + if (any(!is.finite(connection))) { + cli::cli_abort( + "{.arg connection} cannot contain missing or other non-finite values.", + call = call + ) + } + + if (nrow(connection) < 1) { + return(NULL) + } + connection +} + +# Interpolates between every point and the next +build_connection <- function(data, connection) { + + n <- nrow(data) + if (n <= 1) { + return(vec_slice(data, 0)) + } + m <- nrow(connection) + + # Sort data on `x` + data <- vec_slice(as.data.frame(data), order(data$x %||% data$xmin)) + + # Extract x and y aesthetics + x <- as.matrix(data[intersect(names(data), ggplot_global$x_aes)]) + y <- as.matrix(data[intersect(names(data), ggplot_global$y_aes)]) + + # Setup repeats + before <- rep(seq_len(n - 1), each = m) + after <- rep(seq_len(n)[-1], each = m) + xjust <- rep(connection[, 1], n - 1L) + yjust <- rep(connection[, 2], n - 1L) + + # Do interpolation + # Note: length(xjust) != length(x). These are kept in sync because the + # matrix recycling rules effectively do `rep(xjust, ncol(x))`. + x <- vec_slice(x, before) * (1 - xjust) + vec_slice(x, after) * xjust + 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) + + # Ensure 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)) + } + new_data +} diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index ea01c29996..62ad3551c7 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -4,29 +4,29 @@ % R/geom-raster.R, R/annotation-raster.R, R/axis-secondary.R, R/coord-.R, % R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, R/coord-map.R, % R/coord-polar.R, R/coord-quickmap.R, R/coord-radial.R, R/coord-transform.R, -% R/facet-.R, R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, -% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, R/geom-bin2d.R, -% R/geom-blank.R, R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, -% R/geom-contour.R, R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, -% R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, -% R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, -% R/geom-label.R, R/geom-linerange.R, R/geom-point.R, R/geom-pointrange.R, -% R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, R/geom-spoke.R, -% R/geom-text.R, R/geom-violin.R, R/geom-vline.R, R/guide-.R, R/guide-axis.R, -% R/guide-axis-logticks.R, R/guide-axis-stack.R, R/guide-axis-theta.R, -% R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, R/guide-colorsteps.R, -% R/guide-custom.R, R/guide-none.R, R/guide-old.R, R/layout.R, R/position-.R, -% R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, -% R/position-jitter.R, R/position-jitterdodge.R, R/position-nudge.R, -% R/position-stack.R, R/scale-.R, R/scale-binned.R, R/scale-continuous.R, -% R/scale-date.R, R/scale-discrete-.R, R/scale-identity.R, -% R/stat-align.R, R/stat-bin.R, R/stat-bin2d.R, R/stat-bindot.R, -% R/stat-binhex.R, R/stat-boxplot.R, R/stat-contour.R, R/stat-count.R, -% R/stat-density-2d.R, R/stat-density.R, R/stat-ecdf.R, R/stat-ellipse.R, -% R/stat-function.R, R/stat-identity.R, R/stat-manual.R, R/stat-qq-line.R, -% R/stat-qq.R, R/stat-quantilemethods.R, R/stat-smooth.R, R/stat-sum.R, -% R/stat-summary-2d.R, R/stat-summary-bin.R, R/stat-summary-hex.R, -% R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R +% R/facet-.R, R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, +% R/stat-.R, R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, +% R/geom-bin2d.R, R/geom-blank.R, R/geom-boxplot.R, R/geom-col.R, +% R/geom-path.R, R/geom-contour.R, R/geom-crossbar.R, R/geom-segment.R, +% R/geom-curve.R, R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, +% R/geom-dotplot.R, R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, +% R/geom-hline.R, R/geom-label.R, R/geom-linerange.R, R/geom-point.R, +% R/geom-pointrange.R, R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, +% R/geom-spoke.R, R/geom-text.R, R/geom-violin.R, R/geom-vline.R, +% R/guide-.R, R/guide-axis.R, R/guide-axis-logticks.R, R/guide-axis-stack.R, +% R/guide-axis-theta.R, R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, +% R/guide-colorsteps.R, R/guide-custom.R, R/guide-none.R, R/guide-old.R, +% R/layout.R, R/position-.R, R/position-connection.R, R/position-dodge.R, +% R/position-dodge2.R, R/position-identity.R, R/position-jitter.R, +% R/position-jitterdodge.R, R/position-nudge.R, R/position-stack.R, +% R/scale-.R, R/scale-binned.R, R/scale-continuous.R, R/scale-date.R, +% R/scale-discrete-.R, R/scale-identity.R, R/stat-align.R, R/stat-bin.R, +% R/stat-bin2d.R, R/stat-bindot.R, R/stat-binhex.R, R/stat-boxplot.R, +% R/stat-contour.R, R/stat-count.R, R/stat-density-2d.R, R/stat-density.R, +% R/stat-ecdf.R, R/stat-ellipse.R, R/stat-function.R, R/stat-identity.R, +% R/stat-manual.R, R/stat-qq-line.R, R/stat-qq.R, R/stat-quantilemethods.R, +% R/stat-smooth.R, R/stat-sum.R, R/stat-summary-2d.R, R/stat-summary-bin.R, +% R/stat-summary-hex.R, R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R \docType{data} \name{ggplot2-ggproto} \alias{ggplot2-ggproto} @@ -105,6 +105,7 @@ \alias{GuideOld} \alias{Layout} \alias{Position} +\alias{PositionConnect} \alias{PositionDodge} \alias{PositionDodge2} \alias{PositionIdentity} diff --git a/man/position_connect.Rd b/man/position_connect.Rd new file mode 100644 index 0000000000..8aeeba7074 --- /dev/null +++ b/man/position_connect.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-connection.R +\name{position_connect} +\alias{position_connect} +\title{Connect observations} +\usage{ +position_connect(connection = "hv") +} +\arguments{ +\item{connection}{A specification of how to points are connected. Can be one of the following: +\itemize{ +\item A string giving a named connection. These options are: +\itemize{ +\item \code{"hv"} to first jump horizontally, then vertically. +\item \code{"vh"} to first jump vertically, then horizontally. +\item \code{"mid"} to step half-way between adjacent x-values. +\item \code{"linear"} to use a straight segment. +} +\item 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) to point B at location (1, 1). At least one of these two +points is expected to be included in the coordinates. +}} +} +\description{ +A line connecting two points is usually drawn as a straight segment. This +position adjustment gives additional options for how two points are connected. +} +\examples{ +# Mirroring `geom_step()` +ggplot(head(economics, 20), aes(date, unemploy)) + + geom_line(position = "connect") + +# Making a histogram without bars +ggplot(faithful, aes(waiting)) + + geom_area( + stat = "bin", bins = 20, pad = TRUE, + position = position_connect("mid") + ) + +# Using custom connections with a matrix. +# Note that point A at (0, 0) is not included, but point B at (1, 1) is. +zigzag <- cbind(c(0.4, 0.6, 1), c(0.75, 0.25, 1)) +x <- seq(0, 1, length.out = 20)[-1] +smooth <- cbind(x, scales::rescale(1 / (1 + exp(-(x * 10 - 5))))) + +ggplot(head(economics, 10), aes(date, unemploy)) + + geom_line(position = position_connect(zigzag), aes(colour = "zigzag")) + + geom_line(position = position_connect(smooth), aes(colour = "smooth")) + + geom_point() +} +\seealso{ +Other position adjustments: +\code{\link{position_dodge}()}, +\code{\link{position_identity}()}, +\code{\link{position_jitter}()}, +\code{\link{position_jitterdodge}()}, +\code{\link{position_nudge}()}, +\code{\link{position_stack}()} +} +\concept{position adjustments} diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index e4f9211110..bffe5dff52 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -113,6 +113,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + } \seealso{ Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_identity}()}, \code{\link{position_jitter}()}, \code{\link{position_jitterdodge}()}, diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 26e840cfaa..21702ce18c 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -11,6 +11,7 @@ Don't adjust position } \seealso{ Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_dodge}()}, \code{\link{position_jitter}()}, \code{\link{position_jitterdodge}()}, diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index b43f4ade40..7d659fa816 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -56,6 +56,7 @@ ggplot(mtcars, aes(am, vs)) + } \seealso{ Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_dodge}()}, \code{\link{position_identity}()}, \code{\link{position_jitterdodge}()}, diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index ca5bb8e30c..cf1ab72a43 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -47,6 +47,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + } \seealso{ Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_dodge}()}, \code{\link{position_identity}()}, \code{\link{position_jitter}()}, diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index 3b2b2573cb..2ab14ab546 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -36,6 +36,7 @@ ggplot(df, aes(x, y)) + } \seealso{ Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_dodge}()}, \code{\link{position_identity}()}, \code{\link{position_jitter}()}, diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 646ab3c515..e69caf8335 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -146,6 +146,7 @@ See \code{\link[=geom_bar]{geom_bar()}} and \code{\link[=geom_area]{geom_area()} more examples. Other position adjustments: +\code{\link{position_connect}()}, \code{\link{position_dodge}()}, \code{\link{position_identity}()}, \code{\link{position_jitter}()}, diff --git a/tests/testthat/_snaps/position-connection.md b/tests/testthat/_snaps/position-connection.md new file mode 100644 index 0000000000..e7a096bb0e --- /dev/null +++ b/tests/testthat/_snaps/position-connection.md @@ -0,0 +1,24 @@ +# position_connection validates connections + + Code + p$setup_params(NULL) + Condition + Error in `position_connect()`: + ! `connection` must be one of "hv", "vh", "mid", or "linear", not "foobar". + +--- + + Code + p$setup_params(NULL) + Condition + Error in `position_connect()`: + ! `connection` must be a numeric with 2 columns, not an integer matrix with 1 columns. + +--- + + Code + p$setup_params(NULL) + Condition + Error in `position_connect()`: + ! `connection` cannot contain missing or other non-finite values. + diff --git a/tests/testthat/test-position-connection.R b/tests/testthat/test-position-connection.R new file mode 100644 index 0000000000..8944fa1559 --- /dev/null +++ b/tests/testthat/test-position-connection.R @@ -0,0 +1,87 @@ + +test_that("position_connection closes off ends", { + data <- data.frame(x = c(1, 2, 3), y = c(1, 2, 0), group = -1L) + + params <- list(flipped_aes = FALSE, connection = validate_connection("hv")) + test <- PositionConnect$compute_panel(data, params, list()) + + n <- nrow(test) + expect_equal(test$x[c(1, n)], data$x[c(1, 3)]) + expect_equal(test$y[c(1, n)], data$y[c(1, 3)]) + + params <- list(flipped_aes = FALSE, connection = validate_connection("vh")) + test <- PositionConnect$compute_panel(data, params, list()) + + n <- nrow(test) + expect_equal(test$x[c(1, n)], data$x[c(1, 3)]) + expect_equal(test$y[c(1, n)], data$y[c(1, 3)]) + + params <- list(flipped_aes = FALSE, connection = validate_connection("mid")) + test <- PositionConnect$compute_panel(data, params, list()) + + n <- nrow(test) + expect_equal(test$x[c(1, n)], data$x[c(1, 3)]) + expect_equal(test$y[c(1, n)], data$y[c(1, 3)]) + +}) + +test_that("position_connection works with 1-row connection", { + data <- data.frame(x = c(1, 2, 3), y = c(1, 2, 0), group = -1L) + + params <- list(flipped_aes = FALSE, connection = cbind(0.5, 0.5)) + test <- PositionConnect$compute_panel(data, params, list()) + + expect_equal(test$x, c(1, 1.5, 2.5, 3)) + expect_equal(test$y, c(1, 1.5, 1.0, 0)) +}) + +test_that("position_connection works with ribbons regardless of orientation", { + + 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) + ) + + p <- ggplot(data, aes(x, ymin = ymin, ymax = ymax)) + + geom_ribbon(position = position_connect(connection = "hv")) + test <- layer_data(p) + expect_equal(test[c("x", "ymin", "ymax")], expected) + + p <- ggplot(data, aes(y = x, xmin = ymin, xmax = ymax)) + + geom_ribbon(position = position_connect(connection = "vh")) + test <- layer_data(p) + expect_equal(test[c("y", "xmin", "xmax")], flip_data(expected, TRUE)) + +}) + +test_that("position_connection validates connections", { + + # Good: one of the keywords + p <- position_connect(connection = "linear") + params <- p$setup_params(NULL) + expect_vector(params$connection, size = 2L, ptype = matrix(NA_real_, 0, 2)) + + # Good: manual matrix + p <- position_connect(connection = cbind(c(0, 1), c(0, 1))) + params <- p$setup_params(NULL) + expect_vector(params$connection, size = 2L, ptype = matrix(NA_real_, 0, 2)) + + # Allowed: 0-row matrix, becomes NULL + p <- position_connect(connection = matrix(NA_real_, nrow = 0, ncol = 2)) + params <- p$setup_params(NULL) + expect_null(params$connection) + + # Forbidden: non-keywords + p <- position_connect(connection = "foobar") + expect_snapshot(p$setup_params(NULL), error = TRUE) + + # Forbidden: malformed matrices + p <- position_connect(connection = matrix(1:3, ncol = 1)) + expect_snapshot(p$setup_params(NULL), error = TRUE) + + # Forbidden: NAs + p <- position_connect(connection = matrix(c(1:3, NA), 2, 2)) + expect_snapshot(p$setup_params(NULL), error = TRUE) +})