From a486906bc134daa797d48b45186be0130621d2a1 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:09:06 +0200 Subject: [PATCH 001/125] Add position_nudgestack --- R/position-nudgestack.R | 117 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 R/position-nudgestack.R diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R new file mode 100644 index 0000000000..f978593441 --- /dev/null +++ b/R/position-nudgestack.R @@ -0,0 +1,117 @@ +#' Simultaneously nudge and stack +#' +#' This is primarily used for set stacked columns between the ticks on the +#' x-axis. +#' +#' @family position adjustments +#' @param x,y Amount of vertical and horizontal distance to move. +#' @param vjust Vertical adjustment for geoms that have a position +#' (like points or lines), not a dimension (like bars or areas). Set to +#' `0` to align with the bottom, `0.5` for the middle, +#' and `1` (the default) for the top. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. +#' @export +#' @examples +#' data <- mtcars +#' ggplot() + +#' geom_col( +#' data, +#' aes(x = cyl, y = gear, fill = gear), +#' position = position_nudgestack(x = 1) +#' ) +position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { + ggproto(NULL, PositionNudgeStack, + x = x, + y = y, + vjust = vjust, + reverse = reverse + ) +} + + + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionNudgeStack <- ggproto("PositionNudgeStack", Position, + x = 0, + y = 0, + type = NULL, + vjust = 1, + fill = FALSE, + reverse = FALSE, + + setup_params = function(self, data) { + list( + x = self$x, + y = self$y, + var = if (!is.null(self$var)) self$var else stack_var(data), + fill = self$fill, + vjust = self$vjust, + reverse = self$reverse + ) + }, + + setup_data = function(self, data, params) { + if (is.null(params$var)) { + return(data) + } + + data$ymax <- switch(params$var, + y = data$y, + ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) + ) + + remove_missing( + data, + vars = c("x", "xmin", "xmax", "y"), + name = "position_stack" + ) + }, + + compute_layer = function(self, data, params, layout) { + if (is.null(params$var)) { + return(data) + } + + negative <- data$ymax < 0 + negative[is.na(negative)] <- FALSE + + neg <- data[negative, , drop = FALSE] + pos <- data[!negative, , drop = FALSE] + + if (any(negative)) { + neg <- collide(neg, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + if (any(!negative)) { + pos <- collide(pos, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] + + + + # transform only the dimensions for which non-zero nudging is requested + if (any(params$x != 0)) { + if (any(params$y != 0)) { + transform_position(data, function(x) x + params$x, function(y) y + params$y) + } else { + transform_position(data, function(x) x + params$x, NULL) + } + } else if (any(params$y != 0)) { + transform_position(data, NULL, function(y) y + params$y) + } else { + data # if both x and y are 0 we don't need to transform + } + } +) From 01d7db0a484bc2f025545331b4e138995c77503c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:26:32 +0200 Subject: [PATCH 002/125] Delete emtpy rows --- R/position-nudgestack.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index f978593441..60e67169dd 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -29,8 +29,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ) } - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -99,8 +97,6 @@ PositionNudgeStack <- ggproto("PositionNudgeStack", Position, data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] - - # transform only the dimensions for which non-zero nudging is requested if (any(params$x != 0)) { if (any(params$y != 0)) { From 23e324197e0a5ddd764588d42838b0d96da9b68d Mon Sep 17 00:00:00 2001 From: Mara Alexeev <39673697+MaraAlexeev@users.noreply.github.com> Date: Tue, 3 Sep 2019 08:26:07 -0400 Subject: [PATCH 003/125] Clarify documentation in mpg: very minor (#3515) * add helpful explanation of mpg$drv --- R/data.R | 2 +- man/mpg.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/data.R b/R/data.R index 909c639b93..aee286cc57 100644 --- a/R/data.R +++ b/R/data.R @@ -100,7 +100,7 @@ #' \item{year}{year of manufacture} #' \item{cyl}{number of cylinders} #' \item{trans}{type of transmission} -#' \item{drv}{f = front-wheel drive, r = rear wheel drive, 4 = 4wd} +#' \item{drv}{the type of drive train, where f = front-wheel drive, r = rear wheel drive, 4 = 4wd} #' \item{cty}{city miles per gallon} #' \item{hwy}{highway miles per gallon} #' \item{fl}{fuel type} diff --git a/man/mpg.Rd b/man/mpg.Rd index 598a59979f..63b4f8ca44 100644 --- a/man/mpg.Rd +++ b/man/mpg.Rd @@ -12,7 +12,7 @@ \item{year}{year of manufacture} \item{cyl}{number of cylinders} \item{trans}{type of transmission} -\item{drv}{f = front-wheel drive, r = rear wheel drive, 4 = 4wd} +\item{drv}{the type of drive train, where f = front-wheel drive, r = rear wheel drive, 4 = 4wd} \item{cty}{city miles per gallon} \item{hwy}{highway miles per gallon} \item{fl}{fuel type} From bcc75a394e3ad37ed917fa446443bf727deabf2c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 004/125] Add time series example --- R/position-nudgestack.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 60e67169dd..a2837ba90e 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,13 +13,23 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' data <- mtcars -#' ggplot() + -#' geom_col( -#' data, -#' aes(x = cyl, y = gear, fill = gear), -#' position = position_nudgestack(x = 1) +#' library(dplyr) +#' library(ggplot2) +#' ESM <- data.frame( +#' as.matrix(EuStockMarkets), +#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), +#' format = "%d %b %Y" #' ) +#' ) +#' +#' ESM_prep <- ESM %>% +#' tidyr::gather(key = key, value = value, -date) %>% +#' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' +#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, x = x, @@ -36,7 +46,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From fedef933ca622259130d4b3dd7f0717c63c9f578 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:56:35 +0200 Subject: [PATCH 005/125] Add new position to DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 95cb820686..db8d7cc03d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -179,6 +179,7 @@ Collate: 'position-jitter.r' 'position-jitterdodge.R' 'position-nudge.R' + 'position-nudgestack.R' 'position-stack.r' 'quick-plot.r' 'range.r' From e5e91ea5358c68d2d94f542f51ad76f6a2ef5473 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:58:38 +0200 Subject: [PATCH 006/125] Add new position_nudgestack into NAMESPACE --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3670510528..a5d486488b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -188,6 +188,7 @@ export(PositionIdentity) export(PositionJitter) export(PositionJitterdodge) export(PositionNudge) +export(PositionNudgeStack) export(PositionStack) export(Scale) export(ScaleContinuous) @@ -405,6 +406,7 @@ export(position_identity) export(position_jitter) export(position_jitterdodge) export(position_nudge) +export(position_nudgestack) export(position_stack) export(qplot) export(quickplot) From 971b110ab8c4ebb1076b1ecb69c64693afa81d8d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 007/125] Add position-nudgestack.R into man --- man/ggplot2-ggproto.Rd | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index df35148ece..e52deb35fc 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -14,15 +14,15 @@ % R/geom-spoke.r, R/geom-text.r, R/geom-tile.r, R/geom-violin.r, % R/geom-vline.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-continuous.r, R/scale-date.r, R/scale-discrete-.r, -% R/scale-identity.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-qq-line.R, R/stat-qq.r, -% R/stat-quantile.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/position-jitterdodge.R, R/position-nudge.R, R/position-nudgestack.R, +% R/position-stack.r, R/scale-.r, R/scale-continuous.r, R/scale-date.r, +% R/scale-discrete-.r, R/scale-identity.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-qq-line.R, +% R/stat-qq.r, R/stat-quantile.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} @@ -90,6 +90,7 @@ \alias{PositionJitter} \alias{PositionJitterdodge} \alias{PositionNudge} +\alias{PositionNudgeStack} \alias{PositionStack} \alias{PositionFill} \alias{Scale} From 99b4b5e1177edb4a7675db25094e927e20bf8a3b Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:13 +0200 Subject: [PATCH 008/125] Add position_nudgestack into description --- man/position_dodge.Rd | 1 + man/position_identity.Rd | 1 + man/position_jitter.Rd | 1 + man/position_jitterdodge.Rd | 1 + man/position_nudge.Rd | 1 + man/position_stack.Rd | 1 + 6 files changed, 6 insertions(+) diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index a35191e4fa..cef3386d86 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -96,6 +96,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + Other position adjustments: \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 440e575682..994bd2952e 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -13,6 +13,7 @@ Don't adjust position Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index 16548f6496..37b6df322c 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -58,6 +58,7 @@ ggplot(mtcars, aes(am, vs)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index f543bb332a..ff6e5f05b9 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -40,6 +40,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index aaf735e236..9597692160 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -39,6 +39,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_stack}} } \concept{position adjustments} diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 39ea363603..991aed9c2c 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -144,6 +144,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}} } \concept{position adjustments} From 5ebe5d408cb62b2635ac1761ba36c1b402c561dd Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:48 +0200 Subject: [PATCH 009/125] Add description of position_nudgestack --- man/position_nudgestack.Rd | 41 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 man/position_nudgestack.Rd diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd new file mode 100644 index 0000000000..e23e8d4ca3 --- /dev/null +++ b/man/position_nudgestack.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-nudgestack.R +\name{position_nudgestack} +\alias{position_nudgestack} +\title{Simultaneously nudge and stack} +\usage{ +position_nudgestack(x = 0, y = 0, vjust = 1, reverse = FALSE) +} +\arguments{ +\item{x, y}{Amount of vertical and horizontal distance to move.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} +} +\description{ +This is primarily used for set stacked columns between the ticks on the +x-axis. +} +\examples{ +data <- mtcars +ggplot() + + geom_col( + data, + aes(x = cyl, y = gear, fill = gear), + position = position_nudgestack(x = 1) + ) +} +\seealso{ +Other position adjustments: \code{\link{position_dodge}}, + \code{\link{position_identity}}, + \code{\link{position_jitterdodge}}, + \code{\link{position_jitter}}, + \code{\link{position_nudge}}, + \code{\link{position_stack}} +} +\concept{position adjustments} From c1729d170214ab45947d7cbcac061172e261cfdb Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 010/125] Add the zoo-package to Suggestions --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index db8d7cc03d..cb2bfb7169 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Suggests: sf (>= 0.7-3), svglite (>= 1.2.0.9001), testthat (>= 2.1.0), - vdiffr (>= 0.3.0) + vdiffr (>= 0.3.0), + zoo Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From def47559ae4df0b8ef197325b4312c839f715da5 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 011/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a2837ba90e..fdfa395feb 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -26,7 +26,7 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From 02f6be4f6bd4749295dc732107cc38a36a790ecc Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:20 +0200 Subject: [PATCH 012/125] Delete packages from @examples --- R/position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fdfa395feb..a031937593 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,8 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' library(dplyr) -#' library(ggplot2) #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From a681f591a495f7378ad912caf736a9fe60e261f7 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 013/125] Add new examples --- man/position_nudgestack.Rd | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index e23e8d4ca3..0c97b2c6d9 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,13 +22,23 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -data <- mtcars -ggplot() + - geom_col( - data, - aes(x = cyl, y = gear, fill = gear), - position = position_nudgestack(x = 1) +library(dplyr) +library(ggplot2) +ESM <- data.frame( + as.matrix(EuStockMarkets), + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "\%d \%b \%Y" ) +) + +ESM_prep <- ESM \%>\% + tidyr::gather(key = key, value = value, -date) \%>\% + group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% + filter(date >= "1995-01-01" & date < "1998-01-01") + +ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) } \seealso{ Other position adjustments: \code{\link{position_dodge}}, From e2c1fb6440d62feebae9dc65176577f23ffeed39 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 014/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/testthat/test-position-nudgestack.R diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R new file mode 100644 index 0000000000..cda3fd3e20 --- /dev/null +++ b/tests/testthat/test-position-nudgestack.R @@ -0,0 +1,27 @@ +context("position_nudgestack") + +test_that("position_nudgestack draws correctly", { + ESM <- data_frame( + DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], + SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], + CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], + FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "%d %b %Y" + ) + ) + + ESM_prep <- ESM %>% + tidyr::gather(key = key, value = value, -date) %>% + group_by(date, key) %>% + summarize(value = mean(value)) %>% + filter(date >= "1995-01-01" & date < "1998-01-01") + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) + + expect_doppelganger( + "nudgestack EuStockMarkets data", + stock_marked + ) +}) From 2484f71296a7f1345b40e504d23d0054c589bb05 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:50 +0200 Subject: [PATCH 015/125] Update vdiffr version --- tests/figs/deps.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/figs/deps.txt b/tests/figs/deps.txt index 059d357267..0f64e23e67 100644 --- a/tests/figs/deps.txt +++ b/tests/figs/deps.txt @@ -1,3 +1,3 @@ - vdiffr-svg-engine: 1.0 -- vdiffr: 0.3.0 +- vdiffr: 0.3.1 - freetypeharfbuzz: 0.2.5 From 015b2e35f8c791a1add8ab814f4a6d9de42f790c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 016/125] Add validated svg for position_nudgestack --- .../nudgestack-eustockmarkets-data.svg | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg new file mode 100644 index 0000000000..fc0ed6d9a6 --- /dev/null +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -0,0 +1,203 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10000 +20000 + + + + + + + +1995 +1996 +1997 +1998 +date +value + +key + + + + + + + + +CAC +DAX +FTSE +SMI +nudgestack EuStockMarkets data + From d5c58da560999c63e499081c83fe4e776f6f48d2 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:37 +0200 Subject: [PATCH 017/125] Delete packages from example --- man/position_nudgestack.Rd | 2 -- 1 file changed, 2 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 0c97b2c6d9..7efb57a035 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,8 +22,6 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -library(dplyr) -library(ggplot2) ESM <- data.frame( as.matrix(EuStockMarkets), date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From c32f85616e0e7fae8173ce57f4bf9e018e365cc5 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 018/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 93 +++++++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index cda3fd3e20..6ac2277a09 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -25,3 +25,96 @@ test_that("position_nudgestack draws correctly", { stock_marked ) }) + + +test_that("nudging works in both dimensions simultaneously", { + # individual nudge value for continuous data + set.seed(111) + + df <- data_frame(x = 1:3) + + p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + + geom_col(position = position_nudgestack(x = 0.5, y = 2)) + + data <- layer_data(p) + + expect_equal(data$x, 1.5:3.5) + expect_equal(data$xmin, 1.05:3.05) + expect_equal(data$xmax, 1.95:3.95) + expect_equal(data$y, 3:5) + expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymax, 3:5) + +}) + +test_that("nudging works for discrete values correctly", { + set.seed(111) + + # x nudge value for discrete data + series <- data.frame( + time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c('a', 'b', 'c', 'd'), 4), + value = rpois(16, 10) + ) + + p <- ggplot(series, aes(time, value, group = type)) + + geom_line(aes(colour = type), position = position_nudgestack(x = 0.5)) + + geom_point(aes(colour = type), position = position_nudgestack(x = 0.5)) + + data <- layer_data(p) + + expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + +}) + + +test_that("data is sorted prior to stacking", { + df <- data_frame( + x = rep(c(1:10), 3), + var = rep(c("a", "b", "c"), 10), + y = round(runif(30, 1, 5)) + ) + p <- ggplot(df, aes(x = x, y = y, fill = var)) + + geom_col(position = position_nudgestack(x = 0.5)) + + dat <- layer_data(p) + expect_true(all(dat$group == 3:1)) +}) + +test_that("negative and positive values are handled separately", { + df <- data_frame( + x = c(1,1,1,2,2), + g = c(1,2,3,1,2), + y = c(1,-1,1,2,-3) + ) + p <- ggplot(df, aes(x, y, fill = factor(g))) + + geom_col(position = position_nudgestack(x = 0.5)) + dat <- layer_data(p) + + expect_equal(dat$ymin[dat$x == 1.5], c(0, -1, 1)) + expect_equal(dat$ymax[dat$x == 1.5], c(1, 0, 2)) + + expect_equal(dat$ymin[dat$x == 2.5], c(0, -3)) + expect_equal(dat$ymax[dat$x == 2.5], c(2, 0)) +}) + +test_that("can request reverse stacking", { + df <- data_frame( + y = c(-2, 2, -1, 1), + g = c("a", "a", "b", "b") + ) + p <- ggplot(df, aes(1, y, fill = g)) + + geom_col(position = position_nudgestack(x = 0.5, reverse = TRUE)) + dat <- layer_data(p) + expect_equal(dat$ymin, c(-2, 0, -3, 2)) +}) + +test_that("position_nudgestack() can stack correctly when ymax is NA", { + df <- data_frame(x = c(1, 1), y = c(1, 1)) + p <- ggplot(df, aes(x, y, ymax = NA_real_)) + + geom_point(position = position_nudgestack(x = 0.5)) + expect_equal(layer_data(p)$y, c(1, 2)) +}) + From 2782c9d63bc8d92044272ced5d818bad4b75f9b2 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:09:06 +0200 Subject: [PATCH 019/125] Add position_nudgestack --- R/position-nudgestack.R | 117 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 R/position-nudgestack.R diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R new file mode 100644 index 0000000000..f978593441 --- /dev/null +++ b/R/position-nudgestack.R @@ -0,0 +1,117 @@ +#' Simultaneously nudge and stack +#' +#' This is primarily used for set stacked columns between the ticks on the +#' x-axis. +#' +#' @family position adjustments +#' @param x,y Amount of vertical and horizontal distance to move. +#' @param vjust Vertical adjustment for geoms that have a position +#' (like points or lines), not a dimension (like bars or areas). Set to +#' `0` to align with the bottom, `0.5` for the middle, +#' and `1` (the default) for the top. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. +#' @export +#' @examples +#' data <- mtcars +#' ggplot() + +#' geom_col( +#' data, +#' aes(x = cyl, y = gear, fill = gear), +#' position = position_nudgestack(x = 1) +#' ) +position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { + ggproto(NULL, PositionNudgeStack, + x = x, + y = y, + vjust = vjust, + reverse = reverse + ) +} + + + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionNudgeStack <- ggproto("PositionNudgeStack", Position, + x = 0, + y = 0, + type = NULL, + vjust = 1, + fill = FALSE, + reverse = FALSE, + + setup_params = function(self, data) { + list( + x = self$x, + y = self$y, + var = if (!is.null(self$var)) self$var else stack_var(data), + fill = self$fill, + vjust = self$vjust, + reverse = self$reverse + ) + }, + + setup_data = function(self, data, params) { + if (is.null(params$var)) { + return(data) + } + + data$ymax <- switch(params$var, + y = data$y, + ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) + ) + + remove_missing( + data, + vars = c("x", "xmin", "xmax", "y"), + name = "position_stack" + ) + }, + + compute_layer = function(self, data, params, layout) { + if (is.null(params$var)) { + return(data) + } + + negative <- data$ymax < 0 + negative[is.na(negative)] <- FALSE + + neg <- data[negative, , drop = FALSE] + pos <- data[!negative, , drop = FALSE] + + if (any(negative)) { + neg <- collide(neg, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + if (any(!negative)) { + pos <- collide(pos, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] + + + + # transform only the dimensions for which non-zero nudging is requested + if (any(params$x != 0)) { + if (any(params$y != 0)) { + transform_position(data, function(x) x + params$x, function(y) y + params$y) + } else { + transform_position(data, function(x) x + params$x, NULL) + } + } else if (any(params$y != 0)) { + transform_position(data, NULL, function(y) y + params$y) + } else { + data # if both x and y are 0 we don't need to transform + } + } +) From 3d61c3a93b3031937f5d3a4e8b53e7f65b28af3b Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:26:32 +0200 Subject: [PATCH 020/125] Delete emtpy rows --- R/position-nudgestack.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index f978593441..60e67169dd 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -29,8 +29,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ) } - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -99,8 +97,6 @@ PositionNudgeStack <- ggproto("PositionNudgeStack", Position, data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] - - # transform only the dimensions for which non-zero nudging is requested if (any(params$x != 0)) { if (any(params$y != 0)) { From 85724371d96e9c415547f8c792793da4ea4c2d9f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 021/125] Add time series example --- R/position-nudgestack.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 60e67169dd..a2837ba90e 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,13 +13,23 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' data <- mtcars -#' ggplot() + -#' geom_col( -#' data, -#' aes(x = cyl, y = gear, fill = gear), -#' position = position_nudgestack(x = 1) +#' library(dplyr) +#' library(ggplot2) +#' ESM <- data.frame( +#' as.matrix(EuStockMarkets), +#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), +#' format = "%d %b %Y" #' ) +#' ) +#' +#' ESM_prep <- ESM %>% +#' tidyr::gather(key = key, value = value, -date) %>% +#' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' +#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, x = x, @@ -36,7 +46,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From c5022d3665b15442f2f90f8a366c1a6be191e512 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:56:35 +0200 Subject: [PATCH 022/125] Add new position to DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 95cb820686..db8d7cc03d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -179,6 +179,7 @@ Collate: 'position-jitter.r' 'position-jitterdodge.R' 'position-nudge.R' + 'position-nudgestack.R' 'position-stack.r' 'quick-plot.r' 'range.r' From 9bd40d60e58b1156927fb0ab775ace3b6fc586db Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:58:38 +0200 Subject: [PATCH 023/125] Add new position_nudgestack into NAMESPACE --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3670510528..a5d486488b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -188,6 +188,7 @@ export(PositionIdentity) export(PositionJitter) export(PositionJitterdodge) export(PositionNudge) +export(PositionNudgeStack) export(PositionStack) export(Scale) export(ScaleContinuous) @@ -405,6 +406,7 @@ export(position_identity) export(position_jitter) export(position_jitterdodge) export(position_nudge) +export(position_nudgestack) export(position_stack) export(qplot) export(quickplot) From 7bb930c6759ee752c2a3078c98953c285c60e476 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 024/125] Add position-nudgestack.R into man --- man/ggplot2-ggproto.Rd | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index df35148ece..e52deb35fc 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -14,15 +14,15 @@ % R/geom-spoke.r, R/geom-text.r, R/geom-tile.r, R/geom-violin.r, % R/geom-vline.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-continuous.r, R/scale-date.r, R/scale-discrete-.r, -% R/scale-identity.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-qq-line.R, R/stat-qq.r, -% R/stat-quantile.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/position-jitterdodge.R, R/position-nudge.R, R/position-nudgestack.R, +% R/position-stack.r, R/scale-.r, R/scale-continuous.r, R/scale-date.r, +% R/scale-discrete-.r, R/scale-identity.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-qq-line.R, +% R/stat-qq.r, R/stat-quantile.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} @@ -90,6 +90,7 @@ \alias{PositionJitter} \alias{PositionJitterdodge} \alias{PositionNudge} +\alias{PositionNudgeStack} \alias{PositionStack} \alias{PositionFill} \alias{Scale} From 548f313d13e6810168fef725e765e9c052b42b55 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:13 +0200 Subject: [PATCH 025/125] Add position_nudgestack into description --- man/position_dodge.Rd | 1 + man/position_identity.Rd | 1 + man/position_jitter.Rd | 1 + man/position_jitterdodge.Rd | 1 + man/position_nudge.Rd | 1 + man/position_stack.Rd | 1 + 6 files changed, 6 insertions(+) diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index a35191e4fa..cef3386d86 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -96,6 +96,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + Other position adjustments: \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 440e575682..994bd2952e 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -13,6 +13,7 @@ Don't adjust position Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index 16548f6496..37b6df322c 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -58,6 +58,7 @@ ggplot(mtcars, aes(am, vs)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index f543bb332a..ff6e5f05b9 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -40,6 +40,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index aaf735e236..9597692160 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -39,6 +39,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_stack}} } \concept{position adjustments} diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 39ea363603..991aed9c2c 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -144,6 +144,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}} } \concept{position adjustments} From 42c0fa3e4be760d5c40e665ac64f5444cfd0f342 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:48 +0200 Subject: [PATCH 026/125] Add description of position_nudgestack --- man/position_nudgestack.Rd | 41 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 man/position_nudgestack.Rd diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd new file mode 100644 index 0000000000..e23e8d4ca3 --- /dev/null +++ b/man/position_nudgestack.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-nudgestack.R +\name{position_nudgestack} +\alias{position_nudgestack} +\title{Simultaneously nudge and stack} +\usage{ +position_nudgestack(x = 0, y = 0, vjust = 1, reverse = FALSE) +} +\arguments{ +\item{x, y}{Amount of vertical and horizontal distance to move.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} +} +\description{ +This is primarily used for set stacked columns between the ticks on the +x-axis. +} +\examples{ +data <- mtcars +ggplot() + + geom_col( + data, + aes(x = cyl, y = gear, fill = gear), + position = position_nudgestack(x = 1) + ) +} +\seealso{ +Other position adjustments: \code{\link{position_dodge}}, + \code{\link{position_identity}}, + \code{\link{position_jitterdodge}}, + \code{\link{position_jitter}}, + \code{\link{position_nudge}}, + \code{\link{position_stack}} +} +\concept{position adjustments} From ef5aef71f4b5a0bfd92424a32df5578a91e5fe8d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 027/125] Add the zoo-package to Suggestions --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index db8d7cc03d..cb2bfb7169 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Suggests: sf (>= 0.7-3), svglite (>= 1.2.0.9001), testthat (>= 2.1.0), - vdiffr (>= 0.3.0) + vdiffr (>= 0.3.0), + zoo Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From 9291957420dfb0a7ce82d17bc45d68cd877bf3e7 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 028/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a2837ba90e..fdfa395feb 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -26,7 +26,7 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From 37134200b495f6815dd7ba7e498136f52cdf8608 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:20 +0200 Subject: [PATCH 029/125] Delete packages from @examples --- R/position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fdfa395feb..a031937593 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,8 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' library(dplyr) -#' library(ggplot2) #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From f44e50460c5e4882e22cb488b1f6e3016bef81b2 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 030/125] Add new examples --- man/position_nudgestack.Rd | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index e23e8d4ca3..0c97b2c6d9 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,13 +22,23 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -data <- mtcars -ggplot() + - geom_col( - data, - aes(x = cyl, y = gear, fill = gear), - position = position_nudgestack(x = 1) +library(dplyr) +library(ggplot2) +ESM <- data.frame( + as.matrix(EuStockMarkets), + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "\%d \%b \%Y" ) +) + +ESM_prep <- ESM \%>\% + tidyr::gather(key = key, value = value, -date) \%>\% + group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% + filter(date >= "1995-01-01" & date < "1998-01-01") + +ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) } \seealso{ Other position adjustments: \code{\link{position_dodge}}, From be9189377d557dfe3a76dbdbc91e5004664e00b0 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 031/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/testthat/test-position-nudgestack.R diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R new file mode 100644 index 0000000000..cda3fd3e20 --- /dev/null +++ b/tests/testthat/test-position-nudgestack.R @@ -0,0 +1,27 @@ +context("position_nudgestack") + +test_that("position_nudgestack draws correctly", { + ESM <- data_frame( + DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], + SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], + CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], + FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "%d %b %Y" + ) + ) + + ESM_prep <- ESM %>% + tidyr::gather(key = key, value = value, -date) %>% + group_by(date, key) %>% + summarize(value = mean(value)) %>% + filter(date >= "1995-01-01" & date < "1998-01-01") + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) + + expect_doppelganger( + "nudgestack EuStockMarkets data", + stock_marked + ) +}) From e6df407f0205bb4456c63c1d79779b75a0033ffb Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:50 +0200 Subject: [PATCH 032/125] Update vdiffr version --- tests/figs/deps.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/figs/deps.txt b/tests/figs/deps.txt index 059d357267..0f64e23e67 100644 --- a/tests/figs/deps.txt +++ b/tests/figs/deps.txt @@ -1,3 +1,3 @@ - vdiffr-svg-engine: 1.0 -- vdiffr: 0.3.0 +- vdiffr: 0.3.1 - freetypeharfbuzz: 0.2.5 From 823c686fa6a30273a986f0a2b9a815bb3f9f9938 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 033/125] Add validated svg for position_nudgestack --- .../nudgestack-eustockmarkets-data.svg | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg new file mode 100644 index 0000000000..fc0ed6d9a6 --- /dev/null +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -0,0 +1,203 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10000 +20000 + + + + + + + +1995 +1996 +1997 +1998 +date +value + +key + + + + + + + + +CAC +DAX +FTSE +SMI +nudgestack EuStockMarkets data + From 4fb69961ad832913661a8e8081b9f8e1ceeceaae Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:37 +0200 Subject: [PATCH 034/125] Delete packages from example --- man/position_nudgestack.Rd | 2 -- 1 file changed, 2 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 0c97b2c6d9..7efb57a035 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,8 +22,6 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -library(dplyr) -library(ggplot2) ESM <- data.frame( as.matrix(EuStockMarkets), date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From 10b5e2400197b5db300f5eb02c25d8803eabd38a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 035/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 93 +++++++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index cda3fd3e20..6ac2277a09 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -25,3 +25,96 @@ test_that("position_nudgestack draws correctly", { stock_marked ) }) + + +test_that("nudging works in both dimensions simultaneously", { + # individual nudge value for continuous data + set.seed(111) + + df <- data_frame(x = 1:3) + + p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + + geom_col(position = position_nudgestack(x = 0.5, y = 2)) + + data <- layer_data(p) + + expect_equal(data$x, 1.5:3.5) + expect_equal(data$xmin, 1.05:3.05) + expect_equal(data$xmax, 1.95:3.95) + expect_equal(data$y, 3:5) + expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymax, 3:5) + +}) + +test_that("nudging works for discrete values correctly", { + set.seed(111) + + # x nudge value for discrete data + series <- data.frame( + time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c('a', 'b', 'c', 'd'), 4), + value = rpois(16, 10) + ) + + p <- ggplot(series, aes(time, value, group = type)) + + geom_line(aes(colour = type), position = position_nudgestack(x = 0.5)) + + geom_point(aes(colour = type), position = position_nudgestack(x = 0.5)) + + data <- layer_data(p) + + expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + +}) + + +test_that("data is sorted prior to stacking", { + df <- data_frame( + x = rep(c(1:10), 3), + var = rep(c("a", "b", "c"), 10), + y = round(runif(30, 1, 5)) + ) + p <- ggplot(df, aes(x = x, y = y, fill = var)) + + geom_col(position = position_nudgestack(x = 0.5)) + + dat <- layer_data(p) + expect_true(all(dat$group == 3:1)) +}) + +test_that("negative and positive values are handled separately", { + df <- data_frame( + x = c(1,1,1,2,2), + g = c(1,2,3,1,2), + y = c(1,-1,1,2,-3) + ) + p <- ggplot(df, aes(x, y, fill = factor(g))) + + geom_col(position = position_nudgestack(x = 0.5)) + dat <- layer_data(p) + + expect_equal(dat$ymin[dat$x == 1.5], c(0, -1, 1)) + expect_equal(dat$ymax[dat$x == 1.5], c(1, 0, 2)) + + expect_equal(dat$ymin[dat$x == 2.5], c(0, -3)) + expect_equal(dat$ymax[dat$x == 2.5], c(2, 0)) +}) + +test_that("can request reverse stacking", { + df <- data_frame( + y = c(-2, 2, -1, 1), + g = c("a", "a", "b", "b") + ) + p <- ggplot(df, aes(1, y, fill = g)) + + geom_col(position = position_nudgestack(x = 0.5, reverse = TRUE)) + dat <- layer_data(p) + expect_equal(dat$ymin, c(-2, 0, -3, 2)) +}) + +test_that("position_nudgestack() can stack correctly when ymax is NA", { + df <- data_frame(x = c(1, 1), y = c(1, 1)) + p <- ggplot(df, aes(x, y, ymax = NA_real_)) + + geom_point(position = position_nudgestack(x = 0.5)) + expect_equal(layer_data(p)$y, c(1, 2)) +}) + From 696fe9d3aefae10bcabd21192b90b84013b4c5f0 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Fri, 27 Sep 2019 15:58:51 +0200 Subject: [PATCH 036/125] Bugfix --- tests/testthat/test-position-nudgestack.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 6ac2277a09..f3532c9686 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -2,10 +2,10 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { ESM <- data_frame( - DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], - SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], - CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], - FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + DAX = EuStockMarkets[,"DAX"], + SMI = EuStockMarkets[,"SMI"], + CAC = EuStockMarkets[,"CAC"], + FTSE = EuStockMarkets[,"FTSE"], date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), format = "%d %b %Y" ) From fa000f786cb0b641600b6de68ae0f96e2ffc5e75 Mon Sep 17 00:00:00 2001 From: Dewey Dunnington Date: Sun, 29 Sep 2019 18:26:36 -0300 Subject: [PATCH 037/125] Make position guides customizable (#3398, closes #3322) * Position guides can now be customized using the new `guide_axis()`, which can be passed to position `scale_*()` functions or via `guides()`. The new axis guide (`guide_axis()`) comes with arguments `check.overlap` (automatic removal of overlapping labels), `angle` (easy rotation of axis labels), and `n.dodge` (dodge labels into multiple rows/columns) * `CoordCartesian` gets new methods to resolve/train the new position guides --- DESCRIPTION | 1 + NAMESPACE | 14 + NEWS.md | 7 + R/axis-secondary.R | 14 +- R/coord-.r | 10 +- R/coord-cartesian-.r | 109 ++++++- R/coord-flip.r | 29 +- R/coord-polar.r | 6 +- R/coord-sf.R | 2 + R/guides-.r | 35 +- R/guides-axis.r | 192 ++++++++++- R/guides-none.r | 44 +++ R/layout.R | 30 +- R/plot-build.r | 1 + R/scale-continuous.r | 8 +- R/scale-date.r | 16 +- R/scale-discrete-.r | 8 +- R/scale-view.r | 42 ++- man/guide-exts.Rd | 3 + man/guide_axis.Rd | 53 +++ man/guide_none.Rd | 20 ++ man/scale_continuous.Rd | 9 +- man/scale_date.Rd | 19 +- man/scale_discrete.Rd | 9 +- man/sec_axis.Rd | 7 +- .../figs/guides/guide-axis-customization.svg | 292 +++++++++++++++++ .../guides/guides-specified-in-guides.svg | 305 ++++++++++++++++++ tests/figs/guides/position-guide-titles.svg | 34 ++ .../sec-axis/sec-axis-custom-transform.svg | 36 +-- .../sec-axis-independent-transformations.svg | 16 +- .../sec-axis/sec-axis-monotonicity-test.svg | 16 +- .../sec-axis/sec-axis-sec-power-transform.svg | 20 +- .../sec-axis/sec-axis-skewed-transform.svg | 20 +- .../figs/sec-axis/sec-axis-with-division.svg | 12 +- tests/figs/themes/axes-styling.svg | 32 +- tests/figs/themes/ticks-length.svg | 32 +- tests/testthat/test-guides.R | 89 ++++- 37 files changed, 1422 insertions(+), 170 deletions(-) create mode 100644 R/guides-none.r create mode 100644 man/guide_axis.Rd create mode 100644 man/guide_none.Rd create mode 100644 tests/figs/guides/guide-axis-customization.svg create mode 100644 tests/figs/guides/guides-specified-in-guides.svg create mode 100644 tests/figs/guides/position-guide-titles.svg diff --git a/DESCRIPTION b/DESCRIPTION index 95cb820686..c20a3cd7a5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -158,6 +158,7 @@ Collate: 'guides-.r' 'guides-axis.r' 'guides-grid.r' + 'guides-none.r' 'hexbin.R' 'labeller.r' 'labels.r' diff --git a/NAMESPACE b/NAMESPACE index 3670510528..28b49f80ad 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,14 +67,25 @@ S3method(grobWidth,absoluteGrob) S3method(grobWidth,zeroGrob) S3method(grobX,absoluteGrob) S3method(grobY,absoluteGrob) +S3method(guide_gengrob,axis) S3method(guide_gengrob,colorbar) +S3method(guide_gengrob,guide_none) S3method(guide_gengrob,legend) +S3method(guide_geom,axis) S3method(guide_geom,colorbar) +S3method(guide_geom,guide_none) S3method(guide_geom,legend) +S3method(guide_merge,axis) S3method(guide_merge,colorbar) +S3method(guide_merge,guide_none) S3method(guide_merge,legend) +S3method(guide_train,axis) S3method(guide_train,colorbar) +S3method(guide_train,guide_none) S3method(guide_train,legend) +S3method(guide_transform,axis) +S3method(guide_transform,default) +S3method(guide_transform,guide_none) S3method(heightDetails,titleGrob) S3method(heightDetails,zeroGrob) S3method(interleave,default) @@ -358,13 +369,16 @@ export(ggproto) export(ggproto_parent) export(ggsave) export(ggtitle) +export(guide_axis) export(guide_colorbar) export(guide_colourbar) export(guide_gengrob) export(guide_geom) export(guide_legend) export(guide_merge) +export(guide_none) export(guide_train) +export(guide_transform) export(guides) export(is.Coord) export(is.facet) diff --git a/NEWS.md b/NEWS.md index 5e96c37dcf..5dd0bea39b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # ggplot2 (development version) +* Position guides can now be customized using the new `guide_axis()`, + which can be passed to position `scale_*()` functions or via + `guides()`. The new axis guide (`guide_axis()`) comes with + arguments `check.overlap` (automatic removal of overlapping + labels), `angle` (easy rotation of axis labels), and + `n.dodge` (dodge labels into multiple rows/columns) (@paleolimbot, #3322). + * `Geom` now gains a `setup_params()` method in line with the other ggproto classes (@thomasp85, #3509) diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 0d7f6df1a3..27b0554bd0 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -20,6 +20,9 @@ #' - A character vector giving labels (must be same length as `breaks`) #' - A function that takes the breaks as input and returns labels as output #' +#' @param guide A position guide that will be used to render +#' the axis on the plot. Usually this is [guide_axis()]. +#' #' @details #' `sec_axis` is used to create the specifications for a secondary axis. #' Except for the `trans` argument any of the arguments can be set to @@ -79,7 +82,8 @@ #' labels = scales::time_format("%b %d %I %p"))) #' #' @export -sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels = waiver()) { +sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels = waiver(), + guide = waiver()) { # sec_axis() historically accpeted two-sided formula, so be permissive. if (length(trans) > 2) trans <- trans[c(1,3)] @@ -88,14 +92,15 @@ sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels = trans = trans, name = name, breaks = breaks, - labels = labels + labels = labels, + guide = guide ) } #' @rdname sec_axis #' #' @export -dup_axis <- function(trans = ~., name = derive(), breaks = derive(), labels = derive()) { - sec_axis(trans, name, breaks, labels) +dup_axis <- function(trans = ~., name = derive(), breaks = derive(), labels = derive(), guide = derive()) { + sec_axis(trans, name, breaks, labels, guide) } is.sec_axis <- function(x) { @@ -148,6 +153,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, if (is.derived(self$breaks)) self$breaks <- scale$breaks if (is.waive(self$breaks)) self$breaks <- scale$trans$breaks if (is.derived(self$labels)) self$labels <- scale$labels + if (is.derived(self$guide)) self$guide <- scale$guide }, transform_range = function(self, range) { diff --git a/R/coord-.r b/R/coord-.r index e2ea1a025d..26f45c9c17 100644 --- a/R/coord-.r +++ b/R/coord-.r @@ -59,7 +59,7 @@ Coord <- ggproto("Coord", aspect = function(ranges) NULL, - labels = function(panel_params) panel_params, + labels = function(labels, panel_params) labels, render_fg = function(panel_params, theme) element_render(theme, "panel.border"), @@ -91,6 +91,14 @@ Coord <- ggproto("Coord", list() }, + setup_panel_guides = function(self, panel_params, guides, params = list()) { + panel_params + }, + + train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + panel_params + }, + transform = function(data, range) NULL, distance = function(x, y, panel_params) NULL, diff --git a/R/coord-cartesian-.r b/R/coord-cartesian-.r index 8222604039..d36a49674a 100644 --- a/R/coord-cartesian-.r +++ b/R/coord-cartesian-.r @@ -103,6 +103,75 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, ) }, + setup_panel_guides = function(self, panel_params, guides, params = list()) { + aesthetics <- c("x", "y", "x.sec", "y.sec") + names(aesthetics) <- aesthetics + + # resolve the specified guide from the scale and/or guides + guides <- lapply(aesthetics, function(aesthetic) { + resolve_guide( + aesthetic, + panel_params[[aesthetic]], + guides, + default = guide_axis(), + null = guide_none() + ) + }) + + # resolve the guide definition as a "guide" S3 + guides <- lapply(guides, validate_guide) + + # if there is an "position" specification in the scale, pass this on to the guide + # ideally, this should be specified in the guide + guides <- lapply(aesthetics, function(aesthetic) { + guide <- guides[[aesthetic]] + scale <- panel_params[[aesthetic]] + # position could be NULL here for an empty scale + guide$position <- guide$position %|W|% scale$position + guide + }) + + panel_params$guides <- guides + panel_params + }, + + train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + aesthetics <- c("x", "y", "x.sec", "y.sec") + names(aesthetics) <- aesthetics + + panel_params$guides <- lapply(aesthetics, function(aesthetic) { + axis <- substr(aesthetic, 1, 1) + guide <- panel_params$guides[[aesthetic]] + guide <- guide_train(guide, panel_params[[aesthetic]]) + guide <- guide_transform(guide, self, panel_params) + guide <- guide_geom(guide, layers, default_mapping) + guide + }) + + panel_params + }, + + labels = function(self, labels, panel_params) { + positions_x <- c("top", "bottom") + positions_y <- c("left", "right") + + list( + x = lapply(c(1, 2), function(i) { + panel_guide_label( + panel_params$guides, + position = positions_x[[i]], + default_label = labels$x[[i]] + ) + }), + y = lapply(c(1, 2), function(i) { + panel_guide_label( + panel_params$guides, + position = positions_y[[i]], + default_label = labels$y[[i]]) + }) + ) + }, + render_bg = function(panel_params, theme) { guide_grid( theme, @@ -114,24 +183,16 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, }, render_axis_h = function(panel_params, theme) { - arrange <- panel_params$x.arrange %||% c("secondary", "primary") - arrange_scale_keys <- c("primary" = "x", "secondary" = "x.sec")[arrange] - arrange_scales <- panel_params[arrange_scale_keys] - list( - top = draw_view_scale_axis(arrange_scales[[1]], "top", theme), - bottom = draw_view_scale_axis(arrange_scales[[2]], "bottom", theme) + top = panel_guides_grob(panel_params$guides, position = "top", theme = theme), + bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme) ) }, render_axis_v = function(panel_params, theme) { - arrange <- panel_params$y.arrange %||% c("primary", "secondary") - arrange_scale_keys <- c("primary" = "y", "secondary" = "y.sec")[arrange] - arrange_scales <- panel_params[arrange_scale_keys] - list( - left = draw_view_scale_axis(arrange_scales[[1]], "left", theme), - right = draw_view_scale_axis(arrange_scales[[2]], "right", theme) + left = panel_guides_grob(panel_params$guides, position = "left", theme = theme), + right = panel_guides_grob(panel_params$guides, position = "right", theme = theme) ) } ) @@ -153,10 +214,24 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { view_scales } -draw_view_scale_axis <- function(view_scale, axis_position, theme) { - if(is.null(view_scale) || view_scale$is_empty()) { - return(zeroGrob()) - } +panel_guide_label <- function(guides, position, default_label) { + guide <- guide_for_position(guides, position) %||% guide_none(title = NULL) + guide$title %|W|% default_label +} + +panel_guides_grob <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) %||% guide_none() + guide_gengrob(guide, theme) +} + +guide_for_position <- function(guides, position) { + has_position <- vapply( + guides, + function(guide) identical(guide$position, position), + logical(1) + ) - draw_axis(view_scale$break_positions(), view_scale$get_labels(), axis_position, theme) + guides <- guides[has_position] + guides_order <- vapply(guides, function(guide) as.numeric(guide$order)[1], numeric(1)) + Reduce(guide_merge, guides[order(guides_order)]) } diff --git a/R/coord-flip.r b/R/coord-flip.r index 71d11f26ec..45e87c57f5 100644 --- a/R/coord-flip.r +++ b/R/coord-flip.r @@ -40,7 +40,7 @@ coord_flip <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") { CoordFlip <- ggproto("CoordFlip", CoordCartesian, transform = function(data, panel_params) { - data <- flip_labels(data) + data <- flip_axis_labels(data) CoordCartesian$transform(data, panel_params) }, @@ -58,11 +58,11 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, setup_panel_params = function(self, scale_x, scale_y, params = list()) { parent <- ggproto_parent(CoordCartesian, self) panel_params <- parent$setup_panel_params(scale_x, scale_y, params) - flip_labels(panel_params) + flip_axis_labels(panel_params) }, - labels = function(panel_params) { - flip_labels(CoordCartesian$labels(panel_params)) + labels = function(labels, panel_params) { + flip_axis_labels(CoordCartesian$labels(labels, panel_params)) }, setup_layout = function(layout, params) { @@ -72,14 +72,29 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, }, modify_scales = function(scales_x, scales_y) { - lapply(scales_x, scale_flip_position) - lapply(scales_y, scale_flip_position) + lapply(scales_x, scale_flip_axis) + lapply(scales_y, scale_flip_axis) } ) +# In-place modification of a scale position to swap axes +scale_flip_axis <- function(scale) { + scale$position <- switch(scale$position, + top = "right", + bottom = "left", + left = "bottom", + right = "top", + scale$position + ) + + invisible(scale) +} -flip_labels <- function(x) { +# maintaining the position of the x* and y* names is +# important for re-using the same guide_transform() +# as CoordCartesian +flip_axis_labels <- function(x) { old_names <- names(x) new_names <- old_names diff --git a/R/coord-polar.r b/R/coord-polar.r index fd5d44fa3f..591447d015 100644 --- a/R/coord-polar.r +++ b/R/coord-polar.r @@ -305,11 +305,11 @@ CoordPolar <- ggproto("CoordPolar", Coord, ) }, - labels = function(self, panel_params) { + labels = function(self, labels, panel_params) { if (self$theta == "y") { - list(x = panel_params$y, y = panel_params$x) + list(x = labels$y, y = labels$x) } else { - panel_params + labels } }, diff --git a/R/coord-sf.R b/R/coord-sf.R index b73227c7e7..ed41ce4c94 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -195,6 +195,8 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, diff(panel_params$y_range) / diff(panel_params$x_range) / ratio }, + labels = function(labels, panel_params) labels, + render_bg = function(self, panel_params, theme) { el <- calc_element("panel.grid.major", theme) diff --git a/R/guides-.r b/R/guides-.r index 0ad41eb131..40284afa00 100644 --- a/R/guides-.r +++ b/R/guides-.r @@ -73,7 +73,7 @@ update_guides <- function(p, guides) { } -# building guides - called in ggplotGrob (plot-render.r) +# building non-position guides - called in ggplotGrob (plot-build.r) # # the procedure is as follows: # @@ -116,7 +116,13 @@ build_guides <- function(scales, layers, default_mapping, position, theme, guide } # scales -> data for guides - gdefs <- guides_train(scales = scales, theme = theme, guides = guides, labels = labels) + gdefs <- guides_train( + scales = scales$non_position_scales(), + theme = theme, + guides = guides, + labels = labels + ) + if (length(gdefs) == 0) return(zeroGrob()) # merge overlay guides @@ -148,9 +154,15 @@ legend_position <- function(position) { } } +# resolve the guide from the scale and guides +resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { + guides[[aesthetic]] %||% scale$guide %|W|% default %||% null +} + # validate guide object validate_guide <- function(guide) { # if guide is specified by character, then find the corresponding guide + # when guides are officially extensible, this should use find_global() if (is.character(guide)) match.fun(paste("guide_", guide, sep = ""))() else if (inherits(guide, "guide")) @@ -170,12 +182,12 @@ guides_train <- function(scales, theme, guides, labels) { # which is prior to scale_ZZZ(guide=XXX) # guide is determined in order of: # + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend) - guide <- guides[[output]] %||% scale$guide + guide <- resolve_guide(output, scale, guides) # this should be changed to testing guide == "none" # scale$legend is backward compatibility # if guides(XXX=FALSE), then scale_ZZZ(guides=XXX) is discarded. - if (identical(guide, "none") || isFALSE(guide)) next + if (identical(guide, "none") || isFALSE(guide) || inherits(guide, "guide_none")) next # check the validity of guide. # if guide is character, then find the guide object @@ -322,6 +334,21 @@ guide_merge <- function(guide, new_guide) UseMethod("guide_merge") #' @rdname guide-exts guide_geom <- function(guide, layers, default_mapping) UseMethod("guide_geom") +#' @export +#' @rdname guide-exts +guide_transform <- function(guide, coord, panel_params) UseMethod("guide_transform") + +#' @export +guide_transform.default <- function(guide, coord, panel_params) { + stop( + "Guide with class ", + paste(class(guide), collapse = " / "), + " does not implement guide_transform(). ", + "Did you mean to use guide_axis()?", + call. = FALSE + ) +} + #' @export #' @rdname guide-exts guide_gengrob <- function(guide, theme) UseMethod("guide_gengrob") diff --git a/R/guides-axis.r b/R/guides-axis.r index d7bc5449ed..ef0c7b6f65 100644 --- a/R/guides-axis.r +++ b/R/guides-axis.r @@ -1,4 +1,165 @@ +#' Axis guide +#' +#' Axis guides are the visual representation of position scales like those +#' created with [scale_(x|y)_continuous()][scale_x_continuous()] and +#' [scale_(x|y)_discrete()][scale_x_discrete()]. +#' +#' @inheritParams guide_legend +#' @param check.overlap silently remove overlapping labels, +#' (recursively) prioritizing the first, last, and middle labels. +#' @param angle Compared to setting the angle in [theme()] / [element_text()], +#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that +#' you probably want. +#' @param n.dodge The number of rows (for vertical axes) or columns (for +#' horizontal axes) that should be used to render the labels. This is +#' useful for displaying labels that would otherwise overlap. +#' @param order Used to determine the order of the guides (left-to-right, +#' top-to-bottom), if more than one guide must be drawn at the same location. +#' @param position Where this guide should be drawn: one of top, bottom, +#' left, or right. +#' +#' @export +#' +#' @examples +#' # plot with overlapping text +#' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + +#' geom_point() + +#' facet_wrap(vars(class)) +#' +#' # axis guides can be customized in the scale_* functions or +#' # using guides() +#' p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) +#' p + guides(x = guide_axis(angle = 90)) +#' +#' # can also be used to add a duplicate guide +#' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) +#' +#' +guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, n.dodge = 1, + order = 0, position = waiver()) { + structure( + list( + title = title, + + # customizations + check.overlap = check.overlap, + angle = angle, + n.dodge = n.dodge, + + # general + order = order, + position = position, + + # parameter + available_aes = c("x", "y"), + + name = "axis" + ), + class = c("guide", "axis") + ) +} + +#' @export +guide_train.axis <- function(guide, scale, aesthetic = NULL) { + + aesthetic <- aesthetic %||% scale$aesthetics[1] + breaks <- scale$get_breaks() + + empty_ticks <- new_data_frame( + list(aesthetic = numeric(0), .value = numeric(0), .label = character(0)) + ) + names(empty_ticks) <- c(aesthetic, ".value", ".label") + + if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { + warning( + "axis guide needs appropriate scales: ", + paste(guide$available_aes, collapse = ", "), + call. = FALSE + ) + guide$key <- empty_ticks + } else if (length(breaks) == 0) { + guide$key <- empty_ticks + } else { + ticks <- new_data_frame(setNames(list(scale$map(breaks)), aesthetic)) + ticks$.value <- breaks + ticks$.label <- scale$get_labels(breaks) + + if (is.list(ticks$.label)) { + if (any(sapply(ticks$.label, is.language))) { + ticks$.label <- do.call(expression, ticks$.label) + } else { + ticks$.label <- unlist(ticks$.label) + } + } + + guide$key <- ticks + } + + guide$name <- paste0(guide$name, "_", aesthetic) + guide$hash <- digest::digest(list(guide$title, guide$key$.value, guide$key$.label, guide$name)) + guide +} + +#' @export +guide_transform.axis <- function(guide, coord, panel_params) { + if (is.null(guide$position) || nrow(guide$key) == 0) { + return(guide) + } + + aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))] + + if (all(c("x", "y") %in% aesthetics)) { + guide$key <- coord$transform(guide$key, panel_params) + } else { + other_aesthetic <- setdiff(c("x", "y"), aesthetics) + override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf + guide$key[[other_aesthetic]] <- override_value + + guide$key <- coord$transform(guide$key, panel_params) + + warn_for_guide_position(guide) + } + + guide +} + +# discards the new guide with a warning +#' @export +guide_merge.axis <- function(guide, new_guide) { + if (!inherits(guide, "guide_none")) { + warning( + "guide_axis(): Discarding guide on merge. ", + "Do you have more than one guide with the same position?", + call. = FALSE + ) + } + + guide +} + +# axis guides don't care which geometry uses these aesthetics +#' @export +guide_geom.axis <- function(guide, layers, default_mapping) { + guide +} + +#' @export +guide_gengrob.axis <- function(guide, theme) { + aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1] + + draw_axis( + break_positions = guide$key[[aesthetic]], + break_labels = guide$key$.label, + axis_position = guide$position, + theme = theme, + check.overlap = guide$check.overlap, + angle = guide$angle, + n.dodge = guide$n.dodge + ) +} + + #' Grob for axes #' #' @param break_position position of ticks @@ -10,14 +171,14 @@ #' @param angle Compared to setting the angle in [theme()] / [element_text()], #' this also uses some heuristics to automatically pick the `hjust` and `vjust` that #' you probably want. -#' @param n_dodge The number of rows (for vertical axes) or columns (for +#' @param n.dodge The number of rows (for vertical axes) or columns (for #' horizontal axes) that should be used to render the labels. This is #' useful for displaying labels that would otherwise overlap. #' #' @noRd #' draw_axis <- function(break_positions, break_labels, axis_position, theme, - check.overlap = FALSE, angle = NULL, n_dodge = 1) { + check.overlap = FALSE, angle = NULL, n.dodge = 1) { axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left")) aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y" @@ -96,7 +257,7 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme, } # calculate multiple rows/columns of labels (which is usually 1) - dodge_pos <- rep(seq_len(n_dodge), length.out = n_breaks) + dodge_pos <- rep(seq_len(n.dodge), length.out = n_breaks) dodge_indices <- split(seq_len(n_breaks), dodge_pos) label_grobs <- lapply(dodge_indices, function(indices) { @@ -256,3 +417,28 @@ axis_label_element_overrides <- function(axis_position, angle = NULL) { stop("Unrecognized position: '", axis_position, "'", call. = FALSE) } } + +warn_for_guide_position <- function(guide) { + if (empty(guide$key) || nrow(guide$key) == 1) { + return() + } + + # this is trying to catch when a user specifies a position perpendicular + # to the direction of the axis (e.g., a "y" axis on "top") + + if (guide$position %in% c("top", "bottom")) { + position_aes <- "x" + } else if(guide$position %in% c("left", "right")) { + position_aes <- "y" + } else { + return() + } + + if (length(unique(guide$key[[position_aes]])) == 1) { + warning( + "Position guide is perpendicular to the intended axis. ", + "Did you mean to specify a different guide `position`?", + call. = FALSE + ) + } +} diff --git a/R/guides-none.r b/R/guides-none.r new file mode 100644 index 0000000000..e27b6e9892 --- /dev/null +++ b/R/guides-none.r @@ -0,0 +1,44 @@ + +#' Empty guide +#' +#' This guide draws nothing. +#' +#' @inheritParams guide_axis +#' +#' @export +#' +guide_none <- function(title = waiver(), position = waiver()) { + structure( + list( + title = title, + position = position, + available_aes = "any" + ), + class = c("guide", "guide_none") + ) +} + +#' @export +guide_train.guide_none <- function(guide, scale, aesthetic = NULL) { + guide +} + +#' @export +guide_merge.guide_none <- function(guide, new_guide) { + new_guide +} + +#' @export +guide_geom.guide_none <- function(guide, layers, default_mapping) { + guide +} + +#' @export +guide_transform.guide_none <- function(guide, coord, panel_params) { + guide +} + +#' @export +guide_gengrob.guide_none <- function(guide, theme, ...) { + zeroGrob() +} diff --git a/R/layout.R b/R/layout.R index 966f301fda..b1f9bb2a89 100644 --- a/R/layout.R +++ b/R/layout.R @@ -104,10 +104,13 @@ Layout <- ggproto("Layout", NULL, ) # Draw individual labels, then add to gtable - labels <- self$coord$labels(list( - x = self$xlabel(labels), - y = self$ylabel(labels) - )) + labels <- self$coord$labels( + list( + x = self$xlabel(labels), + y = self$ylabel(labels) + ), + self$panel_params[[1]] + ) labels <- self$render_labels(labels, theme) self$facet$draw_labels( plot_table, @@ -209,6 +212,25 @@ Layout <- ggproto("Layout", NULL, invisible() }, + setup_panel_guides = function(self, guides, layers, default_mapping) { + self$panel_params <- lapply( + self$panel_params, + self$coord$setup_panel_guides, + guides, + self$coord_params + ) + + self$panel_params <- lapply( + self$panel_params, + self$coord$train_panel_guides, + layers, + default_mapping, + self$coord_params + ) + + invisible() + }, + xlabel = function(self, labels) { primary <- self$panel_scales_x[[1]]$name %|W|% labels$x primary <- self$panel_scales_x[[1]]$make_title(primary) diff --git a/R/plot-build.r b/R/plot-build.r index e24a3d8882..714d200307 100644 --- a/R/plot-build.r +++ b/R/plot-build.r @@ -166,6 +166,7 @@ ggplot_gtable.ggplot_built <- function(data) { theme <- plot_theme(plot) geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot$layers, data) + layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping) plot_table <- layout$render(geom_grobs, data, theme, plot$labels) # Legends diff --git a/R/scale-continuous.r b/R/scale-continuous.r index 662f39b913..8f1cfb1217 100644 --- a/R/scale-continuous.r +++ b/R/scale-continuous.r @@ -76,14 +76,14 @@ NULL scale_x_continuous <- function(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, - na.value = NA_real_, trans = "identity", + na.value = NA_real_, trans = "identity", guide = waiver(), position = "bottom", sec.axis = waiver()) { sc <- continuous_scale( c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper", "x0"), "position_c", identity, name = name, breaks = breaks, minor_breaks = minor_breaks, labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value, trans = trans, - guide = "none", position = position, super = ScaleContinuousPosition + guide = guide, position = position, super = ScaleContinuousPosition ) set_sec_axis(sec.axis, sc) @@ -95,14 +95,14 @@ scale_x_continuous <- function(name = waiver(), breaks = waiver(), scale_y_continuous <- function(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, - na.value = NA_real_, trans = "identity", + na.value = NA_real_, trans = "identity", guide = waiver(), position = "left", sec.axis = waiver()) { sc <- continuous_scale( c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", "lower", "middle", "upper", "y0"), "position_c", identity, name = name, breaks = breaks, minor_breaks = minor_breaks, labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value, trans = trans, - guide = "none", position = position, super = ScaleContinuousPosition + guide = guide, position = position, super = ScaleContinuousPosition ) set_sec_axis(sec.axis, sc) diff --git a/R/scale-date.r b/R/scale-date.r index 030d2f412d..14f002d702 100644 --- a/R/scale-date.r +++ b/R/scale-date.r @@ -66,6 +66,7 @@ scale_x_date <- function(name = waiver(), date_minor_breaks = waiver(), limits = NULL, expand = waiver(), + guide = waiver(), position = "bottom", sec.axis = waiver()) { @@ -80,7 +81,7 @@ scale_x_date <- function(name = waiver(), date_labels = date_labels, minor_breaks = minor_breaks, date_minor_breaks = date_minor_breaks, - guide = "none", + guide = guide, limits = limits, expand = expand, position = position @@ -100,6 +101,7 @@ scale_y_date <- function(name = waiver(), date_minor_breaks = waiver(), limits = NULL, expand = waiver(), + guide = waiver(), position = "left", sec.axis = waiver()) { @@ -114,7 +116,7 @@ scale_y_date <- function(name = waiver(), date_labels = date_labels, minor_breaks = minor_breaks, date_minor_breaks = date_minor_breaks, - guide = "none", + guide = guide, limits = limits, expand = expand, position = position @@ -135,6 +137,7 @@ scale_x_datetime <- function(name = waiver(), timezone = NULL, limits = NULL, expand = waiver(), + guide = waiver(), position = "bottom", sec.axis = waiver()) { @@ -150,7 +153,7 @@ scale_x_datetime <- function(name = waiver(), minor_breaks = minor_breaks, date_minor_breaks = date_minor_breaks, timezone = timezone, - guide = "none", + guide = guide, limits = limits, expand = expand, position = position @@ -172,6 +175,7 @@ scale_y_datetime <- function(name = waiver(), timezone = NULL, limits = NULL, expand = waiver(), + guide = waiver(), position = "left", sec.axis = waiver()) { @@ -187,7 +191,7 @@ scale_y_datetime <- function(name = waiver(), minor_breaks = minor_breaks, date_minor_breaks = date_minor_breaks, timezone = timezone, - guide = "none", + guide = guide, limits = limits, expand = expand, position = position @@ -208,6 +212,7 @@ scale_x_time <- function(name = waiver(), expand = waiver(), oob = censor, na.value = NA_real_, + guide = waiver(), position = "bottom", sec.axis = waiver()) { @@ -220,6 +225,7 @@ scale_x_time <- function(name = waiver(), expand = expand, oob = oob, na.value = na.value, + guide = guide, position = position, trans = scales::hms_trans(), sec.axis = sec.axis @@ -237,6 +243,7 @@ scale_y_time <- function(name = waiver(), expand = waiver(), oob = censor, na.value = NA_real_, + guide = waiver(), position = "left", sec.axis = waiver()) { @@ -249,6 +256,7 @@ scale_y_time <- function(name = waiver(), expand = expand, oob = oob, na.value = na.value, + guide = guide, position = position, trans = scales::hms_trans(), sec.axis = sec.axis diff --git a/R/scale-discrete-.r b/R/scale-discrete-.r index 49e7e0eee7..1390bef2af 100644 --- a/R/scale-discrete-.r +++ b/R/scale-discrete-.r @@ -47,18 +47,18 @@ #' geom_point() + #' scale_x_discrete(labels = abbreviate) #' } -scale_x_discrete <- function(..., expand = waiver(), position = "bottom") { +scale_x_discrete <- function(..., expand = waiver(), guide = waiver(), position = "bottom") { sc <- discrete_scale(c("x", "xmin", "xmax", "xend"), "position_d", identity, ..., - expand = expand, guide = "none", position = position, super = ScaleDiscretePosition) + expand = expand, guide = guide, position = position, super = ScaleDiscretePosition) sc$range_c <- continuous_range() sc } #' @rdname scale_discrete #' @export -scale_y_discrete <- function(..., expand = waiver(), position = "left") { +scale_y_discrete <- function(..., expand = waiver(), guide = waiver(), position = "left") { sc <- discrete_scale(c("y", "ymin", "ymax", "yend"), "position_d", identity, ..., - expand = expand, guide = "none", position = position, super = ScaleDiscretePosition) + expand = expand, guide = guide, position = position, super = ScaleDiscretePosition) sc$range_c <- continuous_range() sc diff --git a/R/scale-view.r b/R/scale-view.r index 13afdba516..2986e275cd 100644 --- a/R/scale-view.r +++ b/R/scale-view.r @@ -26,13 +26,14 @@ view_scale_primary <- function(scale, limits = scale$get_limits(), ggproto(NULL, ViewScale, scale = scale, + guide = scale$guide, + position = scale$position, aesthetics = scale$aesthetics, name = scale$name, scale_is_discrete = scale$is_discrete(), limits = limits, continuous_range = continuous_range, breaks = breaks, - labels = scale$get_labels(breaks), minor_breaks = minor_breaks ) } @@ -40,17 +41,37 @@ view_scale_primary <- function(scale, limits = scale$get_limits(), # this function is a hack that is difficult to avoid given the complex implementation of second axes view_scale_secondary <- function(scale, limits = scale$get_limits(), continuous_range = scale$dimension(limits = limits)) { + if (is.null(scale$secondary.axis) || is.waive(scale$secondary.axis) || scale$secondary.axis$empty()) { - view_scale_empty() + # if there is no second axis, return the primary scale with no guide + # this guide can be overridden using guides() + primary_scale <- view_scale_primary(scale, limits, continuous_range) + scale_flip_position(primary_scale) + primary_scale$guide <- guide_none() + primary_scale } else { scale$secondary.axis$init(scale) break_info <- scale$secondary.axis$break_info(continuous_range, scale) names(break_info) <- gsub("sec\\.", "", names(break_info)) + # flip position from the original scale by default + # this can (should) be overridden in the guide + position <- switch(scale$position, + top = "bottom", + bottom = "top", + left = "right", + right = "left", + scale$position + ) + ggproto(NULL, ViewScale, scale = scale, + guide = scale$secondary.axis$guide, + position = position, break_info = break_info, - aesthetics = paste0(scale$aesthetics, ".sec"), + # as far as scales are concerned, this is a regular scale with + # different breaks and labels in a different data space + aesthetics = scale$aesthetics, name = scale$sec_name(), make_title = function(self, title) self$scale$make_sec_title(title), @@ -60,7 +81,7 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), get_breaks_minor = function(self) self$break_info$minor_source, break_positions = function(self) self$break_info$major, break_positions_minor = function(self) self$break_info$minor, - get_labels = function(self) self$break_info$labels, + get_labels = function(self, breaks = self$get_breaks()) self$break_info$labels, rescale = function(x) rescale(x, from = break_info$range, to = c(0, 1)) ) } @@ -74,7 +95,7 @@ view_scale_empty <- function() { get_limits = function() c(0, 1), get_breaks = function() NULL, get_breaks_minor = function() NULL, - get_labels = function() NULL, + get_labels = function(breaks = NULL) breaks, rescale = function(x) stop("Not implemented", call. = FALSE), map = function(x) stop("Not implemented", call. = FALSE), make_title = function(title) title, @@ -87,13 +108,14 @@ ViewScale <- ggproto("ViewScale", NULL, # map, rescale, and make_title need a reference # to the original scale scale = ggproto(NULL, Scale), + guide = guide_none(), + position = NULL, aesthetics = NULL, name = waiver(), scale_is_discrete = FALSE, limits = NULL, continuous_range = NULL, breaks = NULL, - labels = NULL, minor_breaks = NULL, is_empty = function(self) { @@ -104,12 +126,16 @@ ViewScale <- ggproto("ViewScale", NULL, get_limits = function(self) self$limits, get_breaks = function(self) self$breaks, get_breaks_minor = function(self) self$minor_breaks, - get_labels = function(self) self$labels, + get_labels = function(self, breaks = self$get_breaks()) self$scale$get_labels(breaks), rescale = function(self, x) { self$scale$rescale(x, self$limits, self$continuous_range) }, map = function(self, x) { - self$scale$map(x, self$limits) + if (self$is_discrete()) { + self$scale$map(x, self$limits) + } else { + self$scale$map(x, self$continuous_range) + } }, make_title = function(self, title) { self$scale$make_title(title) diff --git a/man/guide-exts.Rd b/man/guide-exts.Rd index 8d4fb270f4..17c1591cb6 100644 --- a/man/guide-exts.Rd +++ b/man/guide-exts.Rd @@ -5,6 +5,7 @@ \alias{guide_train} \alias{guide_merge} \alias{guide_geom} +\alias{guide_transform} \alias{guide_gengrob} \title{S3 generics for guides.} \usage{ @@ -14,6 +15,8 @@ guide_merge(guide, new_guide) guide_geom(guide, layers, default_mapping) +guide_transform(guide, coord, panel_params) + guide_gengrob(guide, theme) } \arguments{ diff --git a/man/guide_axis.Rd b/man/guide_axis.Rd new file mode 100644 index 0000000000..dbd206aaa5 --- /dev/null +++ b/man/guide_axis.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guides-axis.r +\name{guide_axis} +\alias{guide_axis} +\title{Axis guide} +\usage{ +guide_axis(title = waiver(), check.overlap = FALSE, angle = NULL, + n.dodge = 1, order = 0, position = waiver()) +} +\arguments{ +\item{title}{A character string or expression indicating a title of guide. +If \code{NULL}, the title is not shown. By default +(\code{\link[=waiver]{waiver()}}), the name of the scale object or the name +specified in \code{\link[=labs]{labs()}} is used for the title.} + +\item{check.overlap}{silently remove overlapping labels, +(recursively) prioritizing the first, last, and middle labels.} + +\item{angle}{Compared to setting the angle in \code{\link[=theme]{theme()}} / \code{\link[=element_text]{element_text()}}, +this also uses some heuristics to automatically pick the \code{hjust} and \code{vjust} that +you probably want.} + +\item{n.dodge}{The number of rows (for vertical axes) or columns (for +horizontal axes) that should be used to render the labels. This is +useful for displaying labels that would otherwise overlap.} + +\item{order}{Used to determine the order of the guides (left-to-right, +top-to-bottom), if more than one guide must be drawn at the same location.} + +\item{position}{Where this guide should be drawn: one of top, bottom, +left, or right.} +} +\description{ +Axis guides are the visual representation of position scales like those +created with \link[=scale_x_continuous]{scale_(x|y)_continuous()} and +\link[=scale_x_discrete]{scale_(x|y)_discrete()}. +} +\examples{ +# plot with overlapping text +p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + + geom_point() + + facet_wrap(vars(class)) + +# axis guides can be customized in the scale_* functions or +# using guides() +p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) +p + guides(x = guide_axis(angle = 90)) + +# can also be used to add a duplicate guide +p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) + + +} diff --git a/man/guide_none.Rd b/man/guide_none.Rd new file mode 100644 index 0000000000..514784d7c9 --- /dev/null +++ b/man/guide_none.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guides-none.r +\name{guide_none} +\alias{guide_none} +\title{Empty guide} +\usage{ +guide_none(title = waiver(), position = waiver()) +} +\arguments{ +\item{title}{A character string or expression indicating a title of guide. +If \code{NULL}, the title is not shown. By default +(\code{\link[=waiver]{waiver()}}), the name of the scale object or the name +specified in \code{\link[=labs]{labs()}} is used for the title.} + +\item{position}{Where this guide should be drawn: one of top, bottom, +left, or right.} +} +\description{ +This guide draws nothing. +} diff --git a/man/scale_continuous.Rd b/man/scale_continuous.Rd index d904a781fe..925196344c 100644 --- a/man/scale_continuous.Rd +++ b/man/scale_continuous.Rd @@ -14,12 +14,14 @@ scale_x_continuous(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, na.value = NA_real_, - trans = "identity", position = "bottom", sec.axis = waiver()) + trans = "identity", guide = waiver(), position = "bottom", + sec.axis = waiver()) scale_y_continuous(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, na.value = NA_real_, - trans = "identity", position = "left", sec.axis = waiver()) + trans = "identity", guide = waiver(), position = "left", + sec.axis = waiver()) scale_x_log10(...) @@ -111,6 +113,9 @@ are defined in the scales package, and are called \code{_trans} (e.g., \code{\link[scales:boxcox_trans]{scales::boxcox_trans()}}). You can create your own transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.} +\item{guide}{A function used to create a guide or its name. See +\code{\link[=guides]{guides()}} for more information.} + \item{position}{For position scales, The position of the axis. \code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} diff --git a/man/scale_date.Rd b/man/scale_date.Rd index 3b9e123d5a..444a4cacd2 100644 --- a/man/scale_date.Rd +++ b/man/scale_date.Rd @@ -12,36 +12,36 @@ scale_x_date(name = waiver(), breaks = waiver(), date_breaks = waiver(), labels = waiver(), date_labels = waiver(), minor_breaks = waiver(), date_minor_breaks = waiver(), - limits = NULL, expand = waiver(), position = "bottom", - sec.axis = waiver()) + limits = NULL, expand = waiver(), guide = waiver(), + position = "bottom", sec.axis = waiver()) scale_y_date(name = waiver(), breaks = waiver(), date_breaks = waiver(), labels = waiver(), date_labels = waiver(), minor_breaks = waiver(), date_minor_breaks = waiver(), - limits = NULL, expand = waiver(), position = "left", - sec.axis = waiver()) + limits = NULL, expand = waiver(), guide = waiver(), + position = "left", sec.axis = waiver()) scale_x_datetime(name = waiver(), breaks = waiver(), date_breaks = waiver(), labels = waiver(), date_labels = waiver(), minor_breaks = waiver(), date_minor_breaks = waiver(), timezone = NULL, limits = NULL, expand = waiver(), - position = "bottom", sec.axis = waiver()) + guide = waiver(), position = "bottom", sec.axis = waiver()) scale_y_datetime(name = waiver(), breaks = waiver(), date_breaks = waiver(), labels = waiver(), date_labels = waiver(), minor_breaks = waiver(), date_minor_breaks = waiver(), timezone = NULL, limits = NULL, expand = waiver(), - position = "left", sec.axis = waiver()) + guide = waiver(), position = "left", sec.axis = waiver()) scale_x_time(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, na.value = NA_real_, - position = "bottom", sec.axis = waiver()) + guide = waiver(), position = "bottom", sec.axis = waiver()) scale_y_time(name = waiver(), breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), oob = censor, na.value = NA_real_, - position = "left", sec.axis = waiver()) + guide = waiver(), position = "left", sec.axis = waiver()) } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -107,6 +107,9 @@ to generate the values for the \code{expand} argument. The defaults are to expand the scale by 5\% on each side for continuous variables, and by 0.6 units on each side for discrete variables.} +\item{guide}{A function used to create a guide or its name. See +\code{\link[=guides]{guides()}} for more information.} + \item{position}{For position scales, The position of the axis. \code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} diff --git a/man/scale_discrete.Rd b/man/scale_discrete.Rd index b0f730cae2..cd73d626b1 100644 --- a/man/scale_discrete.Rd +++ b/man/scale_discrete.Rd @@ -5,9 +5,11 @@ \alias{scale_y_discrete} \title{Position scales for discrete data} \usage{ -scale_x_discrete(..., expand = waiver(), position = "bottom") +scale_x_discrete(..., expand = waiver(), guide = waiver(), + position = "bottom") -scale_y_discrete(..., expand = waiver(), position = "left") +scale_y_discrete(..., expand = waiver(), guide = waiver(), + position = "left") } \arguments{ \item{...}{Arguments passed on to \code{discrete_scale} @@ -70,6 +72,9 @@ to generate the values for the \code{expand} argument. The defaults are to expand the scale by 5\% on each side for continuous variables, and by 0.6 units on each side for discrete variables.} +\item{guide}{A function used to create a guide or its name. See +\code{\link[=guides]{guides()}} for more information.} + \item{position}{For position scales, The position of the axis. \code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} } diff --git a/man/sec_axis.Rd b/man/sec_axis.Rd index f89a90c216..b57d45aaa7 100644 --- a/man/sec_axis.Rd +++ b/man/sec_axis.Rd @@ -7,10 +7,10 @@ \title{Specify a secondary axis} \usage{ sec_axis(trans = NULL, name = waiver(), breaks = waiver(), - labels = waiver()) + labels = waiver(), guide = waiver()) dup_axis(trans = ~., name = derive(), breaks = derive(), - labels = derive()) + labels = derive(), guide = derive()) derive() } @@ -34,6 +34,9 @@ derive() \item A character vector giving labels (must be same length as \code{breaks}) \item A function that takes the breaks as input and returns labels as output }} + +\item{guide}{A position guide that will be used to render +the axis on the plot. Usually this is \code{\link[=guide_axis]{guide_axis()}}.} } \description{ This function is used in conjunction with a position scale to create a diff --git a/tests/figs/guides/guide-axis-customization.svg b/tests/figs/guides/guide-axis-customization.svg new file mode 100644 index 0000000000..a242c3b6a2 --- /dev/null +++ b/tests/figs/guides/guide-axis-customization.svg @@ -0,0 +1,292 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +30 +20 +40 + + + + + + +20 +40 +30 + + + + + + + +2seater +midsize +pickup +suv +compact +minivan +subcompact +class +hwy +hwy +guide_axis() customization + diff --git a/tests/figs/guides/guides-specified-in-guides.svg b/tests/figs/guides/guides-specified-in-guides.svg new file mode 100644 index 0000000000..9d3274dabb --- /dev/null +++ b/tests/figs/guides/guides-specified-in-guides.svg @@ -0,0 +1,305 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +compact +minivan +subcompact +2seater +midsize +pickup +suv + + + + + + + +30 +20 +40 + + + + + + +20 +40 +30 + + + + + + + +2seater +midsize +pickup +suv +compact +minivan +subcompact +class +hwy +guides specified in guides() + diff --git a/tests/figs/guides/position-guide-titles.svg b/tests/figs/guides/position-guide-titles.svg new file mode 100644 index 0000000000..69f3b2e748 --- /dev/null +++ b/tests/figs/guides/position-guide-titles.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +x (secondary) +x (primary) +y (primary) +y (secondary) +position guide titles + diff --git a/tests/figs/sec-axis/sec-axis-custom-transform.svg b/tests/figs/sec-axis/sec-axis-custom-transform.svg index 9635517c6a..0dbe8af171 100644 --- a/tests/figs/sec-axis/sec-axis-custom-transform.svg +++ b/tests/figs/sec-axis/sec-axis-custom-transform.svg @@ -70,24 +70,24 @@ - - - - - - - - - -0.001 -0.010 -0.100 -0.250 -0.300 -0.350 -0.400 -0.450 -0.500 + + + + + + + + + +0.001 +0.010 +0.100 +0.250 +0.300 +0.350 +0.400 +0.450 +0.500 diff --git a/tests/figs/sec-axis/sec-axis-independent-transformations.svg b/tests/figs/sec-axis/sec-axis-independent-transformations.svg index e9fa100779..3e3764dffe 100644 --- a/tests/figs/sec-axis/sec-axis-independent-transformations.svg +++ b/tests/figs/sec-axis/sec-axis-independent-transformations.svg @@ -46,15 +46,15 @@ -5 -10 -15 -20 +5 +10 +15 +20 25 - - - - + + + + 0.2 0.3 diff --git a/tests/figs/sec-axis/sec-axis-monotonicity-test.svg b/tests/figs/sec-axis/sec-axis-monotonicity-test.svg index 09da192d8a..cd76b3c44e 100644 --- a/tests/figs/sec-axis/sec-axis-monotonicity-test.svg +++ b/tests/figs/sec-axis/sec-axis-monotonicity-test.svg @@ -52,14 +52,14 @@ - - - - -1 -2 -3 -4 + + + + +1 +2 +3 +4 diff --git a/tests/figs/sec-axis/sec-axis-sec-power-transform.svg b/tests/figs/sec-axis/sec-axis-sec-power-transform.svg index 7451419cde..19517dabc6 100644 --- a/tests/figs/sec-axis/sec-axis-sec-power-transform.svg +++ b/tests/figs/sec-axis/sec-axis-sec-power-transform.svg @@ -53,17 +53,17 @@ -0.25 -0.00 -0.25 -0.50 -0.75 -1.00 +0.00 +0.25 +0.50 +0.75 +1.00 - - - - - + + + + + 4.950 4.975 5.000 diff --git a/tests/figs/sec-axis/sec-axis-skewed-transform.svg b/tests/figs/sec-axis/sec-axis-skewed-transform.svg index 4e5e2630ec..c5b429b83a 100644 --- a/tests/figs/sec-axis/sec-axis-skewed-transform.svg +++ b/tests/figs/sec-axis/sec-axis-skewed-transform.svg @@ -147,16 +147,16 @@ -1e-01 -1e+00 -1e+01 -1e+02 -1e+03 - - - - - +1e-01 +1e+00 +1e+01 +1e+02 +1e+03 + + + + + 0.00 0.25 0.50 diff --git a/tests/figs/sec-axis/sec-axis-with-division.svg b/tests/figs/sec-axis/sec-axis-with-division.svg index a7dc81bcff..364b556ead 100644 --- a/tests/figs/sec-axis/sec-axis-with-division.svg +++ b/tests/figs/sec-axis/sec-axis-with-division.svg @@ -284,12 +284,12 @@ - - - -10 -15 -20 + + + +10 +15 +20 diff --git a/tests/figs/themes/axes-styling.svg b/tests/figs/themes/axes-styling.svg index e16319a8e5..b0ae37c5cc 100644 --- a/tests/figs/themes/axes-styling.svg +++ b/tests/figs/themes/axes-styling.svg @@ -51,14 +51,14 @@ -2.5 -5.0 -7.5 -10.0 - - - - +2.5 +5.0 +7.5 +10.0 + + + + 2.5 5.0 @@ -69,14 +69,14 @@ - - - - -2.5 -5.0 -7.5 -10.0 + + + + +2.5 +5.0 +7.5 +10.0 diff --git a/tests/figs/themes/ticks-length.svg b/tests/figs/themes/ticks-length.svg index 58e713674f..99e8d21ff9 100644 --- a/tests/figs/themes/ticks-length.svg +++ b/tests/figs/themes/ticks-length.svg @@ -35,14 +35,14 @@ -2.5 -5.0 -7.5 -10.0 - - - - +2.5 +5.0 +7.5 +10.0 + + + + 2.5 5.0 7.5 @@ -51,14 +51,14 @@ - - - - -2.5 -5.0 -7.5 -10.0 + + + + +2.5 +5.0 +7.5 +10.0 diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 6ef54fcaf5..0fa2b90a91 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -65,6 +65,54 @@ test_that("axis_label_element_overrides errors when angles are outside the range expect_error(axis_label_element_overrides("bottom", -91), "`angle` must") }) +test_that("a warning is generated when guides are drawn at a location that doesn't make sense", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + scale_y_continuous(guide = guide_axis(position = "top")) + built <- expect_silent(ggplot_build(plot)) + expect_warning(ggplot_gtable(built), "Position guide is perpendicular") +}) + +test_that("a warning is generated when more than one position guide is drawn at a location", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + guides( + y = guide_axis(position = "left"), + y.sec = guide_axis(position = "left") + ) + built <- expect_silent(ggplot_build(plot)) + expect_warning(ggplot_gtable(built), "Discarding guide") +}) + +test_that("guide_none() can be used in non-position scales", { + p <- ggplot(mpg, aes(cty, hwy, colour = class)) + + geom_point() + + scale_color_discrete(guide = guide_none()) + + built <- ggplot_build(p) + plot <- built$plot + guides <- build_guides( + plot$scales, + plot$layers, + plot$mapping, + "right", + theme_gray(), + plot$guides, + plot$labels + ) + + expect_identical(guides, zeroGrob()) +}) + +test_that("Using non-position guides for position scales results in an informative error", { + p <- ggplot(mpg, aes(cty, hwy)) + + geom_point() + + scale_x_continuous(guide = guide_legend()) + + built <- ggplot_build(p) + expect_error(ggplot_gtable(built), "does not implement guide_transform()") +}) + # Visual tests ------------------------------------------------------------ test_that("axis guides are drawn correctly", { @@ -132,7 +180,7 @@ test_that("axis guides are drawn correctly", { # dodged text expect_doppelganger( "axis guides, text dodged into rows/cols", - function() test_draw_axis(10, labels = function(b) comma(b * 1e9), n_dodge = 2) + function() test_draw_axis(10, labels = function(b) comma(b * 1e9), n.dodge = 2) ) }) @@ -156,6 +204,45 @@ test_that("axis guides are drawn correctly in plots", { ) }) +test_that("axis guides can be customized", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + scale_y_continuous( + sec.axis = dup_axis(guide = guide_axis(n.dodge = 2)), + guide = guide_axis(n.dodge = 2) + ) + + scale_x_discrete(guide = guide_axis(n.dodge = 2)) + + expect_doppelganger("guide_axis() customization", plot) +}) + +test_that("guides can be specified in guides()", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + guides( + x = guide_axis(n.dodge = 2), + y = guide_axis(n.dodge = 2), + x.sec = guide_axis(n.dodge = 2), + y.sec = guide_axis(n.dodge = 2) + ) + + expect_doppelganger("guides specified in guides()", plot) +}) + +test_that("guides have the final say in x and y", { + df <- data_frame(x = 1, y = 1) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + guides( + x = guide_none(title = "x (primary)"), + y = guide_none(title = "y (primary)"), + x.sec = guide_none(title = "x (secondary)"), + y.sec = guide_none(title = "y (secondary)") + ) + + expect_doppelganger("position guide titles", plot) +}) + test_that("guides are positioned correctly", { df <- data_frame(x = 1, y = 1, z = factor("a")) From 0ee259ccbbe9866ad9cc618d66eb452d870cacd6 Mon Sep 17 00:00:00 2001 From: bernie gray Date: Mon, 30 Sep 2019 06:54:57 -0400 Subject: [PATCH 038/125] default formula argument to NULL in geom_smooth() (#3307) --- R/geom-smooth.r | 4 +-- R/stat-smooth.r | 45 +++++++++++++++++++++---------- man/geom_smooth.Rd | 20 ++++++++------ tests/testthat/test-geom-smooth.R | 9 +++++++ 4 files changed, 54 insertions(+), 24 deletions(-) diff --git a/R/geom-smooth.r b/R/geom-smooth.r index 6c10e98ba5..a4e224450f 100644 --- a/R/geom-smooth.r +++ b/R/geom-smooth.r @@ -78,8 +78,8 @@ geom_smooth <- function(mapping = NULL, data = NULL, stat = "smooth", position = "identity", ..., - method = "auto", - formula = y ~ x, + method = NULL, + formula = NULL, se = TRUE, na.rm = FALSE, show.legend = NA, diff --git a/R/stat-smooth.r b/R/stat-smooth.r index 86e2e9dcab..a1cc84d762 100644 --- a/R/stat-smooth.r +++ b/R/stat-smooth.r @@ -1,8 +1,10 @@ -#' @param method Smoothing method (function) to use, accepts either a character vector, -#' e.g. `"auto"`, `"lm"`, `"glm"`, `"gam"`, `"loess"` or a function, e.g. -#' `MASS::rlm` or `mgcv::gam`, `stats::lm`, or `stats::loess`. +#' @param method Smoothing method (function) to use, accepts either +#' `NULL` or a character vector, e.g. `"lm"`, `"glm"`, `"gam"`, `"loess"` +#' or a function, e.g. `MASS::rlm` or `mgcv::gam`, `stats::lm`, or `stats::loess`. +#' `"auto"` is also accepted for backwards compatibility. It is equivalent to +#' `NULL`. #' -#' For `method = "auto"` the smoothing method is chosen based on the +#' For `method = NULL` the smoothing method is chosen based on the #' size of the largest group (across all panels). [stats::loess()] is #' used for less than 1,000 observations; otherwise [mgcv::gam()] is #' used with `formula = y ~ s(x, bs = "cs")` with `method = "REML"`. Somewhat anecdotally, @@ -10,10 +12,12 @@ #' so does not work for larger datasets. #' #' If you have fewer than 1,000 observations but want to use the same `gam()` -#' model that `method = "auto"` would use, then set +#' model that `method = NULL` would use, then set #' `method = "gam", formula = y ~ s(x, bs = "cs")`. #' @param formula Formula to use in smoothing function, eg. `y ~ x`, -#' `y ~ poly(x, 2)`, `y ~ log(x)` +#' `y ~ poly(x, 2)`, `y ~ log(x)`. `NULL` by default, in which case +#' `method = NULL` implies `formula = y ~ x` when there are fewer than 1,000 +#' observations and `formula = y ~ s(x, bs = "cs")` otherwise. #' @param se Display confidence interval around smooth? (`TRUE` by default, see #' `level` to control.) #' @param fullrange Should the fit span the full range of the plot, or just @@ -37,8 +41,8 @@ stat_smooth <- function(mapping = NULL, data = NULL, geom = "smooth", position = "identity", ..., - method = "auto", - formula = y ~ x, + method = NULL, + formula = NULL, se = TRUE, n = 80, span = 0.75, @@ -77,7 +81,8 @@ stat_smooth <- function(mapping = NULL, data = NULL, #' @export StatSmooth <- ggproto("StatSmooth", Stat, setup_params = function(data, params) { - if (identical(params$method, "auto")) { + msg <- character() + if (is.null(params$method) || identical(params$method, "auto")) { # Use loess for small datasets, gam with a cubic regression basis for # larger. Based on size of the _largest_ group to avoid bad memory # behaviour of loess @@ -87,18 +92,30 @@ StatSmooth <- ggproto("StatSmooth", Stat, params$method <- "loess" } else { params$method <- "gam" + } + msg <- c(msg, paste0("method = '", params$method, "'")) + } + + if (is.null(params$formula)) { + if (identical(params$method, "gam")) { params$formula <- y ~ s(x, bs = "cs") + } else { + params$formula <- y ~ x } - message( - "`geom_smooth()` using method = '", params$method, - "' and formula '", deparse(params$formula), "'" - ) + msg <- c(msg, paste0("formula '", deparse(params$formula), "'")) + } + if (identical(params$method, "gam")) { + params$method <- mgcv::gam + } + + if (length(msg) > 0) { + message("`geom_smooth()` using ", paste0(msg, collapse = " and ")) } params }, - compute_group = function(data, scales, method = "auto", formula = y ~ x, + compute_group = function(data, scales, method = NULL, formula = NULL, se = TRUE, n = 80, span = 0.75, fullrange = FALSE, xseq = NULL, level = 0.95, method.args = list(), na.rm = FALSE) { diff --git a/man/geom_smooth.Rd b/man/geom_smooth.Rd index c29a0fa0d0..540207b2db 100644 --- a/man/geom_smooth.Rd +++ b/man/geom_smooth.Rd @@ -6,11 +6,11 @@ \title{Smoothed conditional means} \usage{ geom_smooth(mapping = NULL, data = NULL, stat = "smooth", - position = "identity", ..., method = "auto", formula = y ~ x, + position = "identity", ..., method = NULL, formula = NULL, se = TRUE, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) stat_smooth(mapping = NULL, data = NULL, geom = "smooth", - position = "identity", ..., method = "auto", formula = y ~ x, + position = "identity", ..., method = NULL, formula = NULL, se = TRUE, n = 80, span = 0.75, fullrange = FALSE, level = 0.95, method.args = list(), na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) @@ -44,11 +44,13 @@ often aesthetics, used to set an aesthetic to a fixed value, like \code{colour = "red"} or \code{size = 3}. They may also be parameters to the paired geom/stat.} -\item{method}{Smoothing method (function) to use, accepts either a character vector, -e.g. \code{"auto"}, \code{"lm"}, \code{"glm"}, \code{"gam"}, \code{"loess"} or a function, e.g. -\code{MASS::rlm} or \code{mgcv::gam}, \code{stats::lm}, or \code{stats::loess}. +\item{method}{Smoothing method (function) to use, accepts either +\code{NULL} or a character vector, e.g. \code{"lm"}, \code{"glm"}, \code{"gam"}, \code{"loess"} +or a function, e.g. \code{MASS::rlm} or \code{mgcv::gam}, \code{stats::lm}, or \code{stats::loess}. +\code{"auto"} is also accepted for backwards compatibility. It is equivalent to +\code{NULL}. -For \code{method = "auto"} the smoothing method is chosen based on the +For \code{method = NULL} the smoothing method is chosen based on the size of the largest group (across all panels). \code{\link[stats:loess]{stats::loess()}} is used for less than 1,000 observations; otherwise \code{\link[mgcv:gam]{mgcv::gam()}} is used with \code{formula = y ~ s(x, bs = "cs")} with \code{method = "REML"}. Somewhat anecdotally, @@ -56,11 +58,13 @@ used with \code{formula = y ~ s(x, bs = "cs")} with \code{method = "REML"}. Some so does not work for larger datasets. If you have fewer than 1,000 observations but want to use the same \code{gam()} -model that \code{method = "auto"} would use, then set +model that \code{method = NULL} would use, then set \code{method = "gam", formula = y ~ s(x, bs = "cs")}.} \item{formula}{Formula to use in smoothing function, eg. \code{y ~ x}, -\code{y ~ poly(x, 2)}, \code{y ~ log(x)}} +\code{y ~ poly(x, 2)}, \code{y ~ log(x)}. \code{NULL} by default, in which case +\code{method = NULL} implies \code{formula = y ~ x} when there are fewer than 1,000 +observations and \code{formula = y ~ s(x, bs = "cs")} otherwise.} \item{se}{Display confidence interval around smooth? (\code{TRUE} by default, see \code{level} to control.)} diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index 0c378eae31..e84f8dae6a 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -48,6 +48,15 @@ test_that("default smoothing methods for small and large data sets work", { "method = 'gam' and formula 'y ~ s\\(x, bs = \"cs\"\\)" ) expect_equal(plot_data$y, as.numeric(out)) + + # backwards compatibility of method = "auto" + p <- ggplot(df, aes(x, y)) + geom_smooth(method = "auto") + + expect_message( + plot_data <- layer_data(p), + "method = 'gam' and formula 'y ~ s\\(x, bs = \"cs\"\\)" + ) + expect_equal(plot_data$y, as.numeric(out)) }) From bde684484f01a2927ef64abdbbf06628ca39b03e Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 30 Sep 2019 14:06:24 +0200 Subject: [PATCH 039/125] Use tsbox for converting ts object to tibble --- DESCRIPTION | 2 +- R/position-nudgestack.R | 15 +- man/position_nudgestack.Rd | 15 +- .../nudgestack-eustockmarkets-data.svg | 302 +++++++++--------- tests/testthat/test-position-nudgestack.R | 23 +- 5 files changed, 171 insertions(+), 186 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index cb2bfb7169..211906ed0b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,7 +56,7 @@ Suggests: svglite (>= 1.2.0.9001), testthat (>= 2.1.0), vdiffr (>= 0.3.0), - zoo + tsbox Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a031937593..51a3de3587 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,20 +13,15 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' ESM <- data.frame( -#' as.matrix(EuStockMarkets), -#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), -#' format = "%d %b %Y" -#' ) -#' ) +#' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' tidyr::gather(key = key, value = value, -date) %>% -#' group_by(date, key) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' group_by(id, time) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date < "1998-01-01") +#' filter(time >= "1995-01-01" & time < "1998-01-01") #' -#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 7efb57a035..5d6a382bd3 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,20 +22,15 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -ESM <- data.frame( - as.matrix(EuStockMarkets), - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "\%d \%b \%Y" - ) -) +ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - tidyr::gather(key = key, value = value, -date) \%>\% - group_by(date, key) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date < "1998-01-01") + filter(time >= "1995-01-01" & time < "1998-01-01") -ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) } \seealso{ diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg index fc0ed6d9a6..326eed0610 100644 --- a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -19,150 +19,150 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -170,11 +170,13 @@ 0 -10000 -20000 +5000 +10000 +15000 - - + + + @@ -183,10 +185,10 @@ 1996 1997 1998 -date +time value -key +id diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index f3532c9686..29964c5dfb 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,23 +1,16 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- data_frame( - DAX = EuStockMarkets[,"DAX"], - SMI = EuStockMarkets[,"SMI"], - CAC = EuStockMarkets[,"CAC"], - FTSE = EuStockMarkets[,"FTSE"], - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "%d %b %Y" - ) - ) + + ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - tidyr::gather(key = key, value = value, -date) %>% - group_by(date, key) %>% - summarize(value = mean(value)) %>% - filter(date >= "1995-01-01" & date < "1998-01-01") + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::group_by(id, time) %>% + dplyr::summarize(value = mean(value)) %>% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -51,7 +44,7 @@ test_that("nudging works for discrete values correctly", { set.seed(111) # x nudge value for discrete data - series <- data.frame( + series <- data_frame( time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), type = rep(c('a', 'b', 'c', 'd'), 4), value = rpois(16, 10) From a290bb3ae448798c1ffdf858b7c437d2bd4eacf8 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:09:06 +0200 Subject: [PATCH 040/125] Add position_nudgestack --- R/position-nudgestack.R | 117 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 R/position-nudgestack.R diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R new file mode 100644 index 0000000000..f978593441 --- /dev/null +++ b/R/position-nudgestack.R @@ -0,0 +1,117 @@ +#' Simultaneously nudge and stack +#' +#' This is primarily used for set stacked columns between the ticks on the +#' x-axis. +#' +#' @family position adjustments +#' @param x,y Amount of vertical and horizontal distance to move. +#' @param vjust Vertical adjustment for geoms that have a position +#' (like points or lines), not a dimension (like bars or areas). Set to +#' `0` to align with the bottom, `0.5` for the middle, +#' and `1` (the default) for the top. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. +#' @export +#' @examples +#' data <- mtcars +#' ggplot() + +#' geom_col( +#' data, +#' aes(x = cyl, y = gear, fill = gear), +#' position = position_nudgestack(x = 1) +#' ) +position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { + ggproto(NULL, PositionNudgeStack, + x = x, + y = y, + vjust = vjust, + reverse = reverse + ) +} + + + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionNudgeStack <- ggproto("PositionNudgeStack", Position, + x = 0, + y = 0, + type = NULL, + vjust = 1, + fill = FALSE, + reverse = FALSE, + + setup_params = function(self, data) { + list( + x = self$x, + y = self$y, + var = if (!is.null(self$var)) self$var else stack_var(data), + fill = self$fill, + vjust = self$vjust, + reverse = self$reverse + ) + }, + + setup_data = function(self, data, params) { + if (is.null(params$var)) { + return(data) + } + + data$ymax <- switch(params$var, + y = data$y, + ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) + ) + + remove_missing( + data, + vars = c("x", "xmin", "xmax", "y"), + name = "position_stack" + ) + }, + + compute_layer = function(self, data, params, layout) { + if (is.null(params$var)) { + return(data) + } + + negative <- data$ymax < 0 + negative[is.na(negative)] <- FALSE + + neg <- data[negative, , drop = FALSE] + pos <- data[!negative, , drop = FALSE] + + if (any(negative)) { + neg <- collide(neg, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + if (any(!negative)) { + pos <- collide(pos, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] + + + + # transform only the dimensions for which non-zero nudging is requested + if (any(params$x != 0)) { + if (any(params$y != 0)) { + transform_position(data, function(x) x + params$x, function(y) y + params$y) + } else { + transform_position(data, function(x) x + params$x, NULL) + } + } else if (any(params$y != 0)) { + transform_position(data, NULL, function(y) y + params$y) + } else { + data # if both x and y are 0 we don't need to transform + } + } +) From c8fa99fd5de5a1c7ddc5eb52900b23d33243c595 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:26:32 +0200 Subject: [PATCH 041/125] Delete emtpy rows --- R/position-nudgestack.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index f978593441..60e67169dd 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -29,8 +29,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ) } - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -99,8 +97,6 @@ PositionNudgeStack <- ggproto("PositionNudgeStack", Position, data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] - - # transform only the dimensions for which non-zero nudging is requested if (any(params$x != 0)) { if (any(params$y != 0)) { From 4535be621298965cb1ba331ba52f4f39337768ab Mon Sep 17 00:00:00 2001 From: Mara Alexeev <39673697+MaraAlexeev@users.noreply.github.com> Date: Tue, 3 Sep 2019 08:26:07 -0400 Subject: [PATCH 042/125] Clarify documentation in mpg: very minor (#3515) * add helpful explanation of mpg$drv --- R/data.R | 2 +- man/mpg.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/data.R b/R/data.R index 909c639b93..aee286cc57 100644 --- a/R/data.R +++ b/R/data.R @@ -100,7 +100,7 @@ #' \item{year}{year of manufacture} #' \item{cyl}{number of cylinders} #' \item{trans}{type of transmission} -#' \item{drv}{f = front-wheel drive, r = rear wheel drive, 4 = 4wd} +#' \item{drv}{the type of drive train, where f = front-wheel drive, r = rear wheel drive, 4 = 4wd} #' \item{cty}{city miles per gallon} #' \item{hwy}{highway miles per gallon} #' \item{fl}{fuel type} diff --git a/man/mpg.Rd b/man/mpg.Rd index 598a59979f..63b4f8ca44 100644 --- a/man/mpg.Rd +++ b/man/mpg.Rd @@ -12,7 +12,7 @@ \item{year}{year of manufacture} \item{cyl}{number of cylinders} \item{trans}{type of transmission} -\item{drv}{f = front-wheel drive, r = rear wheel drive, 4 = 4wd} +\item{drv}{the type of drive train, where f = front-wheel drive, r = rear wheel drive, 4 = 4wd} \item{cty}{city miles per gallon} \item{hwy}{highway miles per gallon} \item{fl}{fuel type} From 56e9b3b8aead1bf345e6dfb9d32b634891366d8a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 043/125] Add time series example --- R/position-nudgestack.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 60e67169dd..a2837ba90e 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,13 +13,23 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' data <- mtcars -#' ggplot() + -#' geom_col( -#' data, -#' aes(x = cyl, y = gear, fill = gear), -#' position = position_nudgestack(x = 1) +#' library(dplyr) +#' library(ggplot2) +#' ESM <- data.frame( +#' as.matrix(EuStockMarkets), +#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), +#' format = "%d %b %Y" #' ) +#' ) +#' +#' ESM_prep <- ESM %>% +#' tidyr::gather(key = key, value = value, -date) %>% +#' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' +#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, x = x, @@ -36,7 +46,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 9d894a86b0ec5458d2aedd5d12cbaaa7562ade4c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:56:35 +0200 Subject: [PATCH 044/125] Add new position to DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 95cb820686..db8d7cc03d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -179,6 +179,7 @@ Collate: 'position-jitter.r' 'position-jitterdodge.R' 'position-nudge.R' + 'position-nudgestack.R' 'position-stack.r' 'quick-plot.r' 'range.r' From 7fbc0f77cb19531c502eb539e63e625d13c2dacf Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:58:38 +0200 Subject: [PATCH 045/125] Add new position_nudgestack into NAMESPACE --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3670510528..a5d486488b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -188,6 +188,7 @@ export(PositionIdentity) export(PositionJitter) export(PositionJitterdodge) export(PositionNudge) +export(PositionNudgeStack) export(PositionStack) export(Scale) export(ScaleContinuous) @@ -405,6 +406,7 @@ export(position_identity) export(position_jitter) export(position_jitterdodge) export(position_nudge) +export(position_nudgestack) export(position_stack) export(qplot) export(quickplot) From c97d54da79b09cc6611817d17bccf6e9db02c281 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 046/125] Add position-nudgestack.R into man --- man/ggplot2-ggproto.Rd | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index df35148ece..e52deb35fc 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -14,15 +14,15 @@ % R/geom-spoke.r, R/geom-text.r, R/geom-tile.r, R/geom-violin.r, % R/geom-vline.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-continuous.r, R/scale-date.r, R/scale-discrete-.r, -% R/scale-identity.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-qq-line.R, R/stat-qq.r, -% R/stat-quantile.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/position-jitterdodge.R, R/position-nudge.R, R/position-nudgestack.R, +% R/position-stack.r, R/scale-.r, R/scale-continuous.r, R/scale-date.r, +% R/scale-discrete-.r, R/scale-identity.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-qq-line.R, +% R/stat-qq.r, R/stat-quantile.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} @@ -90,6 +90,7 @@ \alias{PositionJitter} \alias{PositionJitterdodge} \alias{PositionNudge} +\alias{PositionNudgeStack} \alias{PositionStack} \alias{PositionFill} \alias{Scale} From 327a6cd0ebad38a853d7ae81634b96f78d5f6ce8 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:13 +0200 Subject: [PATCH 047/125] Add position_nudgestack into description --- man/position_dodge.Rd | 1 + man/position_identity.Rd | 1 + man/position_jitter.Rd | 1 + man/position_jitterdodge.Rd | 1 + man/position_nudge.Rd | 1 + man/position_stack.Rd | 1 + 6 files changed, 6 insertions(+) diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index a35191e4fa..cef3386d86 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -96,6 +96,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + Other position adjustments: \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 440e575682..994bd2952e 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -13,6 +13,7 @@ Don't adjust position Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index 16548f6496..37b6df322c 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -58,6 +58,7 @@ ggplot(mtcars, aes(am, vs)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index f543bb332a..ff6e5f05b9 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -40,6 +40,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index aaf735e236..9597692160 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -39,6 +39,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_stack}} } \concept{position adjustments} diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 39ea363603..991aed9c2c 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -144,6 +144,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}} } \concept{position adjustments} From f587fb8af7121f5dcfeb73b9c14c4a94fc1db302 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:01:48 +0200 Subject: [PATCH 048/125] Add description of position_nudgestack --- man/position_nudgestack.Rd | 41 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 man/position_nudgestack.Rd diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd new file mode 100644 index 0000000000..e23e8d4ca3 --- /dev/null +++ b/man/position_nudgestack.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-nudgestack.R +\name{position_nudgestack} +\alias{position_nudgestack} +\title{Simultaneously nudge and stack} +\usage{ +position_nudgestack(x = 0, y = 0, vjust = 1, reverse = FALSE) +} +\arguments{ +\item{x, y}{Amount of vertical and horizontal distance to move.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} +} +\description{ +This is primarily used for set stacked columns between the ticks on the +x-axis. +} +\examples{ +data <- mtcars +ggplot() + + geom_col( + data, + aes(x = cyl, y = gear, fill = gear), + position = position_nudgestack(x = 1) + ) +} +\seealso{ +Other position adjustments: \code{\link{position_dodge}}, + \code{\link{position_identity}}, + \code{\link{position_jitterdodge}}, + \code{\link{position_jitter}}, + \code{\link{position_nudge}}, + \code{\link{position_stack}} +} +\concept{position adjustments} From 87c00faaa52e3b5cf56ee709d2ddaeb3c8bdf47d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 049/125] Add the zoo-package to Suggestions --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index db8d7cc03d..cb2bfb7169 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Suggests: sf (>= 0.7-3), svglite (>= 1.2.0.9001), testthat (>= 2.1.0), - vdiffr (>= 0.3.0) + vdiffr (>= 0.3.0), + zoo Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From d35ea706c17ac6eefd3bb6e9242ffeffecd7b08c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 050/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a2837ba90e..fdfa395feb 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -26,7 +26,7 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From dc6b78deea2f74ba66b27001eeb5e42c9c644b85 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:20 +0200 Subject: [PATCH 051/125] Delete packages from @examples --- R/position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fdfa395feb..a031937593 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,8 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' library(dplyr) -#' library(ggplot2) #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From 31cc1048f989fdaaefcb8af6ef00da09df6727c0 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 052/125] Add new examples --- man/position_nudgestack.Rd | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index e23e8d4ca3..0c97b2c6d9 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,13 +22,23 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -data <- mtcars -ggplot() + - geom_col( - data, - aes(x = cyl, y = gear, fill = gear), - position = position_nudgestack(x = 1) +library(dplyr) +library(ggplot2) +ESM <- data.frame( + as.matrix(EuStockMarkets), + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "\%d \%b \%Y" ) +) + +ESM_prep <- ESM \%>\% + tidyr::gather(key = key, value = value, -date) \%>\% + group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% + filter(date >= "1995-01-01" & date < "1998-01-01") + +ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) } \seealso{ Other position adjustments: \code{\link{position_dodge}}, From 0e80c8afe8874e66e148ebdfecd51c764818579a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 053/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/testthat/test-position-nudgestack.R diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R new file mode 100644 index 0000000000..cda3fd3e20 --- /dev/null +++ b/tests/testthat/test-position-nudgestack.R @@ -0,0 +1,27 @@ +context("position_nudgestack") + +test_that("position_nudgestack draws correctly", { + ESM <- data_frame( + DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], + SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], + CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], + FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "%d %b %Y" + ) + ) + + ESM_prep <- ESM %>% + tidyr::gather(key = key, value = value, -date) %>% + group_by(date, key) %>% + summarize(value = mean(value)) %>% + filter(date >= "1995-01-01" & date < "1998-01-01") + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) + + expect_doppelganger( + "nudgestack EuStockMarkets data", + stock_marked + ) +}) From 59d2b6ecfba1a9a8d2081ea14afd159dbe931ae6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:50 +0200 Subject: [PATCH 054/125] Update vdiffr version --- tests/figs/deps.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/figs/deps.txt b/tests/figs/deps.txt index 059d357267..0f64e23e67 100644 --- a/tests/figs/deps.txt +++ b/tests/figs/deps.txt @@ -1,3 +1,3 @@ - vdiffr-svg-engine: 1.0 -- vdiffr: 0.3.0 +- vdiffr: 0.3.1 - freetypeharfbuzz: 0.2.5 From a1573b3b58c4cc5a75471b0187e99181278392f2 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 055/125] Add validated svg for position_nudgestack --- .../nudgestack-eustockmarkets-data.svg | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg new file mode 100644 index 0000000000..fc0ed6d9a6 --- /dev/null +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -0,0 +1,203 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10000 +20000 + + + + + + + +1995 +1996 +1997 +1998 +date +value + +key + + + + + + + + +CAC +DAX +FTSE +SMI +nudgestack EuStockMarkets data + From da1e7be645b7fb4005e7011c5b114983c78e872f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:37 +0200 Subject: [PATCH 056/125] Delete packages from example --- man/position_nudgestack.Rd | 2 -- 1 file changed, 2 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 0c97b2c6d9..7efb57a035 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,8 +22,6 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -library(dplyr) -library(ggplot2) ESM <- data.frame( as.matrix(EuStockMarkets), date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From 771918d854417823a20a7f0e686a246fad5a924d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 057/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 93 +++++++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index cda3fd3e20..6ac2277a09 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -25,3 +25,96 @@ test_that("position_nudgestack draws correctly", { stock_marked ) }) + + +test_that("nudging works in both dimensions simultaneously", { + # individual nudge value for continuous data + set.seed(111) + + df <- data_frame(x = 1:3) + + p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + + geom_col(position = position_nudgestack(x = 0.5, y = 2)) + + data <- layer_data(p) + + expect_equal(data$x, 1.5:3.5) + expect_equal(data$xmin, 1.05:3.05) + expect_equal(data$xmax, 1.95:3.95) + expect_equal(data$y, 3:5) + expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymax, 3:5) + +}) + +test_that("nudging works for discrete values correctly", { + set.seed(111) + + # x nudge value for discrete data + series <- data.frame( + time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c('a', 'b', 'c', 'd'), 4), + value = rpois(16, 10) + ) + + p <- ggplot(series, aes(time, value, group = type)) + + geom_line(aes(colour = type), position = position_nudgestack(x = 0.5)) + + geom_point(aes(colour = type), position = position_nudgestack(x = 0.5)) + + data <- layer_data(p) + + expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + +}) + + +test_that("data is sorted prior to stacking", { + df <- data_frame( + x = rep(c(1:10), 3), + var = rep(c("a", "b", "c"), 10), + y = round(runif(30, 1, 5)) + ) + p <- ggplot(df, aes(x = x, y = y, fill = var)) + + geom_col(position = position_nudgestack(x = 0.5)) + + dat <- layer_data(p) + expect_true(all(dat$group == 3:1)) +}) + +test_that("negative and positive values are handled separately", { + df <- data_frame( + x = c(1,1,1,2,2), + g = c(1,2,3,1,2), + y = c(1,-1,1,2,-3) + ) + p <- ggplot(df, aes(x, y, fill = factor(g))) + + geom_col(position = position_nudgestack(x = 0.5)) + dat <- layer_data(p) + + expect_equal(dat$ymin[dat$x == 1.5], c(0, -1, 1)) + expect_equal(dat$ymax[dat$x == 1.5], c(1, 0, 2)) + + expect_equal(dat$ymin[dat$x == 2.5], c(0, -3)) + expect_equal(dat$ymax[dat$x == 2.5], c(2, 0)) +}) + +test_that("can request reverse stacking", { + df <- data_frame( + y = c(-2, 2, -1, 1), + g = c("a", "a", "b", "b") + ) + p <- ggplot(df, aes(1, y, fill = g)) + + geom_col(position = position_nudgestack(x = 0.5, reverse = TRUE)) + dat <- layer_data(p) + expect_equal(dat$ymin, c(-2, 0, -3, 2)) +}) + +test_that("position_nudgestack() can stack correctly when ymax is NA", { + df <- data_frame(x = c(1, 1), y = c(1, 1)) + p <- ggplot(df, aes(x, y, ymax = NA_real_)) + + geom_point(position = position_nudgestack(x = 0.5)) + expect_equal(layer_data(p)$y, c(1, 2)) +}) + From 527198760866640933cbc99dab5c218f709ec886 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 08:51:55 +0200 Subject: [PATCH 058/125] Resolve conflict --- R/position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a031937593..b4318e1406 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -44,6 +44,7 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, + type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 752e476b924a8d6148af7df2d4a2757b6b6765d9 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Fri, 27 Sep 2019 15:58:51 +0200 Subject: [PATCH 059/125] Bugfix --- tests/testthat/test-position-nudgestack.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 6ac2277a09..f3532c9686 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -2,10 +2,10 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { ESM <- data_frame( - DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], - SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], - CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], - FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + DAX = EuStockMarkets[,"DAX"], + SMI = EuStockMarkets[,"SMI"], + CAC = EuStockMarkets[,"CAC"], + FTSE = EuStockMarkets[,"FTSE"], date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), format = "%d %b %Y" ) From 88f4a6307a0b277f790f894be0f1b71a06a5a9d6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 30 Sep 2019 14:06:24 +0200 Subject: [PATCH 060/125] Use tsbox for converting ts object to tibble --- DESCRIPTION | 2 +- R/position-nudgestack.R | 15 +- man/position_nudgestack.Rd | 15 +- .../nudgestack-eustockmarkets-data.svg | 302 +++++++++--------- tests/testthat/test-position-nudgestack.R | 23 +- 5 files changed, 171 insertions(+), 186 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index cb2bfb7169..211906ed0b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,7 +56,7 @@ Suggests: svglite (>= 1.2.0.9001), testthat (>= 2.1.0), vdiffr (>= 0.3.0), - zoo + tsbox Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index b4318e1406..139374d410 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,20 +13,15 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' ESM <- data.frame( -#' as.matrix(EuStockMarkets), -#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), -#' format = "%d %b %Y" -#' ) -#' ) +#' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' tidyr::gather(key = key, value = value, -date) %>% -#' group_by(date, key) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' group_by(id, time) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date < "1998-01-01") +#' filter(time >= "1995-01-01" & time < "1998-01-01") #' -#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 7efb57a035..5d6a382bd3 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,20 +22,15 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -ESM <- data.frame( - as.matrix(EuStockMarkets), - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "\%d \%b \%Y" - ) -) +ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - tidyr::gather(key = key, value = value, -date) \%>\% - group_by(date, key) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date < "1998-01-01") + filter(time >= "1995-01-01" & time < "1998-01-01") -ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) } \seealso{ diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg index fc0ed6d9a6..326eed0610 100644 --- a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -19,150 +19,150 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -170,11 +170,13 @@ 0 -10000 -20000 +5000 +10000 +15000 - - + + + @@ -183,10 +185,10 @@ 1996 1997 1998 -date +time value -key +id diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index f3532c9686..29964c5dfb 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,23 +1,16 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- data_frame( - DAX = EuStockMarkets[,"DAX"], - SMI = EuStockMarkets[,"SMI"], - CAC = EuStockMarkets[,"CAC"], - FTSE = EuStockMarkets[,"FTSE"], - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "%d %b %Y" - ) - ) + + ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - tidyr::gather(key = key, value = value, -date) %>% - group_by(date, key) %>% - summarize(value = mean(value)) %>% - filter(date >= "1995-01-01" & date < "1998-01-01") + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::group_by(id, time) %>% + dplyr::summarize(value = mean(value)) %>% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -51,7 +44,7 @@ test_that("nudging works for discrete values correctly", { set.seed(111) # x nudge value for discrete data - series <- data.frame( + series <- data_frame( time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), type = rep(c('a', 'b', 'c', 'd'), 4), value = rpois(16, 10) From 9a45cc8903da804919a7f5f70457cee40f798aae Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 1 Oct 2019 09:03:07 +0200 Subject: [PATCH 061/125] scale_binned (#3096) --- DESCRIPTION | 4 + NAMESPACE | 33 + NEWS.md | 4 + R/guide-bins.R | 587 ++++++++++++++++++ R/guide-colorbar.r | 22 - R/guide-colorsteps.R | 106 ++++ R/scale-.r | 271 +++++++- R/scale-alpha.r | 7 +- R/scale-binned.R | 110 ++++ R/scale-brewer.r | 34 +- R/scale-colour.r | 31 +- R/scale-linetype.r | 9 +- R/scale-shape.r | 9 +- R/scale-size.r | 28 +- R/scale-steps.R | 91 +++ R/scale-viridis.r | 49 +- R/utilities.r | 6 + R/zxx.r | 25 + man/binned_scale.Rd | 123 ++++ man/ggplot2-ggproto.Rd | 18 +- man/guide_bins.Rd | 130 ++++ man/guide_colourbar.Rd | 5 +- man/guide_coloursteps.Rd | 120 ++++ man/guide_legend.Rd | 5 +- man/guides.Rd | 4 +- man/scale_alpha.Rd | 6 +- man/scale_binned.Rd | 123 ++++ man/scale_brewer.Rd | 24 +- man/scale_colour_continuous.Rd | 8 +- man/scale_continuous.Rd | 3 +- man/scale_date.Rd | 3 +- man/scale_discrete.Rd | 3 +- man/scale_gradient.Rd | 1 + man/scale_grey.Rd | 1 + man/scale_hue.Rd | 1 + man/scale_linetype.Rd | 6 +- man/scale_shape.Rd | 6 +- man/scale_size.Rd | 29 +- man/scale_steps.Rd | 195 ++++++ man/scale_viridis.Rd | 22 +- tests/figs/deps.txt | 2 +- .../guides/guide-bins-can-remove-axis.svg | 67 ++ .../guides/guide-bins-can-show-arrows.svg | 73 +++ .../guides/guide-bins-can-show-limits.svg | 75 +++ .../figs/guides/guide-bins-can-show-ticks.svg | 67 ++ .../guides/guide-bins-looks-as-it-should.svg | 71 +++ .../guides/guide-bins-work-horizontally.svg | 71 +++ ...teps-can-have-bins-relative-to-binsize.svg | 157 +++++ .../guide-coloursteps-can-show-limits.svg | 63 ++ .../guide-coloursteps-looks-as-it-should.svg | 61 ++ tests/testthat/test-guides.R | 43 ++ 51 files changed, 2940 insertions(+), 72 deletions(-) create mode 100644 R/guide-bins.R create mode 100644 R/guide-colorsteps.R create mode 100644 R/scale-binned.R create mode 100644 R/scale-steps.R create mode 100644 man/binned_scale.Rd create mode 100644 man/guide_bins.Rd create mode 100644 man/guide_coloursteps.Rd create mode 100644 man/scale_binned.Rd create mode 100644 man/scale_steps.Rd create mode 100644 tests/figs/guides/guide-bins-can-remove-axis.svg create mode 100644 tests/figs/guides/guide-bins-can-show-arrows.svg create mode 100644 tests/figs/guides/guide-bins-can-show-limits.svg create mode 100644 tests/figs/guides/guide-bins-can-show-ticks.svg create mode 100644 tests/figs/guides/guide-bins-looks-as-it-should.svg create mode 100644 tests/figs/guides/guide-bins-work-horizontally.svg create mode 100644 tests/figs/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg create mode 100644 tests/figs/guides/guide-coloursteps-can-show-limits.svg create mode 100644 tests/figs/guides/guide-coloursteps-looks-as-it-should.svg diff --git a/DESCRIPTION b/DESCRIPTION index c20a3cd7a5..7af9aac5ab 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -153,7 +153,9 @@ Collate: 'grob-dotstack.r' 'grob-null.r' 'grouping.r' + 'guide-bins.R' 'guide-colorbar.r' + 'guide-colorsteps.R' 'guide-legend.r' 'guides-.r' 'guides-axis.r' @@ -186,6 +188,7 @@ Collate: 'save.r' 'scale-.r' 'scale-alpha.r' + 'scale-binned.R' 'scale-brewer.r' 'scale-colour.r' 'scale-continuous.r' @@ -200,6 +203,7 @@ Collate: 'scale-manual.r' 'scale-shape.r' 'scale-size.r' + 'scale-steps.R' 'scale-type.R' 'scale-view.r' 'scale-viridis.r' diff --git a/NAMESPACE b/NAMESPACE index 28b49f80ad..de8c8cf4df 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -68,19 +68,24 @@ S3method(grobWidth,zeroGrob) S3method(grobX,absoluteGrob) S3method(grobY,absoluteGrob) S3method(guide_gengrob,axis) +S3method(guide_gengrob,bins) S3method(guide_gengrob,colorbar) S3method(guide_gengrob,guide_none) S3method(guide_gengrob,legend) S3method(guide_geom,axis) +S3method(guide_geom,bins) S3method(guide_geom,colorbar) S3method(guide_geom,guide_none) S3method(guide_geom,legend) S3method(guide_merge,axis) +S3method(guide_merge,bins) S3method(guide_merge,colorbar) S3method(guide_merge,guide_none) S3method(guide_merge,legend) S3method(guide_train,axis) +S3method(guide_train,bins) S3method(guide_train,colorbar) +S3method(guide_train,colorsteps) S3method(guide_train,guide_none) S3method(guide_train,legend) S3method(guide_transform,axis) @@ -201,6 +206,8 @@ export(PositionJitterdodge) export(PositionNudge) export(PositionStack) export(Scale) +export(ScaleBinned) +export(ScaleBinnedPosition) export(ScaleContinuous) export(ScaleContinuousDate) export(ScaleContinuousDatetime) @@ -370,8 +377,11 @@ export(ggproto_parent) export(ggsave) export(ggtitle) export(guide_axis) +export(guide_bins) export(guide_colorbar) +export(guide_colorsteps) export(guide_colourbar) +export(guide_coloursteps) export(guide_gengrob) export(guide_geom) export(guide_legend) @@ -438,12 +448,14 @@ export(scale_alpha_discrete) export(scale_alpha_identity) export(scale_alpha_manual) export(scale_alpha_ordinal) +export(scale_color_binned) export(scale_color_brewer) export(scale_color_continuous) export(scale_color_date) export(scale_color_datetime) export(scale_color_discrete) export(scale_color_distiller) +export(scale_color_fermenter) export(scale_color_gradient) export(scale_color_gradient2) export(scale_color_gradientn) @@ -452,14 +464,19 @@ export(scale_color_hue) export(scale_color_identity) export(scale_color_manual) export(scale_color_ordinal) +export(scale_color_steps) +export(scale_color_steps2) +export(scale_color_stepsn) export(scale_color_viridis_c) export(scale_color_viridis_d) +export(scale_colour_binned) export(scale_colour_brewer) export(scale_colour_continuous) export(scale_colour_date) export(scale_colour_datetime) export(scale_colour_discrete) export(scale_colour_distiller) +export(scale_colour_fermenter) export(scale_colour_gradient) export(scale_colour_gradient2) export(scale_colour_gradientn) @@ -468,17 +485,23 @@ export(scale_colour_hue) export(scale_colour_identity) export(scale_colour_manual) export(scale_colour_ordinal) +export(scale_colour_steps) +export(scale_colour_steps2) +export(scale_colour_stepsn) +export(scale_colour_viridis_b) export(scale_colour_viridis_c) export(scale_colour_viridis_d) export(scale_continuous_identity) export(scale_discrete_identity) export(scale_discrete_manual) +export(scale_fill_binned) export(scale_fill_brewer) export(scale_fill_continuous) export(scale_fill_date) export(scale_fill_datetime) export(scale_fill_discrete) export(scale_fill_distiller) +export(scale_fill_fermenter) export(scale_fill_gradient) export(scale_fill_gradient2) export(scale_fill_gradientn) @@ -487,15 +510,21 @@ export(scale_fill_hue) export(scale_fill_identity) export(scale_fill_manual) export(scale_fill_ordinal) +export(scale_fill_steps) +export(scale_fill_steps2) +export(scale_fill_stepsn) +export(scale_fill_viridis_b) export(scale_fill_viridis_c) export(scale_fill_viridis_d) export(scale_linetype) +export(scale_linetype_binned) export(scale_linetype_continuous) export(scale_linetype_discrete) export(scale_linetype_identity) export(scale_linetype_manual) export(scale_radius) export(scale_shape) +export(scale_shape_binned) export(scale_shape_continuous) export(scale_shape_discrete) export(scale_shape_identity) @@ -503,6 +532,8 @@ export(scale_shape_manual) export(scale_shape_ordinal) export(scale_size) export(scale_size_area) +export(scale_size_binned) +export(scale_size_binned_area) export(scale_size_continuous) export(scale_size_date) export(scale_size_datetime) @@ -511,6 +542,7 @@ export(scale_size_identity) export(scale_size_manual) export(scale_size_ordinal) export(scale_type) +export(scale_x_binned) export(scale_x_continuous) export(scale_x_date) export(scale_x_datetime) @@ -519,6 +551,7 @@ export(scale_x_log10) export(scale_x_reverse) export(scale_x_sqrt) export(scale_x_time) +export(scale_y_binned) export(scale_y_continuous) export(scale_y_date) export(scale_y_datetime) diff --git a/NEWS.md b/NEWS.md index 5dd0bea39b..ac58e9c933 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* A new scale type has been added, that allows binning of aesthetics at the + scale level. It has versions for both position and non-position aesthetics and + comes with two new guides (`guide_bins` and `guide_coloursteps`) (@thomasp85, #3096) + * Position guides can now be customized using the new `guide_axis()`, which can be passed to position `scale_*()` functions or via `guides()`. The new axis guide (`guide_axis()`) comes with diff --git a/R/guide-bins.R b/R/guide-bins.R new file mode 100644 index 0000000000..88a21e1c10 --- /dev/null +++ b/R/guide-bins.R @@ -0,0 +1,587 @@ +#' A binned version of guide_legend +#' +#' This guide is a version of the [guide_legend()] guide for binned scales. It +#' differs in that it places ticks correctly between the keys, and sports a +#' small axis to better show the binning. Like [guide_legend()] it can be used +#' for all non-position aesthetics though colour and fill defaults to +#' [guide_coloursteps()], and it will merge aesthetics together into the same +#' guide if they are mapped in the same way. +#' +#' @inheritParams guide_legend +#' @param axis Logical. Should a small axis be drawn along the guide +#' @param axis.colour,axis.linewidth Graphic specifications for the look of the +#' axis. +#' @param axis.arrow A call to `arrow()` to specify arrows at the end of the +#' axis line, thus showing an open interval. +#' @param show.limits Logical. Should the limits of the scale be shown with +#' labels and ticks. +#' +#' @return A guide object +#' @family guides +#' @export +#' +#' @examples +#' p <- ggplot(mtcars) + +#' geom_point(aes(disp, mpg, size = hp)) + +#' scale_size_binned() +#' +#' # Standard look +#' p +#' +#' # Remove the axis or style it +#' p + guides(size = guide_bins(axis = FALSE)) +#' +#' p + guides(size = guide_bins(show.limits = TRUE)) +#' +#' p + guides(size = guide_bins( +#' axis.arrow = arrow(length = unit(1.5, 'mm'), ends = 'both') +#' )) +#' +#' # Guides are merged together if possible +#' ggplot(mtcars) + +#' geom_point(aes(disp, mpg, size = hp, colour = hp)) + +#' scale_size_binned() + +#' scale_colour_binned(guide = "bins") +#' +guide_bins <- function( + # title + title = waiver(), + title.position = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, + + # label + label = TRUE, + label.position = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, + + # key + keywidth = NULL, + keyheight = NULL, + + # ticks + axis = TRUE, + axis.colour = "black", + axis.linewidth = 0.5, + axis.arrow = NULL, + + # general + direction = NULL, + default.unit = "line", + override.aes = list(), + reverse = FALSE, + order = 0, + show.limits = NULL, + ...) { + + structure(list( + # title + title = title, + title.position = title.position, + title.theme = title.theme, + title.hjust = title.hjust, + title.vjust = title.vjust, + + # label + label = label, + label.position = label.position, + label.theme = label.theme, + label.hjust = label.hjust, + label.vjust = label.vjust, + + # key + keywidth = keywidth, + keyheight = keyheight, + + # ticks + axis = axis, + axis.colour = axis.colour, + axis.linewidth = axis.linewidth, + axis.arrow = axis.arrow, + + # general + direction = direction, + default.unit = default.unit, + reverse = reverse, + order = order, + show.limits = show.limits, + + # parameter + available_aes = c("any"), + ..., + name = "bins"), + class = c("guide", "bins") + ) +} + +#' @export +guide_train.bins <- function(guide, scale, aesthetic = NULL) { + breaks <- scale$get_breaks() + if (length(breaks) == 0 || all(is.na(breaks))) { + return() + } + limits <- scale$get_limits() + all_breaks <- c(limits[1], breaks, limits[2]) + bin_at <- all_breaks[-1] - diff(all_breaks) / 2 + # in the key data frame, use either the aesthetic provided as + # argument to this function or, as a fall back, the first in the vector + # of possible aesthetics handled by the scale + aes_column_name <- aesthetic %||% scale$aesthetics[1] + key <- new_data_frame(setNames(list(c(scale$map(bin_at), NA)), aes_column_name)) + key$.label <- scale$get_labels(all_breaks) + guide$show.limits <- guide$show.limits %||% scale$show_limits %||% FALSE + + if (guide$reverse) key <- key[nrow(key):1, ] + + guide$key <- key + guide$hash <- with( + guide, + digest::digest(list(title, key$.label, direction, name)) + ) + guide +} + +#' @export +guide_merge.bins <- function(guide, new_guide) { + guide$key <- merge(guide$key, new_guide$key, sort = FALSE) + guide$override.aes <- c(guide$override.aes, new_guide$override.aes) + if (any(duplicated(names(guide$override.aes)))) { + warning("Duplicated override.aes is ignored.") + } + guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] + guide +} + +#' @export +guide_geom.bins <- function(guide, layers, default_mapping) { + # arrange common data for vertical and horizontal guide + guide$geoms <- lapply(layers, function(layer) { + matched <- matched_aes(layer, guide, default_mapping) + + if (length(matched) > 0) { + # This layer contributes to the legend + + # check if this layer should be included, different behaviour depending on + # if show.legend is a logical or a named logical vector + if (!is.null(names(layer$show.legend))) { + layer$show.legend <- rename_aes(layer$show.legend) + include <- is.na(layer$show.legend[matched]) || + layer$show.legend[matched] + } else { + include <- is.na(layer$show.legend) || layer$show.legend + } + + if (include) { + # Default is to include it + + # Filter out set aesthetics that can't be applied to the legend + n <- vapply(layer$aes_params, length, integer(1)) + params <- layer$aes_params[n == 1] + + data <- layer$geom$use_defaults(guide$key[matched], params) + } else { + return(NULL) + } + } else { + # This layer does not contribute to the legend + if (is.na(layer$show.legend) || !layer$show.legend) { + # Default is to exclude it + return(NULL) + } else { + data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ] + } + } + + # override.aes in guide_legend manually changes the geom + data <- modify_list(data, guide$override.aes) + + list( + draw_key = layer$geom$draw_key, + data = data, + params = c(layer$geom_params, layer$stat_params) + ) + }) + + # remove null geom + guide$geoms <- compact(guide$geoms) + + # Finally, remove this guide if no layer is drawn + if (length(guide$geoms) == 0) guide <- NULL + guide +} + +#' @export +guide_gengrob.bins <- function(guide, theme) { + if (!guide$show.limits) { + guide$key$.label[c(1, nrow(guide$key))] <- NA + } + + # default setting + if (guide$direction == "horizontal") { + label.position <- guide$label.position %||% "bottom" + if (!label.position %in% c("top", "bottom")) { + warning("Ignoring invalid label.position", call. = FALSE) + label.position <- "bottom" + } + } else { + label.position <- guide$label.position %||% "right" + if (!label.position %in% c("left", "right")) { + warning("Ignoring invalid label.position", call. = FALSE) + label.position <- "right" + } + } + + n_keys <- nrow(guide$key) - 1 + + # obtain the theme for the legend title. We need this both for the title grob + # and to obtain the title fontsize. + title.theme <- guide$title.theme %||% calc_element("legend.title", theme) + + title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0 + title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5 + + grob.title <- ggname("guide.title", + element_grob( + title.theme, + label = guide$title, + hjust = title.hjust, + vjust = title.vjust, + margin_x = TRUE, + margin_y = TRUE + ) + ) + + title_width <- width_cm(grob.title) + title_height <- height_cm(grob.title) + title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||% + calc_element("text", theme)$size %||% 11 + + # gap between keys etc + # the default horizontal and vertical gap need to be the same to avoid strange + # effects for certain guide layouts + hgap <- width_cm(theme$legend.spacing.x %||% (0.5 * unit(title_fontsize, "pt"))) + vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt"))) + + # Labels + + # first get the label theme, we need it below even when there are no labels + label.theme <- guide$label.theme %||% calc_element("legend.text", theme) + + if (!guide$label || is.null(guide$key$.label)) { + grob.labels <- rep(list(zeroGrob()), nrow(guide$key)) + } else { + # get the defaults for label justification. The defaults are complicated and depend + # on the direction of the legend and on label placement + just_defaults <- label_just_defaults.bins(guide$direction, label.position) + # don't set expressions left-justified + if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1 + + # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual + # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which + # seems worse + if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL + if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL + + # label.theme in param of guide_legend() > theme$legend.text.align > default + hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||% + just_defaults$hjust + vjust <- guide$label.vjust %||% label.theme$vjust %||% + just_defaults$vjust + + grob.labels <- lapply(guide$key$.label, function(label, ...) { + g <- element_grob( + element = label.theme, + label = label, + hjust = hjust, + vjust = vjust, + margin_x = TRUE, + margin_y = TRUE + ) + ggname("guide.label", g) + }) + if (!guide$show.limits) { + grob.labels[c(1, length(grob.labels))] <- list(zeroGrob()) + } + } + + label_widths <- width_cm(grob.labels) + label_heights <- height_cm(grob.labels) + + # Keys + key_width <- width_cm( + guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size + ) + key_height <- height_cm( + guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size + ) + + key_size_mat <- do.call("cbind", + lapply(guide$geoms, function(g) g$data$size / 10) + )[seq_len(n_keys), , drop = FALSE] + + if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) { + key_size_mat <- matrix(0, ncol = 1, nrow = n_keys) + } + key_sizes <- apply(key_size_mat, 1, max) + + if (guide$direction == "horizontal") { + key.nrow <- 1 + key.ncol <- n_keys + label.nrow <- 1 + label.ncol <- n_keys + 1 + } else { + key.nrow <- n_keys + key.ncol <- 1 + label.nrow <- n_keys + 1 + label.ncol <- 1 + } + + key_sizes <- matrix(key_sizes, key.nrow, key.ncol) + label_sizes <- matrix(label_widths, label.nrow, label.ncol) + + key_widths <- max(key_width, apply(key_sizes, 2, max)) + key_heights <- max(key_height, apply(key_sizes, 1, max)) + + label_widths <- max(apply(label_sizes, 2, max)) + label_heights <- max(apply(label_sizes, 1, max)) + + key_loc <- data_frame( + R = seq(2, by = 2, length.out = n_keys), + C = if (label.position %in% c("right", "bottom")) 1 else 3 + ) + label_loc <- data_frame( + R = seq(1, by = 2, length.out = n_keys + 1), + C = if (label.position %in% c("right", "bottom")) 3 else 1 + ) + tick_loc <- label_loc + tick_loc$C <- if (label.position %in% c("right", "bottom")) 1 else 3 + + widths <- c(key_widths, hgap, label_widths) + if (label.position != "right") widths <- rev(widths) + heights <- c(interleave(rep(0, n_keys), key_heights), 0) + if (guide$direction == "horizontal") { + names(key_loc) <- c("C", "R") + names(label_loc) <- c("C", "R") + names(tick_loc) <- c("C", "R") + heights <- c(key_heights, vgap, label_heights) + if (label.position != "bottom") heights <- rev(heights) + widths <- c(interleave(rep(0, n_keys), key_widths), 0) + } + + # layout the title over key-label + switch(guide$title.position, + "top" = { + widths <- c(widths, max(0, title_width - sum(widths))) + heights <- c(title_height, vgap, heights) + key_loc$R <- key_loc$R + 2 + label_loc$R <- label_loc$R + 2 + tick_loc$R <- tick_loc$R + 2 + title_row = 1 + title_col = seq_along(widths) + }, + "bottom" = { + widths <- c(widths, max(0, title_width - sum(widths))) + heights <- c(heights, vgap, title_height) + title_row = length(heights) + title_col = seq_along(widths) + }, + "left" = { + widths <- c(title_width, hgap, widths) + heights <- c(heights, max(0, title_height - sum(heights))) + key_loc$C <- key_loc$C + 2 + label_loc$C <- label_loc$C + 2 + tick_loc$C <- tick_loc$C + 2 + title_row = seq_along(heights) + title_col = 1 + }, + "right" = { + widths <- c(widths, hgap, title_width) + heights <- c(heights, max(0, title_height - sum(heights))) + title_row = seq_along(heights) + title_col = length(widths) + } + ) + + # grob for key + key_size <- c(key_width, key_height) * 10 + + draw_key <- function(i) { + bg <- element_render(theme, "legend.key") + keys <- lapply(guide$geoms, function(g) { + g$draw_key(g$data[i, ], g$params, key_size) + }) + c(list(bg), keys) + } + grob.keys <- unlist(lapply(seq_len(n_keys), draw_key), recursive = FALSE) + + # background + grob.background <- element_render(theme, "legend.background") + + ngeom <- length(guide$geoms) + 1 + kcols <- rep(key_loc$C, each = ngeom) + krows <- rep(key_loc$R, each = ngeom) + + # padding + padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE) + widths <- c(padding[4], widths, padding[2]) + heights <- c(padding[1], heights, padding[3]) + + # make the ticks grob (`grob.ticks`) + if (!guide$axis) { + grob.ticks <- zeroGrob() + grob.axis <- zeroGrob() + } else { + if (guide$direction == "horizontal") { + x0 <- 0.5 + y0 <- 0 + x1 <- 0.5 + y1 <- 1/5 + axis_x <- c(0, 1) + axis_y <- c(0, 0) + if (label.position == "top") { + y0 <- 4/5 + y1 <- 1 + axis_y <- c(1, 1) + } + } else { # guide$direction == "vertical" + y0 <- 0.5 + x0 <- 4/5 + y1 <- 0.5 + x1 <- 1 + axis_x <- c(1, 1) + axis_y <- c(0, 1) + if (label.position == "left") { + x0 <- 0 + x1 <- 1/5 + axis_x <- c(0, 0) + } + } + grob.ticks <- segmentsGrob( + x0 = x0, y0 = y0, x1 = x1, y1 = y1, + default.units = "npc", + gp = gpar( + col = guide$axis.colour, + lwd = guide$axis.linewidth, + lineend = "butt" + ) + ) + grob.axis <- segmentsGrob( + x0 = axis_x[1], y0 = axis_y[1], x1 = axis_x[2], y1 = axis_y[2], + default.units = "npc", + arrow = guide$axis.arrow, + gp = gpar( + col = guide$axis.colour, + lwd = guide$axis.linewidth, + lineend = if (is.null(guide$axis.arrow)) "square" else "round" + ) + ) + } + grob.ticks <- rep_len(list(grob.ticks), length(grob.labels)) + if (!guide$show.limits) { + grob.ticks[c(1, length(grob.ticks))] <- list(zeroGrob()) + } + # Create the gtable for the legend + gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm")) + gt <- gtable_add_grob( + gt, + grob.background, + name = "background", + clip = "off", + t = 1, + r = -1, + b = -1, + l = 1 + ) + gt <- gtable_add_grob( + gt, + justify_grobs( + grob.title, + hjust = title.hjust, + vjust = title.vjust, + int_angle = title.theme$angle, + debug = title.theme$debug + ), + name = "title", + clip = "off", + t = 1 + min(title_row), + r = 1 + max(title_col), + b = 1 + max(title_row), + l = 1 + min(title_col) + ) + gt <- gtable_add_grob( + gt, + grob.keys, + name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"), + clip = "off", + t = 1 + krows, + r = 1 + kcols, + b = 1 + krows, + l = 1 + kcols + ) + gt <- gtable_add_grob( + gt, + grob.ticks, + name = paste("tick", tick_loc$R, tick_loc$C, sep = "-"), + clip = "off", + t = 1 + tick_loc$R, + r = 1 + tick_loc$C, + b = 1 + tick_loc$R, + l = 1 + tick_loc$C + ) + gt <- gtable_add_grob( + gt, + grob.axis, + name = "axis", + clip = "off", + t = min(1 + tick_loc$R), + r = min(1 + tick_loc$C), + b = max(1 + tick_loc$R), + l = max(1 + tick_loc$C) + ) + gt <- gtable_add_grob( + gt, + justify_grobs( + grob.labels, + hjust = hjust, + vjust = vjust, + int_angle = label.theme$angle, + debug = label.theme$debug + ), + name = paste("label", label_loc$R, label_loc$C, sep = "-"), + clip = "off", + t = 1 + label_loc$R, + r = 1 + label_loc$C, + b = 1 + label_loc$R, + l = 1 + label_loc$C + ) + gt +} + +#' Calculate the default hjust and vjust settings depending on legend +#' direction and position. +#' +#' @noRd +label_just_defaults.bins <- function(direction, position) { + if (direction == "horizontal") { + switch( + position, + "top" = list(hjust = 0.5, vjust = 0), + "bottom" = list(hjust = 0.5, vjust = 1), + "left" = list(hjust = 1, vjust = 0.5), + list(hjust = 0.5, vjust = 0.5) + ) + } + else { + switch( + position, + "top" = list(hjust = 0.5, vjust = 0), + "bottom" = list(hjust = 0.5, vjust = 1), + "left" = list(hjust = 1, vjust = 0.5), + list(hjust = 0, vjust = 0.5) + ) + + } +} diff --git a/R/guide-colorbar.r b/R/guide-colorbar.r index 4250443b9d..26a959ad3f 100644 --- a/R/guide-colorbar.r +++ b/R/guide-colorbar.r @@ -566,25 +566,3 @@ guide_gengrob.colorbar <- function(guide, theme) { #' @export #' @rdname guide_colourbar guide_colorbar <- guide_colourbar - -#' Calculate the default hjust and vjust settings depending on legend -#' direction and position. -#' -#' @noRd -label_just_defaults.colorbar <- function(direction, position) { - if (direction == "horizontal") { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - list(hjust = 0.5, vjust = 1) - ) - } - else { - switch( - position, - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0, vjust = 0.5) - ) - } -} - diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R new file mode 100644 index 0000000000..fcbabf448f --- /dev/null +++ b/R/guide-colorsteps.R @@ -0,0 +1,106 @@ +#' Discretized colourbar guide +#' +#' This guide is version of [guide_colourbar()] for binned colour and fill +#' scales. It shows areas between breaks as a single constant colour instead of +#' the gradient known from the colourbar counterpart. +#' +#' @param even.steps Should the rendered size of the bins be equal, or should +#' they be proportional to their length in the data space? Defaults to `TRUE` +#' @param show.limits Should labels for the outer limits of the bins be printed? +#' Default is `NULL` which makes the guide use the setting from the scale +#' @param ticks A logical specifying if tick marks on the colourbar should be +#' visible. +#' @inheritDotParams guide_colourbar -nbin -raster -ticks -available_aes +#' +#' @return A guide object +#' @export +#' +#' @family guides +#' @examples +#' df <- reshape2::melt(outer(1:10, 1:10), varnames = c("X1", "X2")) +#' +#' p <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value)) +#' +#' # Coloursteps guide is the default for binned colour scales +#' p + scale_fill_binned() +#' +#' # By default each bin in the guide is the same size irrespectively of how +#' # their sizes relate in data space +#' p + scale_fill_binned(breaks = c(10, 25, 50)) +#' +#' # This can be changed with the `even.steps` argument +#' p + scale_fill_binned( +#' breaks = c(10, 25, 50), +#' guide = guide_coloursteps(even.steps = FALSE) +#' ) +#' +#' # By default the limits is not shown, but this can be changed +#' p + scale_fill_binned(guide = guide_coloursteps(show.limits = TRUE)) +#' +#' # (can also be set in the scale) +#' p + scale_fill_binned(show.limits = TRUE) +#' +guide_coloursteps <- function(even.steps = TRUE, show.limits = NULL, ticks = FALSE, ...) { + guide <- guide_colourbar(raster = FALSE, ticks = ticks, nbin = 100, ...) + guide$even.steps <- even.steps + guide$show.limits <- show.limits + class(guide) <- c('colorsteps', class(guide)) + guide +} +#' @export +#' @rdname guide_coloursteps +guide_colorsteps <- guide_coloursteps + +#' @export +guide_train.colorsteps <- function(guide, scale, aesthetic = NULL) { + if (guide$even.steps) { + breaks <- scale$get_breaks() + if (length(breaks) == 0 || all(is.na(breaks))) + return() + limits <- scale$get_limits() + all_breaks <- c(limits[1], breaks, limits[2]) + bin_at <- all_breaks[-1] - diff(all_breaks) / 2 + ticks <- new_data_frame(setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1])) + ticks$.value <- seq_along(breaks) - 0.5 + ticks$.label <- scale$get_labels(breaks) + guide$nbin <- length(breaks) + 1 + guide$key <- ticks + guide$bar <- new_data_frame(list(colour = scale$map(bin_at), value = seq_along(bin_at) - 1), n = length(bin_at)) + if (guide$reverse) { + guide$key <- guide$key[nrow(guide$key):1, ] + guide$bar <- guide$bar[nrow(guide$bar):1, ] + } + guide$hash <- with(guide, digest::digest(list(title, key$.label, bar, name))) + } else { + guide <- NextMethod() + } + if (guide$show.limits %||% scale$show.limits %||% FALSE) { + edges <- rescale(c(0, 1), to = guide$bar$value[c(1, nrow(guide$bar))], from = c(0.5, guide$nbin - 0.5) / guide$nbin) + limits <- scale$get_limits() + guide$key <- guide$key[c(NA, seq_len(nrow(guide$key)), NA), , drop = FALSE] + guide$key$.value[c(1, nrow(guide$key))] <- edges + guide$key$.label[c(1, nrow(guide$key))] <- scale$get_labels(limits) + } + guide +} + +#' Calculate the default hjust and vjust settings depending on legend +#' direction and position. +#' +#' @noRd +label_just_defaults.colorbar <- function(direction, position) { + if (direction == "horizontal") { + switch( + position, + "top" = list(hjust = 0.5, vjust = 0), + list(hjust = 0.5, vjust = 1) + ) + } + else { + switch( + position, + "left" = list(hjust = 1, vjust = 0.5), + list(hjust = 0, vjust = 0.5) + ) + } +} diff --git a/R/scale-.r b/R/scale-.r index 9ccd77b42d..76e32d006d 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -186,6 +186,70 @@ discrete_scale <- function(aesthetics, scale_name, palette, name = waiver(), ) } +#' Binning scale constructor +#' +#' @inheritParams continuous_scale +#' @param n.breaks The number of break points to create if breaks are not given +#' directly. +#' @param nice.breaks Logical. Should breaks be attempted placed at nice values +#' instead of exactly evenly spaced between the limits. If `TRUE` (default) +#' the scale will ask the transformation object to create breaks, and this +#' may result in a different number of breaks than requested. Ignored if +#' breaks are given explicetly. +#' @param right Should values on the border between bins be part of the right +#' (upper) bin? +#' @param show.limits should the limits of the scale appear as ticks +#' @keywords internal +binned_scale <- function(aesthetics, scale_name, palette, name = waiver(), + breaks = waiver(), labels = waiver(), limits = NULL, + rescaler = rescale, oob = squish, expand = waiver(), + na.value = NA_real_, n.breaks = NULL, nice.breaks = TRUE, + right = TRUE, trans = "identity", show.limits = FALSE, + guide = "bins", position = "left", super = ScaleBinned) { + + aesthetics <- standardise_aes_names(aesthetics) + + check_breaks_labels(breaks, labels) + + position <- match.arg(position, c("left", "right", "top", "bottom")) + + if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") { + guide <- "none" + } + + trans <- as.trans(trans) + if (!is.null(limits)) { + limits <- trans$transform(limits) + } + + ggproto(NULL, super, + call = match.call(), + + aesthetics = aesthetics, + scale_name = scale_name, + palette = palette, + + range = continuous_range(), + limits = limits, + trans = trans, + na.value = na.value, + expand = expand, + rescaler = rescaler, + oob = oob, + n.breaks = n.breaks, + nice.breaks = nice.breaks, + right = right, + show.limits = show.limits, + + name = name, + breaks = breaks, + + labels = labels, + guide = guide, + position = position + ) +} + #' @section Scales: #' #' All `scale_*` functions like [scale_x_continuous()] return a `Scale*` @@ -472,11 +536,8 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, transform = function(self, x) { new_x <- self$trans$transform(x) - if (any(is.finite(x) != is.finite(new_x))) { - type <- if (self$scale_name == "position_c") "continuous" else "discrete" - axis <- if ("x" %in% self$aesthetics) "x" else "y" - warning("Transformation introduced infinite values in ", type, " ", axis, "-axis", call. = FALSE) - } + axis <- if ("x" %in% self$aesthetics) "x" else "y" + check_transformation(x, new_x, self$scale_name, axis) new_x }, @@ -810,6 +871,193 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, } ) +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +ScaleBinned <- ggproto("ScaleBinned", Scale, + range = continuous_range(), + na.value = NA_real_, + rescaler = rescale, + oob = squish, + n.breaks = NULL, + nice.breaks = TRUE, + right = TRUE, + after.stat = FALSE, + show.limits = FALSE, + + is_discrete = function() FALSE, + + train = function(self, x) { + if (!is.numeric(x)) { + stop("Binned scales only support continuous data", call. = FALSE) + } + + if (length(x) == 0) { + return() + } + self$range$train(x) + }, + + transform = function(self, x) { + new_x <- self$trans$transform(x) + axis <- if ("x" %in% self$aesthetics) "x" else "y" + check_transformation(x, new_x, self$scale_name, axis) + new_x + }, + + map = function(self, x, limits = self$get_limits()) { + if (self$after.stat) { + x + } else { + breaks <- self$get_breaks(limits) + breaks <- sort(unique(c(limits[1], breaks, limits[2]))) + + x <- self$rescale(self$oob(x, range = limits), limits) + breaks <- self$rescale(breaks, limits) + + x_binned <- cut(x, breaks, + labels = FALSE, + include.lowest = TRUE, + right = self$right + ) + + if (!is.null(self$palette.cache)) { + pal <- self$palette.cache + } else { + pal <- self$palette(breaks[-1] - diff(breaks) / 2) + self$palette.cache <- pal + } + + pal[x_binned] + } + }, + + rescale = function(self, x, limits = self$get_limits(), range = limits) { + self$rescaler(x, from = range) + }, + + dimension = function(self, expand = c(0, 0, 0, 0)) { + expand_range4(self$get_limits(), expand) + }, + + get_breaks = function(self, limits = self$get_limits()) { + if (self$is_empty()) return(numeric()) + + limits <- self$trans$inverse(limits) + + if (is.null(self$breaks)) { + return(NULL) + } else if (identical(self$breaks, NA)) { + stop("Invalid breaks specification. Use NULL, not NA", call. = FALSE) + } else if (is.waive(self$breaks)) { + if (self$nice.breaks) { + if (!is.null(self$n.breaks) && "n" %in% names(formals(self$trans$breaks))) { + breaks <- self$trans$breaks(limits, n = self$n.breaks) + } else { + if (!is.null(self$n.breaks)) { + warning("Ignoring n.breaks. Use a trans object that supports setting number of breaks", call. = FALSE) + } + breaks <- self$trans$breaks(limits) + } + } else { + n.breaks <- self$n.breaks %||% 5 # same default as trans objects + breaks <- seq(limits[1], limits[2], length.out = n.breaks + 2) + breaks <- breaks[-c(1, length(breaks))] + } + + # Ensure terminal bins are same width if limits not set + if (is.null(self$limits)) { + # Remove calculated breaks if they coincide with limits + breaks <- setdiff(breaks, limits) + nbreaks <- length(breaks) + if (nbreaks >= 2) { + new_limits <- c(2 * breaks[1] - breaks[2], 2 * breaks[nbreaks] - breaks[nbreaks - 1]) + if (breaks[nbreaks] > limits[2]) { + new_limits[2] <- breaks[nbreaks] + breaks <- breaks[-nbreaks] + } + if (breaks[1] < limits[1]) { + new_limits[1] <- breaks[1] + breaks <- breaks[-1] + } + limits <- new_limits + } else { + bin_size <- max(breaks[1] - limits[1], limits[2] - breaks[1]) + limits <- c(breaks[1] - bin_size, breaks[1] + bin_size) + } + self$limits <- self$trans$transform(limits) + } + } else if (is.function(self$breaks)) { + breaks <- self$breaks(limits, self$n_bins) + } else { + breaks <- self$breaks + } + + # Breaks must be within limits + breaks <- breaks[breaks >= limits[1] & breaks <= limits[2]] + self$breaks <- breaks + + self$trans$transform(breaks) + }, + + get_breaks_minor = function(...) NULL, + + get_labels = function(self, breaks = self$get_breaks()) { + if (is.null(breaks)) return(NULL) + + breaks <- self$trans$inverse(breaks) + + if (is.null(self$labels)) { + return(NULL) + } else if (identical(self$labels, NA)) { + stop("Invalid labels specification. Use NULL, not NA", call. = FALSE) + } else if (is.waive(self$labels)) { + labels <- self$trans$format(breaks) + } else if (is.function(self$labels)) { + labels <- self$labels(breaks) + } else { + labels <- self$labels + } + if (length(labels) != length(breaks)) { + stop("Breaks and labels are different lengths") + } + labels + }, + + clone = function(self) { + new <- ggproto(NULL, self) + new$range <- continuous_range() + new + }, + + break_info = function(self, range = NULL) { + # range + if (is.null(range)) range <- self$dimension() + + # major breaks + major <- self$get_breaks(range) + + if (!is.null(self$palette.cache)) { + pal <- self$palette.cache + } else { + pal <- self$palette(length(major) + 1) + } + + if (self$show.limits) { + limits <- self$get_limits() + major <- sort(unique(c(limits, major))) + } + + # labels + labels <- self$get_labels(major) + + list(range = range, labels = labels, + major = pal, minor = NULL, + major_source = major, minor_source = NULL) + } +) + # In place modification of a scale to change the primary axis scale_flip_position <- function(scale) { scale$position <- switch(scale$position, @@ -821,3 +1069,16 @@ scale_flip_position <- function(scale) { ) invisible() } + +check_transformation <- function(x, transformed, name, axis) { + if (any(is.finite(x) != is.finite(transformed))) { + type <- if (name == "position_b") { + "binned" + } else if (name == "position_c") { + "continuous" + } else { + "discrete" + } + warning("Transformation introduced infinite values in ", type, " ", axis, "-axis", call. = FALSE) + } +} diff --git a/R/scale-alpha.r b/R/scale-alpha.r index 967ae92d9a..9c59f09d20 100644 --- a/R/scale-alpha.r +++ b/R/scale-alpha.r @@ -5,7 +5,7 @@ #' `scale_alpha` is an alias for `scale_alpha_continuous` since #' that is the most common use of alpha, and it saves a bit of typing. #' -#' @param ... Other arguments passed on to [continuous_scale()] +#' @param ... Other arguments passed on to [continuous_scale()], [binned_scale], #' or [discrete_scale()] as appropriate, to control name, limits, #' breaks, labels and so forth. #' @param range Output range of alpha values. Must lie between 0 and 1. @@ -26,6 +26,11 @@ scale_alpha <- function(..., range = c(0.1, 1)) { #' @export scale_alpha_continuous <- scale_alpha +#' @rdname scale_alpha +scale_alpha_binned <- function(..., range = c(0.1, 1)) { + binned_scale("alpha", "alpha_b", rescale_pal(range), ...) +} + #' @rdname scale_alpha #' @export scale_alpha_discrete <- function(...) { diff --git a/R/scale-binned.R b/R/scale-binned.R new file mode 100644 index 0000000000..4a869bc726 --- /dev/null +++ b/R/scale-binned.R @@ -0,0 +1,110 @@ +#' Positional scales for binning continuous data (x & y) +#' +#' `scale_x_binned()` and `scale_y_binned()` are scales that discretize +#' continuous position data. You can use these scales to transform continuous +#' inputs before using it with a geom that requires discrete positions. An +#' example is using `scale_x_binned()` with [geom_bar()] to create a histogram. +#' +#' @inheritParams binned_scale +#' +#' @family position scales +#' @name scale_binned +#' @aliases NULL +#' +#' @examples +#' # Create a histogram by binning the x-axis +#' ggplot(mtcars) + +#' geom_bar(aes(mpg)) + +#' scale_x_binned() +NULL + +#' @rdname scale_binned +#' +#' @export +scale_x_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, + breaks = waiver(), labels = waiver(), limits = NULL, + expand = waiver(), oob = squish, na.value = NA_real_, + right = TRUE, show.limits = FALSE, trans = "identity", + position = "bottom") { + binned_scale( + aesthetics = c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper"), + scale_name = "position_b", palette = identity, name = name, breaks = breaks, + labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value, + n.breaks = n.breaks, nice.breaks = nice.breaks, right = right, trans = trans, + show.limits = show.limits, guide = "none", position = position, super = ScaleBinnedPosition + ) +} + +#' @rdname scale_binned +#' +#' @export +scale_y_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, + breaks = waiver(), labels = waiver(), limits = NULL, + expand = waiver(), oob = squish, na.value = NA_real_, + right = TRUE, show.limits = FALSE, trans = "identity", + position = "left") { + binned_scale( + aesthetics = c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", "lower", "middle", "upper"), + scale_name = "position_b", palette = identity, name = name, breaks = breaks, + labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value, + n.breaks = n.breaks, nice.breaks = nice.breaks, right = right, trans = trans, + show.limits = show.limits, guide = "none", position = position, super = ScaleBinnedPosition + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, + after.stat = FALSE, + + train = function(self, x) { + if (!is.numeric(x)) { + stop("Binned scales only support continuous data", call. = FALSE) + } + + if (length(x) == 0 || self$after.stat) return() + self$range$train(x) + }, + + map = function(self, x, limits = self$get_limits()) { + breaks <- self$get_breaks(limits) + all_breaks <- unique(sort(c(limits[1], breaks, limits[2]))) + + if (self$after.stat) { + # Backtransform to original scale + x_binned <- cut(x, seq_len(length(all_breaks) + 1) - 0.5, + labels = FALSE, + include.lowest = TRUE, + right = self$right + ) + (x - x_binned + .5) * diff(all_breaks)[x_binned] + all_breaks[x_binned] + } else { + x <- as.numeric(self$oob(x, limits)) + x <- ifelse(!is.na(x), x, self$na.value) + x_binned <- cut(x, all_breaks, + labels = FALSE, + include.lowest = TRUE, + right = self$right + ) + + x_binned # Return integer form so stat treat it like a discrete scale + } + }, + reset = function(self) { + self$after.stat <- TRUE + limits <- self$get_limits() + breaks <- self$get_breaks(limits) + self$range$reset() + self$range$train(c(limits, breaks)) + }, + + get_breaks = function(self, limits = self$get_limits()) { + breaks <- ggproto_parent(ScaleBinned, self)$get_breaks(limits) + if (self$show.limits) { + breaks <- sort(unique(c(self$get_limits(), breaks))) + } + breaks + } +) diff --git a/R/scale-brewer.r b/R/scale-brewer.r index ccbfc869ac..aa5d95d11d 100644 --- a/R/scale-brewer.r +++ b/R/scale-brewer.r @@ -8,7 +8,8 @@ #' #' @note #' The `distiller` scales extend brewer to continuous scales by smoothly -#' interpolating 7 colours from any palette to a continuous scale. +#' interpolating 7 colours from any palette to a continuous scale. The `fermenter` +#' scales provide binned versions of the brewer scales. #' #' @details #' The `brewer` scales were carefully designed and tested on discrete data. @@ -32,9 +33,9 @@ #' @param palette If a string, will use that named palette. If a number, will index into #' the list of palettes of appropriate `type`. The list of available palettes can found #' in the Palettes section. -#' @param ... Other arguments passed on to [discrete_scale()] or, for -#' `distiller` scales, [continuous_scale()] to control name, -#' limits, breaks, labels and so forth. +#' @param ... Other arguments passed on to [discrete_scale()], [continuous_scale()], +#' or [binned_scale()], for `brewer`, `distiller`, and `fermenter` variants +#' respectively, to control name, limits, breaks, labels and so forth. #' @family colour scales #' @rdname scale_brewer #' @export @@ -69,6 +70,10 @@ #' v #' v + scale_fill_distiller() #' v + scale_fill_distiller(palette = "Spectral") +#' +#' # or use blender variants to discretize continuous data +#' v + scale_fill_fermenter() +#' scale_colour_brewer <- function(..., type = "seq", palette = 1, direction = 1, aesthetics = "colour") { discrete_scale(aesthetics, "brewer", brewer_pal(type, palette, direction), ...) } @@ -104,6 +109,27 @@ scale_fill_distiller <- function(..., type = "seq", palette = 1, direction = -1, gradient_n_pal(brewer_pal(type, palette, direction)(7), values, space), na.value = na.value, guide = guide, ...) } +#' @export +#' @rdname scale_brewer +scale_colour_fermenter <- function(..., type = "seq", palette = 1, direction = -1, na.value = "grey50", guide = "coloursteps", aesthetics = "colour") { + # warn about using a qualitative brewer palette to generate the gradient + type <- match.arg(type, c("seq", "div", "qual")) + if (type == "qual") { + warning("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + } + binned_scale(aesthetics, "fermenter", binned_pal(brewer_pal(type, palette, direction)), na.value = na.value, guide = guide, ...) +} + +#' @export +#' @rdname scale_brewer +scale_fill_fermenter <- function(..., type = "seq", palette = 1, direction = -1, na.value = "grey50", guide = "coloursteps", aesthetics = "fill") { + type <- match.arg(type, c("seq", "div", "qual")) + if (type == "qual") { + warning("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + } + binned_scale(aesthetics, "fermenter", binned_pal(brewer_pal(type, palette, direction)), na.value = na.value, guide = guide, ...) +} + # icon.brewer <- function() { # rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width = 0.21, # gp = gpar(fill = RColorBrewer::brewer.pal(5, "PuOr"), col = NA) diff --git a/R/scale-colour.r b/R/scale-colour.r index d50fb9e22c..e9637a9120 100644 --- a/R/scale-colour.r +++ b/R/scale-colour.r @@ -1,4 +1,4 @@ -#' Continuous colour scales +#' Continuous and binned colour scales #' #' Colour scales for continuous data default to the values of the #' `ggplot2.continuous.colour` and `ggplot2.continuous.fill` options. If these @@ -9,7 +9,8 @@ #' @param type One of "gradient" (the default) or "viridis" indicating the #' colour scale to use #' @seealso [scale_colour_gradient()], [scale_colour_viridis_c()], -#' [scale_fill_gradient()], and [scale_fill_viridis_c()] +#' [scale_colour_steps()], [scale_colour_viridis_b()], [scale_fill_gradient()], +#' [scale_fill_viridis_c()], [scale_fill_steps()], and [scale_fill_viridis_b()] #' @export #' @rdname scale_colour_continuous #' @section Color Blindness: @@ -58,3 +59,29 @@ scale_fill_continuous <- function(..., stop("Unknown scale type", call. = FALSE) ) } + +#' @export +#' @rdname scale_colour_continuous +#' @usage NULL +scale_colour_binned <- function(..., + type = getOption("ggplot2.continuous.colour", default = "gradient")) { + switch( + type, + gradient = scale_colour_steps(...), + viridis = scale_colour_viridis_b(...), + stop("Unknown scale type", call. = FALSE) + ) +} + +#' @export +#' @rdname scale_colour_continuous +#' @usage NULL +scale_fill_binned <- function(..., + type = getOption("ggplot2.continuous.colour", default = "gradient")) { + switch( + type, + gradient = scale_fill_steps(...), + viridis = scale_fill_viridis_b(...), + stop("Unknown scale type", call. = FALSE) + ) +} diff --git a/R/scale-linetype.r b/R/scale-linetype.r index 874c25d6ff..e7c7ac7d6e 100644 --- a/R/scale-linetype.r +++ b/R/scale-linetype.r @@ -2,7 +2,8 @@ #' #' Default line types based on a set supplied by Richard Pearson, #' University of Manchester. Continuous values can not be mapped to -#' line types. +#' line types unless `scale_linetype_binned()` is used. Still, as linetypes has +#' no inherent order, this use is not advised. #' #' @inheritParams scale_x_discrete #' @inheritDotParams discrete_scale -expand -position -na.value @@ -33,6 +34,12 @@ scale_linetype <- function(..., na.value = "blank") { na.value = na.value, ...) } +#' @rdname scale_linetype +#' @export +scale_linetype_binned <- function(..., na.value = "blank") { + binned_scale("linetype", "linetype_b", binned_pal(linetype_pal()), ...) +} + #' @rdname scale_linetype #' @export scale_linetype_continuous <- function(...) { diff --git a/R/scale-shape.r b/R/scale-shape.r index 2a7c8cabac..8c496f1d92 100644 --- a/R/scale-shape.r +++ b/R/scale-shape.r @@ -4,7 +4,8 @@ #' If you have more than six levels, you will get a warning message, and the #' seventh and subsequence levels will not appear on the plot. Use #' [scale_shape_manual()] to supply your own values. You can not map -#' a continuous variable to shape. +#' a continuous variable to shape unless `scale_shape_binned()` is used. Still, +#' as shape has no inherent order, this use is not advised.. #' #' @param solid Should the shapes be solid, `TRUE`, or hollow, #' `FALSE`? @@ -38,6 +39,12 @@ scale_shape <- function(..., solid = TRUE) { discrete_scale("shape", "shape_d", shape_pal(solid), ...) } +#' @rdname scale_shape +#' @export +scale_shape_binned <- function(..., solid = TRUE) { + binned_scale("shape", "shape_b", binned_pal(shape_pal(solid)), ...) +} + #' @rdname scale_shape #' @export #' @usage NULL diff --git a/R/scale-size.r b/R/scale-size.r index fafc562e88..ea6f81003a 100644 --- a/R/scale-size.r +++ b/R/scale-size.r @@ -4,10 +4,13 @@ #' aesthetic is most commonly used for points and text, and humans perceive #' the area of points (not their radius), so this provides for optimal #' perception. `scale_size_area` ensures that a value of 0 is mapped -#' to a size of 0. +#' to a size of 0. `scale_size_binned` is a binned version of `scale_size` that +#' scales by area (but does not ensure 0 equals an area of zero). For a binned +#' equivalent of `scale_size_area` use `scale_size_binned_area`. #' #' @name scale_size #' @inheritParams continuous_scale +#' @inheritParams binned_scale #' @param range a numeric vector of length 2 that specifies the minimum and #' maximum size of the plotting symbol after transformation. #' @seealso [scale_size_area()] if you want 0 values to be mapped @@ -22,6 +25,9 @@ #' # If you want zero value to have zero size, use scale_size_area: #' p + scale_size_area() #' +#' # Binning can sometimes make it easier to match the scaled data to the legend +#' p + scale_size_binned() +#' #' # This is most useful when size is a count #' ggplot(mpg, aes(class, cyl)) + #' geom_count() + @@ -42,6 +48,10 @@ scale_size_continuous <- function(name = waiver(), breaks = waiver(), labels = w guide = guide) } +#' @rdname scale_size +#' @export +scale_size <- scale_size_continuous + #' @rdname scale_size #' @export scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), @@ -54,7 +64,13 @@ scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), #' @rdname scale_size #' @export -scale_size <- scale_size_continuous +scale_size_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), + limits = NULL, range = c(1, 6), n.breaks = NULL, + nice.breaks = TRUE, trans = "identity", guide = "bins") { + binned_scale("size", "area_b", area_pal(range), name = name, + breaks = breaks, labels = labels, limits = limits, trans = trans, + n.breaks = n.breaks, nice.breaks = nice.breaks, guide = guide) +} #' @rdname scale_size #' @export @@ -91,6 +107,14 @@ scale_size_area <- function(..., max_size = 6) { rescaler = rescale_max, ...) } +#' @export +#' @rdname scale_size +scale_size_binned_area <- function(..., max_size = 6) { + binned_scale("size", "area_b", + palette = abs_area(max_size), + rescaler = rescale_max, ...) +} + #' @rdname scale_size #' @export #' @usage NULL diff --git a/R/scale-steps.R b/R/scale-steps.R new file mode 100644 index 0000000000..d671569754 --- /dev/null +++ b/R/scale-steps.R @@ -0,0 +1,91 @@ +#' Binned gradient colour scales +#' +#' `scale_*_steps` creates a two colour binned gradient (low-high), +#' `scale_*_steps2` creates a diverging binned colour gradient (low-mid-high), +#' and `scale_*_stepsn` creates a n-colour binned gradient. These scales are +#' binned variants of the [gradient scale][scale_colour_gradient] family and +#' works in the same way. +#' +#' Default colours are generated with \pkg{munsell} and +#' `mnsl(c("2.5PB 2/4", "2.5PB 7/10"))`. Generally, for continuous +#' colour scales you want to keep hue constant, but vary chroma and +#' luminance. The \pkg{munsell} package makes this easy to do using the +#' Munsell colour system. +#' +#' @inheritParams scale_colour_gradient +#' @inheritDotParams binned_scale -aesthetics -scale_name -palette -na.value -guide -rescaler +#' +#' @seealso [scales::seq_gradient_pal()] for details on underlying +#' palette +#' @family colour scales +#' @rdname scale_steps +#' @export +#' @examples +#' df <- data.frame( +#' x = runif(100), +#' y = runif(100), +#' z1 = rnorm(100) +#' ) +#' +#' # Use scale_colour_steps for a standard binned gradient +#' ggplot(df, aes(x, y)) + +#' geom_point(aes(colour = z1)) + +#' scale_colour_steps() +#' +#' # Get a divergent binned scale with the *2 variant +#' ggplot(df, aes(x, y)) + +#' geom_point(aes(colour = z1)) + +#' scale_colour_steps2() +#' +#' # Define your own colour ramp to extract binned colours from +#' ggplot(df, aes(x, y)) + +#' geom_point(aes(colour = z1)) + +#' scale_colour_stepsn(colours = terrain.colors(10)) +#' + +#' @rdname scale_steps +#' @export +scale_colour_steps <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "colour") { + binned_scale(aesthetics, "steps", seq_gradient_pal(low, high, space), + na.value = na.value, guide = guide, ...) +} +#' @rdname scale_steps +#' @export +scale_colour_steps2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), + midpoint = 0, space = "Lab", na.value = "grey50", guide = "coloursteps", + aesthetics = "colour") { + binned_scale(aesthetics, "steps2", div_gradient_pal(low, mid, high, space), + na.value = na.value, guide = guide, rescaler = mid_rescaler(mid = midpoint), ...) +} +#' @rdname scale_steps +#' @export +scale_colour_stepsn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", + guide = "coloursteps", aesthetics = "colour", colors) { + colours <- if (missing(colours)) colors else colours + binned_scale(aesthetics, "stepsn", + gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...) +} +#' @rdname scale_steps +#' @export +scale_fill_steps <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "fill") { + binned_scale(aesthetics, "steps", seq_gradient_pal(low, high, space), + na.value = na.value, guide = guide, ...) +} +#' @rdname scale_steps +#' @export +scale_fill_steps2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), + midpoint = 0, space = "Lab", na.value = "grey50", guide = "coloursteps", + aesthetics = "fill") { + binned_scale(aesthetics, "steps2", div_gradient_pal(low, mid, high, space), + na.value = na.value, guide = guide, rescaler = mid_rescaler(mid = midpoint), ...) +} +#' @rdname scale_steps +#' @export +scale_fill_stepsn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", + guide = "coloursteps", aesthetics = "fill", colors) { + colours <- if (missing(colours)) colors else colours + binned_scale(aesthetics, "stepsn", + gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...) +} diff --git a/R/scale-viridis.r b/R/scale-viridis.r index ef5da6b395..4b4dde093a 100644 --- a/R/scale-viridis.r +++ b/R/scale-viridis.r @@ -8,8 +8,9 @@ #' @inheritParams viridisLite::viridis #' @inheritParams scales::gradient_n_pal #' @inheritParams continuous_scale -#' @param ... Other arguments passed on to [discrete_scale()] or -#' [continuous_scale()] to control name, limits, breaks, labels and so forth. +#' @param ... Other arguments passed on to [discrete_scale()], +#' [continuous_scale()], or [binned_scale] to control name, limits, breaks, +#' labels and so forth. #' @param aesthetics Character string or vector of character strings listing the #' name(s) of the aesthetic(s) that this scale works with. This can be useful, for #' example, to apply colour settings to the `colour` and `fill` aesthetics at the @@ -50,6 +51,10 @@ #' geom_tile(aes(waiting, eruptions, fill = density))) #' v + scale_fill_viridis_c() #' v + scale_fill_viridis_c(option = "plasma") +#' +#' # Use viridis_b to bin continuous data before mapping +#' v + scale_fill_viridis_b() +#' scale_colour_viridis_d <- function(..., alpha = 1, begin = 0, end = 1, direction = 1, option = "D", aesthetics = "colour") { discrete_scale( @@ -111,3 +116,43 @@ scale_fill_viridis_c <- function(..., alpha = 1, begin = 0, end = 1, ... ) } + +#' @export +#' @rdname scale_viridis +scale_colour_viridis_b <- function(..., alpha = 1, begin = 0, end = 1, + direction = 1, option = "D", values = NULL, + space = "Lab", na.value = "grey50", + guide = "coloursteps", aesthetics = "colour") { + binned_scale( + aesthetics, + "viridis_b", + gradient_n_pal( + viridis_pal(alpha, begin, end, direction, option)(6), + values, + space + ), + na.value = na.value, + guide = guide, + ... + ) +} + +#' @export +#' @rdname scale_viridis +scale_fill_viridis_b <- function(..., alpha = 1, begin = 0, end = 1, + direction = 1, option = "D", values = NULL, + space = "Lab", na.value = "grey50", + guide = "coloursteps", aesthetics = "fill") { + binned_scale( + aesthetics, + "viridis_b", + gradient_n_pal( + viridis_pal(alpha, begin, end, direction, option)(6), + values, + space + ), + na.value = na.value, + guide = guide, + ... + ) +} diff --git a/R/utilities.r b/R/utilities.r index 6336ace4b8..29edb19f16 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -176,6 +176,12 @@ rescale01 <- function(x) { (x - rng[1]) / (rng[2] - rng[1]) } +binned_pal <- function(palette) { + function(x) { + palette(length(x)) + } +} + #' Give a deprecation error, warning, or message, depending on version number. #' #' This function is deprecated. diff --git a/R/zxx.r b/R/zxx.r index 28dc498ca1..b90bd9804c 100644 --- a/R/zxx.r +++ b/R/zxx.r @@ -125,11 +125,21 @@ scale_color_brewer <- scale_colour_brewer #' @usage NULL scale_color_distiller <- scale_colour_distiller +#' @export +#' @rdname scale_brewer +#' @usage NULL +scale_color_fermenter <- scale_colour_fermenter + #' @export #' @rdname scale_colour_continuous #' @usage NULL scale_color_continuous <- scale_colour_continuous +#' @export +#' @rdname scale_colour_continuous +#' @usage NULL +scale_color_binned <- scale_colour_binned + #' @export #' @rdname scale_hue #' @usage NULL @@ -150,6 +160,21 @@ scale_color_gradient2 <- scale_colour_gradient2 #' @usage NULL scale_color_gradientn <- scale_colour_gradientn +#' @export +#' @rdname scale_steps +#' @usage NULL +scale_color_steps <- scale_colour_steps + +#' @export +#' @rdname scale_steps +#' @usage NULL +scale_color_steps2 <- scale_colour_steps2 + +#' @export +#' @rdname scale_steps +#' @usage NULL +scale_color_stepsn <- scale_colour_stepsn + #' @export #' @rdname scale_grey #' @usage NULL diff --git a/man/binned_scale.Rd b/man/binned_scale.Rd new file mode 100644 index 0000000000..0da32bd185 --- /dev/null +++ b/man/binned_scale.Rd @@ -0,0 +1,123 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale-.r +\name{binned_scale} +\alias{binned_scale} +\title{Binning scale constructor} +\usage{ +binned_scale(aesthetics, scale_name, palette, name = waiver(), + breaks = waiver(), labels = waiver(), limits = NULL, + rescaler = rescale, oob = squish, expand = waiver(), + na.value = NA_real_, n.breaks = NULL, nice.breaks = TRUE, + right = TRUE, trans = "identity", show.limits = FALSE, + guide = "bins", position = "left", super = ScaleBinned) +} +\arguments{ +\item{aesthetics}{The names of the aesthetics that this scale works with.} + +\item{scale_name}{The name of the scale that should be used for error messages +associated with this scale.} + +\item{palette}{A palette function that when called with a numeric vector with +values between 0 and 1 returns the corresponding output values +(e.g., \code{\link[scales:area_pal]{scales::area_pal()}}).} + +\item{name}{The name of the scale. Used as the axis or legend title. If +\code{waiver()}, the default, the name of the scale is taken from the first +mapping used for that aesthetic. If \code{NULL}, the legend title will be +omitted.} + +\item{breaks}{One of: +\itemize{ +\item \code{NULL} for no breaks +\item \code{waiver()} for the default breaks computed by the +\link[scales:trans_new]{transformation object} +\item A numeric vector of positions +\item A function that takes the limits as input and returns breaks +as output (e.g., a function returned by \code{\link[scales:extended_breaks]{scales::extended_breaks()}}) +}} + +\item{labels}{One of: +\itemize{ +\item \code{NULL} for no labels +\item \code{waiver()} for the default labels computed by the +transformation object +\item A character vector giving labels (must be same length as \code{breaks}) +\item A function that takes the breaks as input and returns labels +as output +}} + +\item{limits}{One of: +\itemize{ +\item \code{NULL} to use the default scale range +\item A numeric vector of length two providing limits of the scale. +Use \code{NA} to refer to the existing minimum or maximum +\item A function that accepts the existing (automatic) limits and returns +new limits +Note that setting limits on positional scales will \strong{remove} data outside of the limits. +If the purpose is to zoom, use the limit argument in the coordinate system +(see \code{\link[=coord_cartesian]{coord_cartesian()}}). +}} + +\item{rescaler}{A function used to scale the input values to the +range [0, 1]. This is always \code{\link[scales:rescale]{scales::rescale()}}, except for +diverging and n colour gradients (i.e., \code{\link[=scale_colour_gradient2]{scale_colour_gradient2()}}, +\code{\link[=scale_colour_gradientn]{scale_colour_gradientn()}}). The \code{rescaler} is ignored by position +scales, which ways use \code{\link[scales:rescale]{scales::rescale()}}.} + +\item{oob}{One of: +\itemize{ +\item Function that handles limits outside of the scale limits +(out of bounds). +\item The default (\code{\link[scales:censor]{scales::censor()}}) replaces out of +bounds values with \code{NA}. +\item \code{\link[scales:squish]{scales::squish()}} for squishing out of bounds values into range. +\item \code{\link[scales:squish_infinite]{scales::squish_infinite()}} for squishing infitite values into range. +}} + +\item{expand}{For position scales, a vector of range expansion constants used to add some +padding around the data to ensure that they are placed some distance +away from the axes. Use the convenience function \code{\link[=expansion]{expansion()}} +to generate the values for the \code{expand} argument. The defaults are to +expand the scale by 5\% on each side for continuous variables, and by +0.6 units on each side for discrete variables.} + +\item{na.value}{Missing values will be replaced with this value.} + +\item{n.breaks}{The number of break points to create if breaks are not given +directly.} + +\item{nice.breaks}{Logical. Should breaks be attempted placed at nice values +instead of exactly evenly spaced between the limits. If \code{TRUE} (default) +the scale will ask the transformation object to create breaks, and this +may result in a different number of breaks than requested. Ignored if +breaks are given explicetly.} + +\item{right}{Should values on the border between bins be part of the right +(upper) bin?} + +\item{trans}{For continuous scales, the name of a transformation object +or the object itself. Built-in transformations include "asn", "atanh", +"boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2", +"logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal", +"reverse", "sqrt" and "time". + +A transformation object bundles together a transform, its inverse, +and methods for generating breaks and labels. Transformation objects +are defined in the scales package, and are called \code{_trans} (e.g., +\code{\link[scales:boxcox_trans]{scales::boxcox_trans()}}). You can create your own +transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.} + +\item{show.limits}{should the limits of the scale appear as ticks} + +\item{guide}{A function used to create a guide or its name. See +\code{\link[=guides]{guides()}} for more information.} + +\item{position}{For position scales, The position of the axis. +\code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} + +\item{super}{The super class to use for the constructed scale} +} +\description{ +Binning scale constructor +} +\keyword{internal} diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index df35148ece..75605bc356 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -15,14 +15,14 @@ % R/geom-vline.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-continuous.r, R/scale-date.r, R/scale-discrete-.r, -% R/scale-identity.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-qq-line.R, R/stat-qq.r, -% R/stat-quantile.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/scale-.r, R/scale-binned.R, R/scale-continuous.r, R/scale-date.r, +% R/scale-discrete-.r, R/scale-identity.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-qq-line.R, +% R/stat-qq.r, R/stat-quantile.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} @@ -95,6 +95,8 @@ \alias{Scale} \alias{ScaleContinuous} \alias{ScaleDiscrete} +\alias{ScaleBinned} +\alias{ScaleBinnedPosition} \alias{ScaleContinuousPosition} \alias{ScaleContinuousDatetime} \alias{ScaleContinuousDate} diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd new file mode 100644 index 0000000000..13e0bce1fc --- /dev/null +++ b/man/guide_bins.Rd @@ -0,0 +1,130 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide-bins.R +\name{guide_bins} +\alias{guide_bins} +\title{A binned version of guide_legend} +\usage{ +guide_bins(title = waiver(), title.position = NULL, + title.theme = NULL, title.hjust = NULL, title.vjust = NULL, + label = TRUE, label.position = NULL, label.theme = NULL, + label.hjust = NULL, label.vjust = NULL, keywidth = NULL, + keyheight = NULL, axis = TRUE, axis.colour = "black", + axis.linewidth = 0.5, axis.arrow = NULL, direction = NULL, + default.unit = "line", override.aes = list(), reverse = FALSE, + order = 0, show.limits = NULL, ...) +} +\arguments{ +\item{title}{A character string or expression indicating a title of guide. +If \code{NULL}, the title is not shown. By default +(\code{\link[=waiver]{waiver()}}), the name of the scale object or the name +specified in \code{\link[=labs]{labs()}} is used for the title.} + +\item{title.position}{A character string indicating the position of a +title. One of "top" (default for a vertical guide), "bottom", "left" +(default for a horizontal guide), or "right."} + +\item{title.theme}{A theme object for rendering the title text. Usually the +object of \code{\link[=element_text]{element_text()}} is expected. By default, the theme is +specified by \code{legend.title} in \code{\link[=theme]{theme()}} or theme.} + +\item{title.hjust}{A number specifying horizontal justification of the +title text.} + +\item{title.vjust}{A number specifying vertical justification of the title +text.} + +\item{label}{logical. If \code{TRUE} then the labels are drawn. If +\code{FALSE} then the labels are invisible.} + +\item{label.position}{A character string indicating the position of a +label. One of "top", "bottom" (default for horizontal guide), "left", or +"right" (default for vertical guide).} + +\item{label.theme}{A theme object for rendering the label text. Usually the +object of \code{\link[=element_text]{element_text()}} is expected. By default, the theme is +specified by \code{legend.text} in \code{\link[=theme]{theme()}}.} + +\item{label.hjust}{A numeric specifying horizontal justification of the +label text.} + +\item{label.vjust}{A numeric specifying vertical justification of the label +text.} + +\item{keywidth}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying +the width of the legend key. Default value is \code{legend.key.width} or +\code{legend.key.size} in \code{\link[=theme]{theme()}}.} + +\item{keyheight}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying +the height of the legend key. Default value is \code{legend.key.height} or +\code{legend.key.size} in \code{\link[=theme]{theme()}}.} + +\item{axis}{Logical. Should a small axis be drawn along the guide} + +\item{axis.colour, axis.linewidth}{Graphic specifications for the look of the +axis.} + +\item{axis.arrow}{A call to \code{arrow()} to specify arrows at the end of the +axis line, thus showing an open interval.} + +\item{direction}{A character string indicating the direction of the guide. +One of "horizontal" or "vertical."} + +\item{default.unit}{A character string indicating \code{\link[grid:unit]{grid::unit()}} +for \code{keywidth} and \code{keyheight}.} + +\item{override.aes}{A list specifying aesthetic parameters of legend key. +See details and examples.} + +\item{reverse}{logical. If \code{TRUE} the order of legends is reversed.} + +\item{order}{positive integer less than 99 that specifies the order of +this guide among multiple guides. This controls the order in which +multiple guides are displayed, not the contents of the guide itself. +If 0 (default), the order is determined by a secret algorithm.} + +\item{show.limits}{Logical. Should the limits of the scale be shown with +labels and ticks.} + +\item{...}{ignored.} +} +\value{ +A guide object +} +\description{ +This guide is a version of the \code{\link[=guide_legend]{guide_legend()}} guide for binned scales. It +differs in that it places ticks correctly between the keys, and sports a +small axis to better show the binning. Like \code{\link[=guide_legend]{guide_legend()}} it can be used +for all non-position aesthetics though colour and fill defaults to +\code{\link[=guide_coloursteps]{guide_coloursteps()}}, and it will merge aesthetics together into the same +guide if they are mapped in the same way. +} +\examples{ +p <- ggplot(mtcars) + + geom_point(aes(disp, mpg, size = hp)) + + scale_size_binned() + +# Standard look +p + +# Remove the axis or style it +p + guides(size = guide_bins(axis = FALSE)) + +p + guides(size = guide_bins(show.limits = TRUE)) + +p + guides(size = guide_bins( + axis.arrow = arrow(length = unit(1.5, 'mm'), ends = 'both') +)) + +# Guides are merged together if possible +ggplot(mtcars) + + geom_point(aes(disp, mpg, size = hp, colour = hp)) + + scale_size_binned() + + scale_colour_binned(guide = "bins") + +} +\seealso{ +Other guides: \code{\link{guide_colourbar}}, + \code{\link{guide_coloursteps}}, + \code{\link{guide_legend}}, \code{\link{guides}} +} +\concept{guides} diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index 63330959ff..c7eebdfa4d 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -186,7 +186,8 @@ p2 + scale_size(guide = guide_legend(direction = "vertical")) } \seealso{ -Other guides: \code{\link{guide_legend}}, - \code{\link{guides}} +Other guides: \code{\link{guide_bins}}, + \code{\link{guide_coloursteps}}, + \code{\link{guide_legend}}, \code{\link{guides}} } \concept{guides} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd new file mode 100644 index 0000000000..dd73dfff61 --- /dev/null +++ b/man/guide_coloursteps.Rd @@ -0,0 +1,120 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide-colorsteps.R +\name{guide_coloursteps} +\alias{guide_coloursteps} +\alias{guide_colorsteps} +\title{Discretized colourbar guide} +\usage{ +guide_coloursteps(even.steps = TRUE, show.limits = NULL, + ticks = FALSE, ...) + +guide_colorsteps(even.steps = TRUE, show.limits = NULL, + ticks = FALSE, ...) +} +\arguments{ +\item{even.steps}{Should the rendered size of the bins be equal, or should +they be proportional to their length in the data space? Defaults to \code{TRUE}} + +\item{show.limits}{Should labels for the outer limits of the bins be printed? +Default is \code{NULL} which makes the guide use the setting from the scale} + +\item{ticks}{A logical specifying if tick marks on the colourbar should be +visible.} + +\item{...}{Arguments passed on to \code{guide_colourbar} +\describe{ + \item{barwidth}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying +the width of the colourbar. Default value is \code{legend.key.width} or +\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} + \item{barheight}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying +the height of the colourbar. Default value is \code{legend.key.height} or +\code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} + \item{frame.colour}{A string specifying the colour of the frame +drawn around the bar. If \code{NULL} (the default), no frame is drawn.} + \item{frame.linewidth}{A numeric specifying the width of the frame +drawn around the bar.} + \item{frame.linetype}{A numeric specifying the linetype of the frame +drawn around the bar.} + \item{ticks.colour}{A string specifying the colour of the tick marks.} + \item{ticks.linewidth}{A numeric specifying the width of the tick marks.} + \item{draw.ulim}{A logical specifying if the upper limit tick marks should +be visible.} + \item{draw.llim}{A logical specifying if the lower limit tick marks should +be visible.} + \item{direction}{A character string indicating the direction of the guide. +One of "horizontal" or "vertical."} + \item{default.unit}{A character string indicating \code{\link[grid:unit]{grid::unit()}} +for \code{barwidth} and \code{barheight}.} + \item{reverse}{logical. If \code{TRUE} the colourbar is reversed. By default, +the highest value is on the top and the lowest value is on the bottom} + \item{title}{A character string or expression indicating a title of guide. +If \code{NULL}, the title is not shown. By default +(\code{\link[=waiver]{waiver()}}), the name of the scale object or the name +specified in \code{\link[=labs]{labs()}} is used for the title.} + \item{title.position}{A character string indicating the position of a +title. One of "top" (default for a vertical guide), "bottom", "left" +(default for a horizontal guide), or "right."} + \item{title.theme}{A theme object for rendering the title text. Usually the +object of \code{\link[=element_text]{element_text()}} is expected. By default, the theme is +specified by \code{legend.title} in \code{\link[=theme]{theme()}} or theme.} + \item{title.hjust}{A number specifying horizontal justification of the +title text.} + \item{title.vjust}{A number specifying vertical justification of the title +text.} + \item{label}{logical. If \code{TRUE} then the labels are drawn. If +\code{FALSE} then the labels are invisible.} + \item{label.position}{A character string indicating the position of a +label. One of "top", "bottom" (default for horizontal guide), "left", or +"right" (default for vertical guide).} + \item{label.theme}{A theme object for rendering the label text. Usually the +object of \code{\link[=element_text]{element_text()}} is expected. By default, the theme is +specified by \code{legend.text} in \code{\link[=theme]{theme()}}.} + \item{label.hjust}{A numeric specifying horizontal justification of the +label text.} + \item{label.vjust}{A numeric specifying vertical justification of the label +text.} + \item{order}{positive integer less than 99 that specifies the order of +this guide among multiple guides. This controls the order in which +multiple guides are displayed, not the contents of the guide itself. +If 0 (default), the order is determined by a secret algorithm.} +}} +} +\value{ +A guide object +} +\description{ +This guide is version of \code{\link[=guide_colourbar]{guide_colourbar()}} for binned colour and fill +scales. It shows areas between breaks as a single constant colour instead of +the gradient known from the colourbar counterpart. +} +\examples{ +df <- reshape2::melt(outer(1:10, 1:10), varnames = c("X1", "X2")) + +p <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value)) + +# Coloursteps guide is the default for binned colour scales +p + scale_fill_binned() + +# By default each bin in the guide is the same size irrespectively of how +# their sizes relate in data space +p + scale_fill_binned(breaks = c(10, 25, 50)) + +# This can be changed with the `even.steps` argument +p + scale_fill_binned( + breaks = c(10, 25, 50), + guide = guide_coloursteps(even.steps = FALSE) +) + +# By default the limits is not shown, but this can be changed +p + scale_fill_binned(guide = guide_coloursteps(show.limits = TRUE)) + +# (can also be set in the scale) +p + scale_fill_binned(show.limits = TRUE) + +} +\seealso{ +Other guides: \code{\link{guide_bins}}, + \code{\link{guide_colourbar}}, + \code{\link{guide_legend}}, \code{\link{guides}} +} +\concept{guides} diff --git a/man/guide_legend.Rd b/man/guide_legend.Rd index bd53036d09..7dadfbfc52 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.Rd @@ -157,7 +157,8 @@ p + guides(col = guide_legend(reverse = TRUE)) } } \seealso{ -Other guides: \code{\link{guide_colourbar}}, - \code{\link{guides}} +Other guides: \code{\link{guide_bins}}, + \code{\link{guide_colourbar}}, + \code{\link{guide_coloursteps}}, \code{\link{guides}} } \concept{guides} diff --git a/man/guides.Rd b/man/guides.Rd index b3f01d6c70..43928a73cd 100644 --- a/man/guides.Rd +++ b/man/guides.Rd @@ -68,7 +68,9 @@ ggplot(mpg, aes(displ, cty)) + } } \seealso{ -Other guides: \code{\link{guide_colourbar}}, +Other guides: \code{\link{guide_bins}}, + \code{\link{guide_colourbar}}, + \code{\link{guide_coloursteps}}, \code{\link{guide_legend}} } \concept{guides} diff --git a/man/scale_alpha.Rd b/man/scale_alpha.Rd index fdd86fffc4..93f1da10ca 100644 --- a/man/scale_alpha.Rd +++ b/man/scale_alpha.Rd @@ -3,6 +3,7 @@ \name{scale_alpha} \alias{scale_alpha} \alias{scale_alpha_continuous} +\alias{scale_alpha_binned} \alias{scale_alpha_discrete} \alias{scale_alpha_ordinal} \alias{scale_alpha_datetime} @@ -13,12 +14,14 @@ scale_alpha(..., range = c(0.1, 1)) scale_alpha_continuous(..., range = c(0.1, 1)) +scale_alpha_binned(..., range = c(0.1, 1)) + scale_alpha_discrete(...) scale_alpha_ordinal(..., range = c(0.1, 1)) } \arguments{ -\item{...}{Other arguments passed on to \code{\link[=continuous_scale]{continuous_scale()}} +\item{...}{Other arguments passed on to \code{\link[=continuous_scale]{continuous_scale()}}, \link{binned_scale}, or \code{\link[=discrete_scale]{discrete_scale()}} as appropriate, to control name, limits, breaks, labels and so forth.} @@ -43,6 +46,7 @@ Other colour scales: \code{\link{scale_colour_brewer}}, \code{\link{scale_colour_gradient}}, \code{\link{scale_colour_grey}}, \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_steps}}, \code{\link{scale_colour_viridis_d}} } \concept{colour scales} diff --git a/man/scale_binned.Rd b/man/scale_binned.Rd new file mode 100644 index 0000000000..1227d3e7a1 --- /dev/null +++ b/man/scale_binned.Rd @@ -0,0 +1,123 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale-binned.R +\name{scale_binned} +\alias{scale_x_binned} +\alias{scale_y_binned} +\title{Positional scales for binning continuous data (x & y)} +\usage{ +scale_x_binned(name = waiver(), n.breaks = 10, nice.breaks = TRUE, + breaks = waiver(), labels = waiver(), limits = NULL, + expand = waiver(), oob = squish, na.value = NA_real_, + right = TRUE, show.limits = FALSE, trans = "identity", + position = "bottom") + +scale_y_binned(name = waiver(), n.breaks = 10, nice.breaks = TRUE, + breaks = waiver(), labels = waiver(), limits = NULL, + expand = waiver(), oob = squish, na.value = NA_real_, + right = TRUE, show.limits = FALSE, trans = "identity", + position = "left") +} +\arguments{ +\item{name}{The name of the scale. Used as the axis or legend title. If +\code{waiver()}, the default, the name of the scale is taken from the first +mapping used for that aesthetic. If \code{NULL}, the legend title will be +omitted.} + +\item{n.breaks}{The number of break points to create if breaks are not given +directly.} + +\item{nice.breaks}{Logical. Should breaks be attempted placed at nice values +instead of exactly evenly spaced between the limits. If \code{TRUE} (default) +the scale will ask the transformation object to create breaks, and this +may result in a different number of breaks than requested. Ignored if +breaks are given explicetly.} + +\item{breaks}{One of: +\itemize{ +\item \code{NULL} for no breaks +\item \code{waiver()} for the default breaks computed by the +\link[scales:trans_new]{transformation object} +\item A numeric vector of positions +\item A function that takes the limits as input and returns breaks +as output (e.g., a function returned by \code{\link[scales:extended_breaks]{scales::extended_breaks()}}) +}} + +\item{labels}{One of: +\itemize{ +\item \code{NULL} for no labels +\item \code{waiver()} for the default labels computed by the +transformation object +\item A character vector giving labels (must be same length as \code{breaks}) +\item A function that takes the breaks as input and returns labels +as output +}} + +\item{limits}{One of: +\itemize{ +\item \code{NULL} to use the default scale range +\item A numeric vector of length two providing limits of the scale. +Use \code{NA} to refer to the existing minimum or maximum +\item A function that accepts the existing (automatic) limits and returns +new limits +Note that setting limits on positional scales will \strong{remove} data outside of the limits. +If the purpose is to zoom, use the limit argument in the coordinate system +(see \code{\link[=coord_cartesian]{coord_cartesian()}}). +}} + +\item{expand}{For position scales, a vector of range expansion constants used to add some +padding around the data to ensure that they are placed some distance +away from the axes. Use the convenience function \code{\link[=expansion]{expansion()}} +to generate the values for the \code{expand} argument. The defaults are to +expand the scale by 5\% on each side for continuous variables, and by +0.6 units on each side for discrete variables.} + +\item{oob}{One of: +\itemize{ +\item Function that handles limits outside of the scale limits +(out of bounds). +\item The default (\code{\link[scales:censor]{scales::censor()}}) replaces out of +bounds values with \code{NA}. +\item \code{\link[scales:squish]{scales::squish()}} for squishing out of bounds values into range. +\item \code{\link[scales:squish_infinite]{scales::squish_infinite()}} for squishing infitite values into range. +}} + +\item{na.value}{Missing values will be replaced with this value.} + +\item{right}{Should values on the border between bins be part of the right +(upper) bin?} + +\item{show.limits}{should the limits of the scale appear as ticks} + +\item{trans}{For continuous scales, the name of a transformation object +or the object itself. Built-in transformations include "asn", "atanh", +"boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2", +"logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal", +"reverse", "sqrt" and "time". + +A transformation object bundles together a transform, its inverse, +and methods for generating breaks and labels. Transformation objects +are defined in the scales package, and are called \code{_trans} (e.g., +\code{\link[scales:boxcox_trans]{scales::boxcox_trans()}}). You can create your own +transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.} + +\item{position}{For position scales, The position of the axis. +\code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} +} +\description{ +\code{scale_x_binned()} and \code{scale_y_binned()} are scales that discretize +continuous position data. You can use these scales to transform continuous +inputs before using it with a geom that requires discrete positions. An +example is using \code{scale_x_binned()} with \code{\link[=geom_bar]{geom_bar()}} to create a histogram. +} +\examples{ +# Create a histogram by binning the x-axis +ggplot(mtcars) + + geom_bar(aes(mpg)) + + scale_x_binned() +} +\seealso{ +Other position scales: \code{\link{scale_x_continuous}}, + \code{\link{scale_x_date}}, + \code{\link{scale_x_discrete}} +} +\concept{position scales} diff --git a/man/scale_brewer.Rd b/man/scale_brewer.Rd index c44e785402..dffed48fe3 100644 --- a/man/scale_brewer.Rd +++ b/man/scale_brewer.Rd @@ -5,8 +5,11 @@ \alias{scale_fill_brewer} \alias{scale_colour_distiller} \alias{scale_fill_distiller} +\alias{scale_colour_fermenter} +\alias{scale_fill_fermenter} \alias{scale_color_brewer} \alias{scale_color_distiller} +\alias{scale_color_fermenter} \title{Sequential, diverging and qualitative colour scales from colorbrewer.org} \usage{ scale_colour_brewer(..., type = "seq", palette = 1, direction = 1, @@ -22,11 +25,18 @@ scale_colour_distiller(..., type = "seq", palette = 1, scale_fill_distiller(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", aesthetics = "fill") + +scale_colour_fermenter(..., type = "seq", palette = 1, + direction = -1, na.value = "grey50", guide = "coloursteps", + aesthetics = "colour") + +scale_fill_fermenter(..., type = "seq", palette = 1, direction = -1, + na.value = "grey50", guide = "coloursteps", aesthetics = "fill") } \arguments{ -\item{...}{Other arguments passed on to \code{\link[=discrete_scale]{discrete_scale()}} or, for -\code{distiller} scales, \code{\link[=continuous_scale]{continuous_scale()}} to control name, -limits, breaks, labels and so forth.} +\item{...}{Other arguments passed on to \code{\link[=discrete_scale]{discrete_scale()}}, \code{\link[=continuous_scale]{continuous_scale()}}, +or \code{\link[=binned_scale]{binned_scale()}}, for \code{brewer}, \code{distiller}, and \code{fermenter} variants +respectively, to control name, limits, breaks, labels and so forth.} \item{type}{One of seq (sequential), div (diverging) or qual (qualitative)} @@ -69,7 +79,8 @@ look good. Your mileage may vary. } \note{ The \code{distiller} scales extend brewer to continuous scales by smoothly -interpolating 7 colours from any palette to a continuous scale. +interpolating 7 colours from any palette to a continuous scale. The \code{fermenter} +scales provide binned versions of the brewer scales. } \section{Palettes}{ @@ -114,12 +125,17 @@ v <- ggplot(faithfuld) + v v + scale_fill_distiller() v + scale_fill_distiller(palette = "Spectral") + +# or use blender variants to discretize continuous data +v + scale_fill_fermenter() + } \seealso{ Other colour scales: \code{\link{scale_alpha}}, \code{\link{scale_colour_gradient}}, \code{\link{scale_colour_grey}}, \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_steps}}, \code{\link{scale_colour_viridis_d}} } \concept{colour scales} diff --git a/man/scale_colour_continuous.Rd b/man/scale_colour_continuous.Rd index f0ad9fba5a..a1b5753848 100644 --- a/man/scale_colour_continuous.Rd +++ b/man/scale_colour_continuous.Rd @@ -3,8 +3,11 @@ \name{scale_colour_continuous} \alias{scale_colour_continuous} \alias{scale_fill_continuous} +\alias{scale_colour_binned} +\alias{scale_fill_binned} \alias{scale_color_continuous} -\title{Continuous colour scales} +\alias{scale_color_binned} +\title{Continuous and binned colour scales} \usage{ scale_colour_continuous(..., type = getOption("ggplot2.continuous.colour", default = "gradient")) @@ -57,5 +60,6 @@ v + scale_fill_viridis_c() } \seealso{ \code{\link[=scale_colour_gradient]{scale_colour_gradient()}}, \code{\link[=scale_colour_viridis_c]{scale_colour_viridis_c()}}, -\code{\link[=scale_fill_gradient]{scale_fill_gradient()}}, and \code{\link[=scale_fill_viridis_c]{scale_fill_viridis_c()}} +\code{\link[=scale_colour_steps]{scale_colour_steps()}}, \code{\link[=scale_colour_viridis_b]{scale_colour_viridis_b()}}, \code{\link[=scale_fill_gradient]{scale_fill_gradient()}}, +\code{\link[=scale_fill_viridis_c]{scale_fill_viridis_c()}}, \code{\link[=scale_fill_steps]{scale_fill_steps()}}, and \code{\link[=scale_fill_viridis_b]{scale_fill_viridis_b()}} } diff --git a/man/scale_continuous.Rd b/man/scale_continuous.Rd index 925196344c..c853b8c83d 100644 --- a/man/scale_continuous.Rd +++ b/man/scale_continuous.Rd @@ -188,7 +188,8 @@ p1 + scale_y_continuous(trans = scales::reciprocal_trans()) } \seealso{ -Other position scales: \code{\link{scale_x_date}}, +Other position scales: \code{\link{scale_x_binned}}, + \code{\link{scale_x_date}}, \code{\link{scale_x_discrete}} } \concept{position scales} diff --git a/man/scale_date.Rd b/man/scale_date.Rd index 444a4cacd2..8e0391d7ce 100644 --- a/man/scale_date.Rd +++ b/man/scale_date.Rd @@ -160,7 +160,8 @@ base + scale_x_date(limits = c(Sys.Date() - 7, NA)) \seealso{ \code{\link[=sec_axis]{sec_axis()}} for how to specify secondary axes -Other position scales: \code{\link{scale_x_continuous}}, +Other position scales: \code{\link{scale_x_binned}}, + \code{\link{scale_x_continuous}}, \code{\link{scale_x_discrete}} } \concept{position scales} diff --git a/man/scale_discrete.Rd b/man/scale_discrete.Rd index cd73d626b1..3284d62b76 100644 --- a/man/scale_discrete.Rd +++ b/man/scale_discrete.Rd @@ -124,7 +124,8 @@ ggplot(mpg, aes(reorder(manufacturer, displ), cty)) + } } \seealso{ -Other position scales: \code{\link{scale_x_continuous}}, +Other position scales: \code{\link{scale_x_binned}}, + \code{\link{scale_x_continuous}}, \code{\link{scale_x_date}} } \concept{position scales} diff --git a/man/scale_gradient.Rd b/man/scale_gradient.Rd index ad3ef69a5d..d59e93fff7 100644 --- a/man/scale_gradient.Rd +++ b/man/scale_gradient.Rd @@ -225,6 +225,7 @@ Other colour scales: \code{\link{scale_alpha}}, \code{\link{scale_colour_brewer}}, \code{\link{scale_colour_grey}}, \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_steps}}, \code{\link{scale_colour_viridis_d}} } \concept{colour scales} diff --git a/man/scale_grey.Rd b/man/scale_grey.Rd index 0f4b1c491b..3e55326b3e 100644 --- a/man/scale_grey.Rd +++ b/man/scale_grey.Rd @@ -103,6 +103,7 @@ Other colour scales: \code{\link{scale_alpha}}, \code{\link{scale_colour_brewer}}, \code{\link{scale_colour_gradient}}, \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_steps}}, \code{\link{scale_colour_viridis_d}} } \concept{colour scales} diff --git a/man/scale_hue.Rd b/man/scale_hue.Rd index e5c5d6ff36..6a5f5dcde5 100644 --- a/man/scale_hue.Rd +++ b/man/scale_hue.Rd @@ -136,6 +136,7 @@ Other colour scales: \code{\link{scale_alpha}}, \code{\link{scale_colour_brewer}}, \code{\link{scale_colour_gradient}}, \code{\link{scale_colour_grey}}, + \code{\link{scale_colour_steps}}, \code{\link{scale_colour_viridis_d}} } \concept{colour scales} diff --git a/man/scale_linetype.Rd b/man/scale_linetype.Rd index dd4588a11e..2a82557802 100644 --- a/man/scale_linetype.Rd +++ b/man/scale_linetype.Rd @@ -2,12 +2,15 @@ % Please edit documentation in R/scale-linetype.r \name{scale_linetype} \alias{scale_linetype} +\alias{scale_linetype_binned} \alias{scale_linetype_continuous} \alias{scale_linetype_discrete} \title{Scale for line patterns} \usage{ scale_linetype(..., na.value = "blank") +scale_linetype_binned(..., na.value = "blank") + scale_linetype_continuous(...) scale_linetype_discrete(..., na.value = "blank") @@ -60,7 +63,8 @@ as output \description{ Default line types based on a set supplied by Richard Pearson, University of Manchester. Continuous values can not be mapped to -line types. +line types unless \code{scale_linetype_binned()} is used. Still, as linetypes has +no inherent order, this use is not advised. } \examples{ base <- ggplot(economics_long, aes(date, value01)) diff --git a/man/scale_shape.Rd b/man/scale_shape.Rd index 2763e5e984..049aaf06ec 100644 --- a/man/scale_shape.Rd +++ b/man/scale_shape.Rd @@ -2,12 +2,15 @@ % Please edit documentation in R/scale-shape.r \name{scale_shape} \alias{scale_shape} +\alias{scale_shape_binned} \alias{scale_shape_discrete} \alias{scale_shape_ordinal} \alias{scale_shape_continuous} \title{Scales for shapes, aka glyphs} \usage{ scale_shape(..., solid = TRUE) + +scale_shape_binned(..., solid = TRUE) } \arguments{ \item{...}{Arguments passed on to \code{discrete_scale} @@ -63,7 +66,8 @@ as output If you have more than six levels, you will get a warning message, and the seventh and subsequence levels will not appear on the plot. Use \code{\link[=scale_shape_manual]{scale_shape_manual()}} to supply your own values. You can not map -a continuous variable to shape. +a continuous variable to shape unless \code{scale_shape_binned()} is used. Still, +as shape has no inherent order, this use is not advised.. } \examples{ dsmall <- diamonds[sample(nrow(diamonds), 100), ] diff --git a/man/scale_size.Rd b/man/scale_size.Rd index 17614721fc..31c659c4e7 100644 --- a/man/scale_size.Rd +++ b/man/scale_size.Rd @@ -4,22 +4,31 @@ \alias{scale_size} \alias{scale_size_continuous} \alias{scale_radius} +\alias{scale_size_binned} \alias{scale_size_discrete} \alias{scale_size_ordinal} \alias{scale_size_area} +\alias{scale_size_binned_area} \alias{scale_size_datetime} \alias{scale_size_date} \title{Scales for area or radius} \usage{ -scale_radius(name = waiver(), breaks = waiver(), labels = waiver(), +scale_size(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = c(1, 6), trans = "identity", guide = "legend") -scale_size(name = waiver(), breaks = waiver(), labels = waiver(), +scale_radius(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = c(1, 6), trans = "identity", guide = "legend") +scale_size_binned(name = waiver(), breaks = waiver(), + labels = waiver(), limits = NULL, range = c(1, 6), + n.breaks = NULL, nice.breaks = TRUE, trans = "identity", + guide = "bins") + scale_size_area(..., max_size = 6) + +scale_size_binned_area(..., max_size = 6) } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -77,6 +86,15 @@ transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.} \item{guide}{A function used to create a guide or its name. See \code{\link[=guides]{guides()}} for more information.} +\item{n.breaks}{The number of break points to create if breaks are not given +directly.} + +\item{nice.breaks}{Logical. Should breaks be attempted placed at nice values +instead of exactly evenly spaced between the limits. If \code{TRUE} (default) +the scale will ask the transformation object to create breaks, and this +may result in a different number of breaks than requested. Ignored if +breaks are given explicetly.} + \item{...}{Arguments passed on to \code{continuous_scale} \describe{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -161,7 +179,9 @@ expand the scale by 5\% on each side for continuous variables, and by aesthetic is most commonly used for points and text, and humans perceive the area of points (not their radius), so this provides for optimal perception. \code{scale_size_area} ensures that a value of 0 is mapped -to a size of 0. +to a size of 0. \code{scale_size_binned} is a binned version of \code{scale_size} that +scales by area (but does not ensure 0 equals an area of zero). For a binned +equivalent of \code{scale_size_area} use \code{scale_size_binned_area}. } \examples{ p <- ggplot(mpg, aes(displ, hwy, size = hwy)) + @@ -173,6 +193,9 @@ p + scale_size(range = c(0, 10)) # If you want zero value to have zero size, use scale_size_area: p + scale_size_area() +# Binning can sometimes make it easier to match the scaled data to the legend +p + scale_size_binned() + # This is most useful when size is a count ggplot(mpg, aes(class, cyl)) + geom_count() + diff --git a/man/scale_steps.Rd b/man/scale_steps.Rd new file mode 100644 index 0000000000..9155ee3357 --- /dev/null +++ b/man/scale_steps.Rd @@ -0,0 +1,195 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale-steps.R, R/zxx.r +\name{scale_colour_steps} +\alias{scale_colour_steps} +\alias{scale_colour_steps2} +\alias{scale_colour_stepsn} +\alias{scale_fill_steps} +\alias{scale_fill_steps2} +\alias{scale_fill_stepsn} +\alias{scale_color_steps} +\alias{scale_color_steps2} +\alias{scale_color_stepsn} +\title{Binned gradient colour scales} +\usage{ +scale_colour_steps(..., low = "#132B43", high = "#56B1F7", + space = "Lab", na.value = "grey50", guide = "coloursteps", + aesthetics = "colour") + +scale_colour_steps2(..., low = muted("red"), mid = "white", + high = muted("blue"), midpoint = 0, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "colour") + +scale_colour_stepsn(..., colours, values = NULL, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "colour", + colors) + +scale_fill_steps(..., low = "#132B43", high = "#56B1F7", + space = "Lab", na.value = "grey50", guide = "coloursteps", + aesthetics = "fill") + +scale_fill_steps2(..., low = muted("red"), mid = "white", + high = muted("blue"), midpoint = 0, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "fill") + +scale_fill_stepsn(..., colours, values = NULL, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "fill", + colors) +} +\arguments{ +\item{...}{Arguments passed on to \code{binned_scale} +\describe{ + \item{n.breaks}{The number of break points to create if breaks are not given +directly.} + \item{nice.breaks}{Logical. Should breaks be attempted placed at nice values +instead of exactly evenly spaced between the limits. If \code{TRUE} (default) +the scale will ask the transformation object to create breaks, and this +may result in a different number of breaks than requested. Ignored if +breaks are given explicetly.} + \item{right}{Should values on the border between bins be part of the right +(upper) bin?} + \item{show.limits}{should the limits of the scale appear as ticks} + \item{name}{The name of the scale. Used as the axis or legend title. If +\code{waiver()}, the default, the name of the scale is taken from the first +mapping used for that aesthetic. If \code{NULL}, the legend title will be +omitted.} + \item{breaks}{One of: +\itemize{ +\item \code{NULL} for no breaks +\item \code{waiver()} for the default breaks computed by the +\link[scales:trans_new]{transformation object} +\item A numeric vector of positions +\item A function that takes the limits as input and returns breaks +as output (e.g., a function returned by \code{\link[scales:extended_breaks]{scales::extended_breaks()}}) +}} + \item{labels}{One of: +\itemize{ +\item \code{NULL} for no labels +\item \code{waiver()} for the default labels computed by the +transformation object +\item A character vector giving labels (must be same length as \code{breaks}) +\item A function that takes the breaks as input and returns labels +as output +}} + \item{limits}{One of: +\itemize{ +\item \code{NULL} to use the default scale range +\item A numeric vector of length two providing limits of the scale. +Use \code{NA} to refer to the existing minimum or maximum +\item A function that accepts the existing (automatic) limits and returns +new limits +Note that setting limits on positional scales will \strong{remove} data outside of the limits. +If the purpose is to zoom, use the limit argument in the coordinate system +(see \code{\link[=coord_cartesian]{coord_cartesian()}}). +}} + \item{oob}{One of: +\itemize{ +\item Function that handles limits outside of the scale limits +(out of bounds). +\item The default (\code{\link[scales:censor]{scales::censor()}}) replaces out of +bounds values with \code{NA}. +\item \code{\link[scales:squish]{scales::squish()}} for squishing out of bounds values into range. +\item \code{\link[scales:squish_infinite]{scales::squish_infinite()}} for squishing infitite values into range. +}} + \item{expand}{For position scales, a vector of range expansion constants used to add some +padding around the data to ensure that they are placed some distance +away from the axes. Use the convenience function \code{\link[=expansion]{expansion()}} +to generate the values for the \code{expand} argument. The defaults are to +expand the scale by 5\% on each side for continuous variables, and by +0.6 units on each side for discrete variables.} + \item{trans}{For continuous scales, the name of a transformation object +or the object itself. Built-in transformations include "asn", "atanh", +"boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2", +"logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal", +"reverse", "sqrt" and "time". + +A transformation object bundles together a transform, its inverse, +and methods for generating breaks and labels. Transformation objects +are defined in the scales package, and are called \code{_trans} (e.g., +\code{\link[scales:boxcox_trans]{scales::boxcox_trans()}}). You can create your own +transformation with \code{\link[scales:trans_new]{scales::trans_new()}}.} + \item{position}{For position scales, The position of the axis. +\code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} + \item{super}{The super class to use for the constructed scale} +}} + +\item{low}{Colours for low and high ends of the gradient.} + +\item{high}{Colours for low and high ends of the gradient.} + +\item{space}{colour space in which to calculate gradient. Must be "Lab" - +other values are deprecated.} + +\item{na.value}{Colour to use for missing values} + +\item{guide}{Type of legend. Use \code{"colourbar"} for continuous +colour bar, or \code{"legend"} for discrete colour legend.} + +\item{aesthetics}{Character string or vector of character strings listing the +name(s) of the aesthetic(s) that this scale works with. This can be useful, for +example, to apply colour settings to the \code{colour} and \code{fill} aesthetics at the +same time, via \code{aesthetics = c("colour", "fill")}.} + +\item{mid}{colour for mid point} + +\item{midpoint}{The midpoint (in data value) of the diverging scale. +Defaults to 0.} + +\item{colours}{Vector of colours to use for n-colour gradient.} + +\item{values}{if colours should not be evenly positioned along the gradient +this vector gives the position (between 0 and 1) for each colour in the +\code{colours} vector. See \code{\link[=rescale]{rescale()}} for a convenience function +to map an arbitrary range to between 0 and 1.} + +\item{colors}{Vector of colours to use for n-colour gradient.} +} +\description{ +\code{scale_*_steps} creates a two colour binned gradient (low-high), +\code{scale_*_steps2} creates a diverging binned colour gradient (low-mid-high), +and \code{scale_*_stepsn} creates a n-colour binned gradient. These scales are +binned variants of the \link[=scale_colour_gradient]{gradient scale} family and +works in the same way. +} +\details{ +Default colours are generated with \pkg{munsell} and +\code{mnsl(c("2.5PB 2/4", "2.5PB 7/10"))}. Generally, for continuous +colour scales you want to keep hue constant, but vary chroma and +luminance. The \pkg{munsell} package makes this easy to do using the +Munsell colour system. +} +\examples{ +df <- data.frame( + x = runif(100), + y = runif(100), + z1 = rnorm(100) +) + +# Use scale_colour_steps for a standard binned gradient +ggplot(df, aes(x, y)) + + geom_point(aes(colour = z1)) + + scale_colour_steps() + +# Get a divergent binned scale with the *2 variant +ggplot(df, aes(x, y)) + + geom_point(aes(colour = z1)) + + scale_colour_steps2() + +# Define your own colour ramp to extract binned colours from +ggplot(df, aes(x, y)) + + geom_point(aes(colour = z1)) + + scale_colour_stepsn(colours = terrain.colors(10)) + +} +\seealso{ +\code{\link[scales:seq_gradient_pal]{scales::seq_gradient_pal()}} for details on underlying +palette + +Other colour scales: \code{\link{scale_alpha}}, + \code{\link{scale_colour_brewer}}, + \code{\link{scale_colour_gradient}}, + \code{\link{scale_colour_grey}}, + \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_viridis_d}} +} +\concept{colour scales} diff --git a/man/scale_viridis.Rd b/man/scale_viridis.Rd index 6faca738fb..d266cab34b 100644 --- a/man/scale_viridis.Rd +++ b/man/scale_viridis.Rd @@ -5,6 +5,8 @@ \alias{scale_fill_viridis_d} \alias{scale_colour_viridis_c} \alias{scale_fill_viridis_c} +\alias{scale_colour_viridis_b} +\alias{scale_fill_viridis_b} \alias{scale_colour_ordinal} \alias{scale_color_ordinal} \alias{scale_fill_ordinal} @@ -25,10 +27,19 @@ scale_colour_viridis_c(..., alpha = 1, begin = 0, end = 1, scale_fill_viridis_c(..., alpha = 1, begin = 0, end = 1, direction = 1, option = "D", values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", aesthetics = "fill") + +scale_colour_viridis_b(..., alpha = 1, begin = 0, end = 1, + direction = 1, option = "D", values = NULL, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "colour") + +scale_fill_viridis_b(..., alpha = 1, begin = 0, end = 1, + direction = 1, option = "D", values = NULL, space = "Lab", + na.value = "grey50", guide = "coloursteps", aesthetics = "fill") } \arguments{ -\item{...}{Other arguments passed on to \code{\link[=discrete_scale]{discrete_scale()}} or -\code{\link[=continuous_scale]{continuous_scale()}} to control name, limits, breaks, labels and so forth.} +\item{...}{Other arguments passed on to \code{\link[=discrete_scale]{discrete_scale()}}, +\code{\link[=continuous_scale]{continuous_scale()}}, or \link{binned_scale} to control name, limits, breaks, +labels and so forth.} \item{alpha}{The alpha transparency, a number in [0,1], see argument alpha in \code{\link[grDevices]{hsv}}.} @@ -101,12 +112,17 @@ p + scale_fill_viridis_d(direction = -1) geom_tile(aes(waiting, eruptions, fill = density))) v + scale_fill_viridis_c() v + scale_fill_viridis_c(option = "plasma") + +# Use viridis_b to bin continuous data before mapping +v + scale_fill_viridis_b() + } \seealso{ Other colour scales: \code{\link{scale_alpha}}, \code{\link{scale_colour_brewer}}, \code{\link{scale_colour_gradient}}, \code{\link{scale_colour_grey}}, - \code{\link{scale_colour_hue}} + \code{\link{scale_colour_hue}}, + \code{\link{scale_colour_steps}} } \concept{colour scales} diff --git a/tests/figs/deps.txt b/tests/figs/deps.txt index 059d357267..0f64e23e67 100644 --- a/tests/figs/deps.txt +++ b/tests/figs/deps.txt @@ -1,3 +1,3 @@ - vdiffr-svg-engine: 1.0 -- vdiffr: 0.3.0 +- vdiffr: 0.3.1 - freetypeharfbuzz: 0.2.5 diff --git a/tests/figs/guides/guide-bins-can-remove-axis.svg b/tests/figs/guides/guide-bins-can-remove-axis.svg new file mode 100644 index 0000000000..383f841c10 --- /dev/null +++ b/tests/figs/guides/guide-bins-can-remove-axis.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +x + + + + + + + + +1.5 +2.0 +2.5 +guide_bins can remove axis + diff --git a/tests/figs/guides/guide-bins-can-show-arrows.svg b/tests/figs/guides/guide-bins-can-show-arrows.svg new file mode 100644 index 0000000000..3415446818 --- /dev/null +++ b/tests/figs/guides/guide-bins-can-show-arrows.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +x + + + + + + + + + + + + + + +1.5 +2.0 +2.5 +guide_bins can show arrows + diff --git a/tests/figs/guides/guide-bins-can-show-limits.svg b/tests/figs/guides/guide-bins-can-show-limits.svg new file mode 100644 index 0000000000..c4b804a4d4 --- /dev/null +++ b/tests/figs/guides/guide-bins-can-show-limits.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +x + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +guide_bins can show limits + diff --git a/tests/figs/guides/guide-bins-can-show-ticks.svg b/tests/figs/guides/guide-bins-can-show-ticks.svg new file mode 100644 index 0000000000..3746b63a12 --- /dev/null +++ b/tests/figs/guides/guide-bins-can-show-ticks.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + +1 +2 +3 +4 +x +y + + + + + +1.5 +2.0 +3.0 +x + + + + + + +guide_bins can show ticks + diff --git a/tests/figs/guides/guide-bins-looks-as-it-should.svg b/tests/figs/guides/guide-bins-looks-as-it-should.svg new file mode 100644 index 0000000000..650baf4365 --- /dev/null +++ b/tests/figs/guides/guide-bins-looks-as-it-should.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +x + + + + + + + + + + + + +1.5 +2.0 +2.5 +guide_bins looks as it should + diff --git a/tests/figs/guides/guide-bins-work-horizontally.svg b/tests/figs/guides/guide-bins-work-horizontally.svg new file mode 100644 index 0000000000..7d5b3222bb --- /dev/null +++ b/tests/figs/guides/guide-bins-work-horizontally.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +x + + + + + + + + + + + + +1.5 +2.0 +2.5 +guide_bins work horizontally + diff --git a/tests/figs/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg b/tests/figs/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg new file mode 100644 index 0000000000..009180678b --- /dev/null +++ b/tests/figs/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg @@ -0,0 +1,157 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + +1 +2 +3 +4 +x +y + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.5 +2.0 +3.0 +x +guide_coloursteps can have bins relative to binsize + diff --git a/tests/figs/guides/guide-coloursteps-can-show-limits.svg b/tests/figs/guides/guide-coloursteps-can-show-limits.svg new file mode 100644 index 0000000000..a894fc9fcd --- /dev/null +++ b/tests/figs/guides/guide-coloursteps-can-show-limits.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + +1 +2 +3 +4 +x +y + + + + + +1 +1.5 +2.0 +3.0 +4 +x +guide_coloursteps can show limits + diff --git a/tests/figs/guides/guide-coloursteps-looks-as-it-should.svg b/tests/figs/guides/guide-coloursteps-looks-as-it-should.svg new file mode 100644 index 0000000000..ba8a0c49b2 --- /dev/null +++ b/tests/figs/guides/guide-coloursteps-looks-as-it-should.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + +5.0 +5.5 +6.0 +6.5 +7.0 + + + + + + + + + +1 +2 +3 +4 +x +y + + + + + +1.5 +2.0 +3.0 +x +guide_coloursteps looks as it should + diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 0fa2b90a91..87e3898f0d 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -423,3 +423,46 @@ test_that("guides can handle multiple aesthetics for one scale", { expect_doppelganger("one combined colorbar for colour and fill aesthetics", p) }) + +test_that("bin guide can be styled correctly", { + df <- data_frame(x = c(1, 2, 3), + y = c(6, 5, 7)) + + p <- ggplot(df, aes(x, y, size = x)) + + geom_point() + + scale_size_binned() + + expect_doppelganger("guide_bins looks as it should", p) + expect_doppelganger("guide_bins can show limits", + p + guides(size = guide_bins(show.limits = TRUE)) + ) + expect_doppelganger("guide_bins can show arrows", + p + guides(size = guide_bins(axis.arrow = arrow(length = unit(1.5, "mm"), ends = "both"))) + ) + expect_doppelganger("guide_bins can remove axis", + p + guides(size = guide_bins(axis = FALSE)) + ) + expect_doppelganger("guide_bins work horizontally", + p + guides(size = guide_bins(direction = "horizontal")) + ) +}) + +test_that("coloursteps guide can be styled correctly", { + df <- data_frame(x = c(1, 2, 4), + y = c(6, 5, 7)) + + p <- ggplot(df, aes(x, y, colour = x)) + + geom_point() + + scale_colour_binned(breaks = c(1.5, 2, 3)) + + expect_doppelganger("guide_coloursteps looks as it should", p) + expect_doppelganger("guide_coloursteps can show limits", + p + guides(colour = guide_coloursteps(show.limits = TRUE)) + ) + expect_doppelganger("guide_coloursteps can have bins relative to binsize", + p + guides(colour = guide_coloursteps(even.steps = FALSE)) + ) + expect_doppelganger("guide_bins can show ticks", + p + guides(colour = guide_coloursteps(ticks = TRUE)) + ) +}) From e6889447569fef3bf72db9720199680410e3a8b6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 062/125] Style file --- R/position-nudgestack.R | 2 +- tests/testthat/test-position-nudgestack.R | 29 +++++++++++------------ 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 51a3de3587..fecbd48253 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -16,7 +16,7 @@ #' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% #' group_by(id, time) %>% #' summarize(value = mean(value)) %>% #' filter(time >= "1995-01-01" & time < "1998-01-01") diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 29964c5dfb..85a11f197a 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,16 +1,18 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% dplyr::group_by(id, time) %>% dplyr::summarize(value = mean(value)) %>% dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + + stock_marked <- ggplot( + data = ESM_prep, + mapping = aes(x = time, y = value, fill = id) + ) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -35,9 +37,8 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$xmin, 1.05:3.05) expect_equal(data$xmax, 1.95:3.95) expect_equal(data$y, 3:5) - expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) - }) test_that("nudging works for discrete values correctly", { @@ -45,8 +46,8 @@ test_that("nudging works for discrete values correctly", { # x nudge value for discrete data series <- data_frame( - time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), - type = rep(c('a', 'b', 'c', 'd'), 4), + time = factor(c(rep(1, 4), rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c("a", "b", "c", "d"), 4), value = rpois(16, 10) ) @@ -56,10 +57,9 @@ test_that("nudging works for discrete values correctly", { data <- layer_data(p) - expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - + expect_equal(data$x, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) }) @@ -78,9 +78,9 @@ test_that("data is sorted prior to stacking", { test_that("negative and positive values are handled separately", { df <- data_frame( - x = c(1,1,1,2,2), - g = c(1,2,3,1,2), - y = c(1,-1,1,2,-3) + x = c(1, 1, 1, 2, 2), + g = c(1, 2, 3, 1, 2), + y = c(1, -1, 1, 2, -3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col(position = position_nudgestack(x = 0.5)) @@ -110,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From daeb34ee19734d65c0b8804cd9ee83aa0b7b82fc Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 063/125] Style file --- R/position-nudgestack.R | 2 +- man/position_nudgestack.Rd | 2 +- tests/testthat/test-position-nudgestack.R | 29 +++++++++++------------ 3 files changed, 16 insertions(+), 17 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 51a3de3587..fecbd48253 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -16,7 +16,7 @@ #' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% #' group_by(id, time) %>% #' summarize(value = mean(value)) %>% #' filter(time >= "1995-01-01" & time < "1998-01-01") diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 5d6a382bd3..3a77e318ec 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -25,7 +25,7 @@ x-axis. ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"), "-1"))) \%>\% group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% filter(time >= "1995-01-01" & time < "1998-01-01") diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 29964c5dfb..85a11f197a 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,16 +1,18 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% dplyr::group_by(id, time) %>% dplyr::summarize(value = mean(value)) %>% dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + + stock_marked <- ggplot( + data = ESM_prep, + mapping = aes(x = time, y = value, fill = id) + ) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -35,9 +37,8 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$xmin, 1.05:3.05) expect_equal(data$xmax, 1.95:3.95) expect_equal(data$y, 3:5) - expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) - }) test_that("nudging works for discrete values correctly", { @@ -45,8 +46,8 @@ test_that("nudging works for discrete values correctly", { # x nudge value for discrete data series <- data_frame( - time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), - type = rep(c('a', 'b', 'c', 'd'), 4), + time = factor(c(rep(1, 4), rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c("a", "b", "c", "d"), 4), value = rpois(16, 10) ) @@ -56,10 +57,9 @@ test_that("nudging works for discrete values correctly", { data <- layer_data(p) - expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - + expect_equal(data$x, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) }) @@ -78,9 +78,9 @@ test_that("data is sorted prior to stacking", { test_that("negative and positive values are handled separately", { df <- data_frame( - x = c(1,1,1,2,2), - g = c(1,2,3,1,2), - y = c(1,-1,1,2,-3) + x = c(1, 1, 1, 2, 2), + g = c(1, 2, 3, 1, 2), + y = c(1, -1, 1, 2, -3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col(position = position_nudgestack(x = 0.5)) @@ -110,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From 72145873acd56df68180e50eeeb68ed048d0eaa3 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:44:37 +0200 Subject: [PATCH 064/125] Add news --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 5e96c37dcf..89b9d0a16f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Added `position_nudgestack()`, which allows to nudge stacked columns. (@ThomasKnecht ) + * `Geom` now gains a `setup_params()` method in line with the other ggproto classes (@thomasp85, #3509) From 88c5bde5d8ed9cec508d7adc47474674320943fb Mon Sep 17 00:00:00 2001 From: Mine Cetinkaya-Rundel Date: Tue, 1 Oct 2019 09:32:08 +0100 Subject: [PATCH 065/125] Minor updates to data docs (#3545) --- R/data.R | 43 +++++++++++++++++++++++++++---------------- man/diamonds.Rd | 2 +- man/economics.Rd | 14 +++++++------- man/faithfuld.Rd | 7 ++++++- man/midwest.Rd | 2 +- man/mpg.Rd | 6 +++--- man/msleep.Rd | 2 +- man/presidential.Rd | 8 +++++++- man/txhousing.Rd | 2 +- 9 files changed, 54 insertions(+), 32 deletions(-) diff --git a/R/data.R b/R/data.R index aee286cc57..19ff85b59d 100644 --- a/R/data.R +++ b/R/data.R @@ -1,4 +1,4 @@ -#' Prices of 50,000 round cut diamonds +#' Prices of over 50,000 round cut diamonds #' #' A dataset containing the prices and other attributes of almost 54,000 #' diamonds. The variables are as follows: @@ -26,19 +26,19 @@ #' \url{http://research.stlouisfed.org/fred2}. `economics` is in "wide" #' format, `economics_long` is in "long" format. #' -#' @format A data frame with 478 rows and 6 variables +#' @format A data frame with 574 rows and 6 variables: #' \describe{ #' \item{date}{Month of data collection} -#' \item{psavert}{personal savings rate, -#' \url{http://research.stlouisfed.org/fred2/series/PSAVERT/}} #' \item{pce}{personal consumption expenditures, in billions of dollars, #' \url{http://research.stlouisfed.org/fred2/series/PCE}} -#' \item{unemploy}{number of unemployed in thousands, -#' \url{http://research.stlouisfed.org/fred2/series/UNEMPLOY}} -#' \item{uempmed}{median duration of unemployment, in weeks, -#' \url{http://research.stlouisfed.org/fred2/series/UEMPMED}} #' \item{pop}{total population, in thousands, #' \url{http://research.stlouisfed.org/fred2/series/POP}} +#' \item{psavert}{personal savings rate, +#' \url{http://research.stlouisfed.org/fred2/series/PSAVERT/}} +#' \item{uempmed}{median duration of unemployment, in weeks, +#' \url{http://research.stlouisfed.org/fred2/series/UEMPMED}} +#' \item{unemploy}{number of unemployed in thousands, +#' \url{http://research.stlouisfed.org/fred2/series/UNEMPLOY}} #' } #' "economics" @@ -50,7 +50,7 @@ #' #' Demographic information of midwest counties #' -#' @format A data frame with 437 rows and 28 variables +#' @format A data frame with 437 rows and 28 variables: #' \describe{ #' \item{PID}{} #' \item{county}{} @@ -85,16 +85,16 @@ "midwest" -#' Fuel economy data from 1999 and 2008 for 38 popular models of car +#' Fuel economy data from 1999 to 2008 for 38 popular models of cars #' #' This dataset contains a subset of the fuel economy data that the EPA makes #' available on \url{http://fueleconomy.gov}. It contains only models which #' had a new release every year between 1999 and 2008 - this was used as a #' proxy for the popularity of the car. #' -#' @format A data frame with 234 rows and 11 variables +#' @format A data frame with 234 rows and 11 variables: #' \describe{ -#' \item{manufacturer}{} +#' \item{manufacturer}{manufacturer name} #' \item{model}{model name} #' \item{displ}{engine displacement, in litres} #' \item{year}{year of manufacture} @@ -119,7 +119,7 @@ #' Additional variables order, conservation status and vore were added from #' wikipedia. #' -#' @format A data frame with 83 rows and 11 variables +#' @format A data frame with 83 rows and 11 variables: #' \describe{ #' \item{name}{common name} #' \item{genus}{} @@ -140,7 +140,13 @@ #' The names of each president, the start and end date of their term, and #' their party of 11 US presidents from Eisenhower to Obama. #' -#' @format A data frame with 11 rows and 4 variables +#' @format A data frame with 11 rows and 4 variables: +#' \describe{ +#' \item{name}{Last name of president} +#' \item{start}{Presidency start date} +#' \item{end}{Presidency end date} +#' \item{party}{Party of president} +#' } "presidential" #' Vector field of seal movements @@ -161,7 +167,12 @@ #' A 2d density estimate of the waiting and eruptions variables data #' \link{faithful}. #' -#' @format A data frame with 5,625 observations and 3 variables. +#' @format A data frame with 5,625 observations and 3 variables: +#' \describe{ +#' \item{eruptions}{Eruption time in mins} +#' \item{waiting}{Waiting time to next eruption in mins} +#' \item{density}{2d density estimate} +#' } "faithfuld" #' `colors()` in Luv space @@ -182,7 +193,7 @@ #' #' @format A data frame with 8602 observations and 9 variables: #' \describe{ -#' \item{city}{Name of MLS area} +#' \item{city}{Name of multiple listing service (MLS) area} #' \item{year,month,date}{Date} #' \item{sales}{Number of sales} #' \item{volume}{Total value of sales} diff --git a/man/diamonds.Rd b/man/diamonds.Rd index 8d2cb9c0b7..ed13e7e846 100644 --- a/man/diamonds.Rd +++ b/man/diamonds.Rd @@ -3,7 +3,7 @@ \docType{data} \name{diamonds} \alias{diamonds} -\title{Prices of 50,000 round cut diamonds} +\title{Prices of over 50,000 round cut diamonds} \format{A data frame with 53940 rows and 10 variables: \describe{ \item{price}{price in US dollars (\$326--\$18,823)} diff --git a/man/economics.Rd b/man/economics.Rd index 50dc689d90..e099d23e8e 100644 --- a/man/economics.Rd +++ b/man/economics.Rd @@ -5,19 +5,19 @@ \alias{economics} \alias{economics_long} \title{US economic time series} -\format{A data frame with 478 rows and 6 variables +\format{A data frame with 574 rows and 6 variables: \describe{ \item{date}{Month of data collection} -\item{psavert}{personal savings rate, -\url{http://research.stlouisfed.org/fred2/series/PSAVERT/}} \item{pce}{personal consumption expenditures, in billions of dollars, \url{http://research.stlouisfed.org/fred2/series/PCE}} -\item{unemploy}{number of unemployed in thousands, -\url{http://research.stlouisfed.org/fred2/series/UNEMPLOY}} -\item{uempmed}{median duration of unemployment, in weeks, -\url{http://research.stlouisfed.org/fred2/series/UEMPMED}} \item{pop}{total population, in thousands, \url{http://research.stlouisfed.org/fred2/series/POP}} +\item{psavert}{personal savings rate, +\url{http://research.stlouisfed.org/fred2/series/PSAVERT/}} +\item{uempmed}{median duration of unemployment, in weeks, +\url{http://research.stlouisfed.org/fred2/series/UEMPMED}} +\item{unemploy}{number of unemployed in thousands, +\url{http://research.stlouisfed.org/fred2/series/UNEMPLOY}} }} \usage{ economics diff --git a/man/faithfuld.Rd b/man/faithfuld.Rd index 440b3999d1..a5d8d0b7d0 100644 --- a/man/faithfuld.Rd +++ b/man/faithfuld.Rd @@ -4,7 +4,12 @@ \name{faithfuld} \alias{faithfuld} \title{2d density estimate of Old Faithful data} -\format{A data frame with 5,625 observations and 3 variables.} +\format{A data frame with 5,625 observations and 3 variables: +\describe{ +\item{eruptions}{Eruption time in mins} +\item{waiting}{Waiting time to next eruption in mins} +\item{density}{2d density estimate} +}} \usage{ faithfuld } diff --git a/man/midwest.Rd b/man/midwest.Rd index f5ccf869dc..ee8b5e85ae 100644 --- a/man/midwest.Rd +++ b/man/midwest.Rd @@ -4,7 +4,7 @@ \name{midwest} \alias{midwest} \title{Midwest demographics} -\format{A data frame with 437 rows and 28 variables +\format{A data frame with 437 rows and 28 variables: \describe{ \item{PID}{} \item{county}{} diff --git a/man/mpg.Rd b/man/mpg.Rd index 63b4f8ca44..ec696861bd 100644 --- a/man/mpg.Rd +++ b/man/mpg.Rd @@ -3,10 +3,10 @@ \docType{data} \name{mpg} \alias{mpg} -\title{Fuel economy data from 1999 and 2008 for 38 popular models of car} -\format{A data frame with 234 rows and 11 variables +\title{Fuel economy data from 1999 to 2008 for 38 popular models of cars} +\format{A data frame with 234 rows and 11 variables: \describe{ -\item{manufacturer}{} +\item{manufacturer}{manufacturer name} \item{model}{model name} \item{displ}{engine displacement, in litres} \item{year}{year of manufacture} diff --git a/man/msleep.Rd b/man/msleep.Rd index 682992290e..a53c1cd3e2 100644 --- a/man/msleep.Rd +++ b/man/msleep.Rd @@ -4,7 +4,7 @@ \name{msleep} \alias{msleep} \title{An updated and expanded version of the mammals sleep dataset} -\format{A data frame with 83 rows and 11 variables +\format{A data frame with 83 rows and 11 variables: \describe{ \item{name}{common name} \item{genus}{} diff --git a/man/presidential.Rd b/man/presidential.Rd index f3de3abdf8..4c827f93aa 100644 --- a/man/presidential.Rd +++ b/man/presidential.Rd @@ -4,7 +4,13 @@ \name{presidential} \alias{presidential} \title{Terms of 11 presidents from Eisenhower to Obama} -\format{A data frame with 11 rows and 4 variables} +\format{A data frame with 11 rows and 4 variables: +\describe{ +\item{name}{Last name of president} +\item{start}{Presidency start date} +\item{end}{Presidency end date} +\item{party}{Party of president} +}} \usage{ presidential } diff --git a/man/txhousing.Rd b/man/txhousing.Rd index 5ae08e29fe..e9183ea37c 100644 --- a/man/txhousing.Rd +++ b/man/txhousing.Rd @@ -6,7 +6,7 @@ \title{Housing sales in TX} \format{A data frame with 8602 observations and 9 variables: \describe{ -\item{city}{Name of MLS area} +\item{city}{Name of multiple listing service (MLS) area} \item{year,month,date}{Date} \item{sales}{Number of sales} \item{volume}{Total value of sales} From 10fa0014d6be81a7e641b8c2c3b48e1df1b7e2f5 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 1 Oct 2019 11:12:59 +0200 Subject: [PATCH 066/125] Removing direction constraint from geoms (#3506) --- NAMESPACE | 3 + R/geom-.r | 7 +- R/geom-bar.r | 29 +++- R/geom-boxplot.r | 36 +++-- R/geom-col.r | 18 ++- R/geom-crossbar.r | 16 +- R/geom-density.r | 9 +- R/geom-errorbar.r | 31 +++- R/geom-histogram.r | 9 +- R/geom-linerange.r | 31 +++- R/geom-path.r | 22 ++- R/geom-pointrange.r | 22 ++- R/geom-ribbon.r | 47 +++++- R/geom-smooth.r | 26 +++- R/geom-violin.r | 28 +++- R/ggplot-global.R | 6 + R/position-dodge.r | 12 +- R/position-dodge2.r | 9 +- R/position-jitterdodge.R | 9 +- R/position-stack.r | 13 +- R/stat-.r | 7 +- R/stat-bin.r | 45 ++++-- R/stat-boxplot.r | 26 +++- R/stat-count.r | 30 +++- R/stat-density.r | 32 +++- R/stat-smooth.r | 12 +- R/stat-summary-bin.R | 71 ++++++--- R/stat-summary.r | 97 ++++++++---- R/stat-ydensity.r | 17 ++- R/utilities-help.r | 17 +++ R/utilities.r | 229 ++++++++++++++++++++++++++++- man/bidirection.Rd | 101 +++++++++++++ man/geom_bar.Rd | 25 +++- man/geom_boxplot.Rd | 41 ++++-- man/geom_density.Rd | 19 ++- man/geom_histogram.Rd | 18 ++- man/geom_linerange.Rd | 38 +++-- man/geom_path.Rd | 17 ++- man/geom_ribbon.Rd | 33 ++++- man/geom_smooth.Rd | 20 ++- man/geom_violin.Rd | 20 ++- man/stat_summary.Rd | 74 +++++++--- tests/testthat/test-geom-bar.R | 16 ++ tests/testthat/test-geom-boxplot.R | 16 ++ tests/testthat/test-geom-col.R | 16 ++ tests/testthat/test-geom-ribbon.R | 18 +++ tests/testthat/test-geom-smooth.R | 14 ++ tests/testthat/test-geom-violin.R | 14 ++ tests/testthat/test-stat-bin.R | 18 ++- tests/testthat/test-stat-density.R | 14 ++ tests/testthat/test-stats.r | 4 +- vignettes/extending-ggplot2.Rmd | 46 ++++++ 52 files changed, 1316 insertions(+), 232 deletions(-) create mode 100644 man/bidirection.Rd diff --git a/NAMESPACE b/NAMESPACE index de8c8cf4df..7a90dd5f5f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -316,6 +316,8 @@ export(facet_grid) export(facet_null) export(facet_wrap) export(find_panel) +export(flip_data) +export(flipped_names) export(fortify) export(geom_abline) export(geom_area) @@ -390,6 +392,7 @@ export(guide_none) export(guide_train) export(guide_transform) export(guides) +export(has_flipped_aes) export(is.Coord) export(is.facet) export(is.ggplot) diff --git a/R/geom-.r b/R/geom-.r index bca1b57ded..7c8fa47356 100644 --- a/R/geom-.r +++ b/R/geom-.r @@ -153,7 +153,12 @@ Geom <- ggproto("Geom", }, aesthetics = function(self) { - c(union(self$required_aes, names(self$default_aes)), self$optional_aes, "group") + if (is.null(self$required_aes)) { + required_aes <- NULL + } else { + required_aes <- unlist(strsplit(self$required_aes, '|', fixed = TRUE)) + } + c(union(required_aes, names(self$default_aes)), self$optional_aes, "group") } ) diff --git a/R/geom-bar.r b/R/geom-bar.r index 91d1767f3e..4a8309cffe 100644 --- a/R/geom-bar.r +++ b/R/geom-bar.r @@ -19,6 +19,8 @@ #' [position_fill()] shows relative proportions at each `x` by stacking the bars #' and then standardising each bar to have the same height. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "bar") #' @eval rd_aesthetics("geom", "col") #' @eval rd_aesthetics("stat", "count") @@ -29,6 +31,10 @@ #' @export #' @inheritParams layer #' @inheritParams geom_point +#' @param orientation The orientation of the layer. The default (`NA`) +#' automatically determines the orientation from the aesthetic mapping. In the +#' rare event that this fails it can be given explicitly by setting `orientation` +#' to either `"x"` or `"y"`. See the *Orientation* section for more detail. #' @param width Bar width. By default, set to 90\% of the resolution of the data. #' @param binwidth `geom_bar()` no longer has a binwidth argument - if #' you use it you'll get an warning telling to you use @@ -43,17 +49,18 @@ #' g + geom_bar() #' # Total engine displacement of each class #' g + geom_bar(aes(weight = displ)) +#' # Map class to y instead to flip the orientation +#' ggplot(mpg) + geom_bar(aes(y = class)) #' #' # Bar charts are automatically stacked when multiple bars are placed #' # at the same location. The order of the fill is designed to match #' # the legend #' g + geom_bar(aes(fill = drv)) #' -#' # If you need to flip the order (because you've flipped the plot) +#' # If you need to flip the order (because you've flipped the orientation) #' # call position_stack() explicitly: -#' g + +#' ggplot(mpg, aes(y = class)) + #' geom_bar(aes(fill = drv), position = position_stack(reverse = TRUE)) + -#' coord_flip() + #' theme(legend.position = "top") #' #' # To show (e.g.) means, you need geom_col() @@ -77,6 +84,7 @@ geom_bar <- function(mapping = NULL, data = NULL, width = NULL, binwidth = NULL, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -99,6 +107,7 @@ geom_bar <- function(mapping = NULL, data = NULL, params = list( width = width, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -117,16 +126,26 @@ GeomBar <- ggproto("GeomBar", GeomRect, # limits, not just those for which x and y are outside the limits non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = FALSE) + params + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) - transform(data, + data <- transform(data, ymin = pmin(y, 0), ymax = pmax(y, 0), xmin = x - width / 2, xmax = x + width / 2, width = NULL ) + flip_data(data, params$flipped_aes) }, - draw_panel = function(self, data, panel_params, coord, width = NULL) { + draw_panel = function(self, data, panel_params, coord, width = NULL, flipped_aes = FALSE) { # Hack to ensure that width is detected as a parameter ggproto_parent(GeomRect, self)$draw_panel(data, panel_params, coord) } diff --git a/R/geom-boxplot.r b/R/geom-boxplot.r index 246a0a13f9..8ce8574114 100644 --- a/R/geom-boxplot.r +++ b/R/geom-boxplot.r @@ -4,6 +4,8 @@ #' It visualises five summary statistics (the median, two hinges #' and two whiskers), and all "outlying" points individually. #' +#' @eval rd_orientation() +#' #' @section Summary statistics: #' The lower and upper hinges correspond to the first and third quartiles #' (the 25th and 75th percentiles). This differs slightly from the method used @@ -28,7 +30,7 @@ #' [geom_violin()] for a richer display of the distribution, and #' [geom_jitter()] for a useful technique for small data. #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param geom,stat Use to override the default connection between #' `geom_boxplot` and `stat_boxplot`. #' @param outlier.colour,outlier.color,outlier.fill,outlier.shape,outlier.size,outlier.stroke,outlier.alpha @@ -60,7 +62,8 @@ #' @examples #' p <- ggplot(mpg, aes(class, hwy)) #' p + geom_boxplot() -#' p + geom_boxplot() + coord_flip() +#' # Orientation follows the discrete axis +#' ggplot(mpg, aes(hwy, class)) + geom_boxplot() #' #' p + geom_boxplot(notch = TRUE) #' p + geom_boxplot(varwidth = TRUE) @@ -116,6 +119,7 @@ geom_boxplot <- function(mapping = NULL, data = NULL, notchwidth = 0.5, varwidth = FALSE, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -148,6 +152,7 @@ geom_boxplot <- function(mapping = NULL, data = NULL, notchwidth = notchwidth, varwidth = varwidth, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -161,9 +166,16 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, # need to declare `width` here in case this geom is used with a stat that # doesn't have a `width` parameter (e.g., `stat_identity`). - extra_params = c("na.rm", "width"), + extra_params = c("na.rm", "width", "orientation"), + + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params) + params + }, setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) @@ -173,8 +185,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, out_max <- vapply(data$outliers, max, numeric(1)) }) - data$ymin_final <- pmin(out_min, data$ymin) - data$ymax_final <- pmax(out_max, data$ymax) + data$ymin_final <- pmin(out_min, data$ymin) + data$ymax_final <- pmax(out_max, data$ymax) } # if `varwidth` not requested or not available, don't use it @@ -190,7 +202,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, data$width <- NULL if (!is.null(data$relvarwidth)) data$relvarwidth <- NULL - data + flip_data(data, params$flipped_aes) }, draw_group = function(data, panel_params, coord, fatten = 2, @@ -198,8 +210,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, outlier.shape = 19, outlier.size = 1.5, outlier.stroke = 0.5, outlier.alpha = NULL, - notch = FALSE, notchwidth = 0.5, varwidth = FALSE) { - + notch = FALSE, notchwidth = 0.5, varwidth = FALSE, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) # this may occur when using geom_boxplot(stat = "identity") if (nrow(data) != 1) { stop( @@ -226,6 +238,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, ), common ), n = 2) + whiskers <- flip_data(whiskers, flipped_aes) box <- new_data_frame(c( list( @@ -241,6 +254,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, ), common )) + box <- flip_data(box, flipped_aes) if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) { outliers <- new_data_frame(list( @@ -254,6 +268,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, fill = NA, alpha = outlier.alpha %||% data$alpha[1] ), n = length(data$outliers[[1]])) + outliers <- flip_data(outliers, flipped_aes) + outliers_grob <- GeomPoint$draw_panel(outliers, panel_params, coord) } else { outliers_grob <- NULL @@ -262,7 +278,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, ggname("geom_boxplot", grobTree( outliers_grob, GeomSegment$draw_panel(whiskers, panel_params, coord), - GeomCrossbar$draw_panel(box, fatten = fatten, panel_params, coord) + GeomCrossbar$draw_panel(box, fatten = fatten, panel_params, coord, flipped_aes = flipped_aes) )) }, @@ -271,5 +287,5 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, default_aes = aes(weight = 1, colour = "grey20", fill = "white", size = 0.5, alpha = NA, shape = 19, linetype = "solid"), - required_aes = c("x", "lower", "upper", "middle", "ymin", "ymax") + required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax") ) diff --git a/R/geom-col.r b/R/geom-col.r index 7ebd51f8fc..be91cfc480 100644 --- a/R/geom-col.r +++ b/R/geom-col.r @@ -37,16 +37,26 @@ GeomCol <- ggproto("GeomCol", GeomRect, # limits, not just those for which x and y are outside the limits non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params) + params + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) - transform(data, - ymin = pmin(y, 0), ymax = pmax(y, 0), - xmin = x - width / 2, xmax = x + width / 2, width = NULL + data <- transform(data, + ymin = pmin(y, 0), ymax = pmax(y, 0), + xmin = x - width / 2, xmax = x + width / 2, width = NULL ) + flip_data(data, params$flipped_aes) }, - draw_panel = function(self, data, panel_params, coord, width = NULL) { + draw_panel = function(self, data, panel_params, coord, width = NULL, flipped_aes = FALSE) { # Hack to ensure that width is detected as a parameter ggproto_parent(GeomRect, self)$draw_panel(data, panel_params, coord) } diff --git a/R/geom-crossbar.r b/R/geom-crossbar.r index 0a901133d7..05fa058460 100644 --- a/R/geom-crossbar.r +++ b/R/geom-crossbar.r @@ -5,6 +5,7 @@ geom_crossbar <- function(mapping = NULL, data = NULL, ..., fatten = 2.5, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -18,6 +19,7 @@ geom_crossbar <- function(mapping = NULL, data = NULL, params = list( fatten = fatten, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -28,6 +30,12 @@ geom_crossbar <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomCrossbar <- ggproto("GeomCrossbar", Geom, + setup_params = function(data, params) { + GeomErrorbar$setup_params(data, params) + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { GeomErrorbar$setup_data(data, params) }, @@ -35,11 +43,13 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, default_aes = aes(colour = "black", fill = NA, size = 0.5, linetype = 1, alpha = NA), - required_aes = c("x", "y", "ymin", "ymax"), + required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"), draw_key = draw_key_crossbar, - draw_panel = function(data, panel_params, coord, fatten = 2.5, width = NULL) { + draw_panel = function(data, panel_params, coord, fatten = 2.5, width = NULL, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) + middle <- transform(data, x = xmin, xend = xmax, yend = y, size = size * fatten, alpha = NA) has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) && @@ -85,6 +95,8 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group )) } + box <- flip_data(box, flipped_aes) + middle <- flip_data(middle, flipped_aes) ggname("geom_crossbar", gTree(children = gList( GeomPolygon$draw_panel(box, panel_params, coord), diff --git a/R/geom-density.r b/R/geom-density.r index 5d96c3ac1a..093e3bf53e 100644 --- a/R/geom-density.r +++ b/R/geom-density.r @@ -4,18 +4,23 @@ #' the histogram. This is a useful alternative to the histogram for continuous #' data that comes from an underlying smooth distribution. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "density") #' @seealso See [geom_histogram()], [geom_freqpoly()] for #' other methods of displaying continuous distribution. #' See [geom_violin()] for a compact density display. #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param geom,stat Use to override the default connection between #' `geom_density` and `stat_density`. #' @export #' @examples #' ggplot(diamonds, aes(carat)) + #' geom_density() +#' # Map the values to y to flip the orientation +#' ggplot(diamonds, aes(y = carat)) + +#' geom_density() #' #' ggplot(diamonds, aes(carat)) + #' geom_density(adjust = 1/5) @@ -49,6 +54,7 @@ geom_density <- function(mapping = NULL, data = NULL, stat = "density", position = "identity", ..., na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -62,6 +68,7 @@ geom_density <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) diff --git a/R/geom-errorbar.r b/R/geom-errorbar.r index 9c0a4361c2..4840d75d10 100644 --- a/R/geom-errorbar.r +++ b/R/geom-errorbar.r @@ -4,6 +4,7 @@ geom_errorbar <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -16,6 +17,7 @@ geom_errorbar <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) @@ -31,27 +33,40 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, draw_key = draw_key_path, - required_aes = c("x", "ymin", "ymax"), + required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), + + setup_params = function(data, params) { + GeomLinerange$setup_params(data, params) + }, + + extra_params = c("na.rm", "orientation"), setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) - - transform(data, + data <- transform(data, xmin = x - width / 2, xmax = x + width / 2, width = NULL ) + flip_data(data, params$flipped_aes) }, - draw_panel = function(data, panel_params, coord, width = NULL) { - GeomPath$draw_panel(new_data_frame(list( - x = as.vector(rbind(data$xmin, data$xmax, NA, data$x, data$x, NA, data$xmin, data$xmax)), - y = as.vector(rbind(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin)), + draw_panel = function(data, panel_params, coord, width = NULL, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) + x <- as.vector(rbind(data$xmin, data$xmax, NA, data$x, data$x, NA, data$xmin, data$xmax)) + y <- as.vector(rbind(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin)) + data <- new_data_frame(list( + x = x, + y = y, colour = rep(data$colour, each = 8), alpha = rep(data$alpha, each = 8), size = rep(data$size, each = 8), linetype = rep(data$linetype, each = 8), group = rep(1:(nrow(data)), each = 8), row.names = 1:(nrow(data) * 8) - )), panel_params, coord) + )) + data <- flip_data(data, flipped_aes) + GeomPath$draw_panel(data, panel_params, coord) } ) diff --git a/R/geom-histogram.r b/R/geom-histogram.r index 2bdbe74315..0629d93a65 100644 --- a/R/geom-histogram.r +++ b/R/geom-histogram.r @@ -17,13 +17,15 @@ #' one change at a time. You may need to look at a few options to uncover #' the full story behind your data. #' +#' @eval rd_orientation() +#' #' @section Aesthetics: #' `geom_histogram()` uses the same aesthetics as [geom_bar()]; #' `geom_freqpoly()` uses the same aesthetics as [geom_line()]. #' #' @export #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param geom,stat Use to override the default connection between #' `geom_histogram()`/`geom_freqpoly()` and `stat_bin()`. #' @examples @@ -33,6 +35,9 @@ #' geom_histogram(binwidth = 0.01) #' ggplot(diamonds, aes(carat)) + #' geom_histogram(bins = 200) +#' # Map values to y to flip the orientation +#' ggplot(diamonds, aes(y = carat)) + +#' geom_histogram() #' #' # Rather than stacking histograms, it's easier to compare frequency #' # polygons @@ -92,6 +97,7 @@ geom_histogram <- function(mapping = NULL, data = NULL, binwidth = NULL, bins = NULL, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -107,6 +113,7 @@ geom_histogram <- function(mapping = NULL, data = NULL, binwidth = binwidth, bins = bins, na.rm = na.rm, + orientation = orientation, pad = FALSE, ... ) diff --git a/R/geom-linerange.r b/R/geom-linerange.r index 861c8b0760..9676901c01 100644 --- a/R/geom-linerange.r +++ b/R/geom-linerange.r @@ -3,6 +3,8 @@ #' Various ways of representing a vertical interval defined by `x`, #' `ymin` and `ymax`. Each case draws a single graphical object. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "linerange") #' @param fatten A multiplicative factor used to increase the size of the #' middle bar in `geom_crossbar()` and the middle point in @@ -13,7 +15,7 @@ #' [geom_errorbarh()] for a horizontal error bar. #' @export #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @examples #' # Create a simple example dataset #' df <- data.frame( @@ -30,6 +32,10 @@ #' p + geom_crossbar(aes(ymin = lower, ymax = upper), width = 0.2) #' p + geom_errorbar(aes(ymin = lower, ymax = upper), width = 0.2) #' +#' # Flip the orientation by changing mapping +#' ggplot(df, aes(resp, trt, colour = group)) + +#' geom_linerange(aes(xmin = lower, xmax = upper)) +#' #' # Draw lines connecting group means #' p + #' geom_line(aes(group = group)) + @@ -61,6 +67,7 @@ geom_linerange <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -73,6 +80,7 @@ geom_linerange <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) @@ -87,10 +95,27 @@ GeomLinerange <- ggproto("GeomLinerange", Geom, draw_key = draw_key_vpath, - required_aes = c("x", "ymin", "ymax"), + required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), + + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) + if (!(params$flipped_aes || all(c("x", "ymin", "ymax") %in% names(data)))) { + stop("Either, `x`, `ymin`, and `ymax` or `y`, `xmin`, and `xmax` must be supplied", call. = FALSE) + } + params + }, + + extra_params = c("na.rm", "orientation"), + + setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data + }, - draw_panel = function(data, panel_params, coord) { + draw_panel = function(data, panel_params, coord, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) data <- transform(data, xend = x, y = ymin, yend = ymax) + data <- flip_data(data, flipped_aes) ggname("geom_linerange", GeomSegment$draw_panel(data, panel_params, coord)) } ) diff --git a/R/geom-path.r b/R/geom-path.r index f703809708..0f02f2f045 100644 --- a/R/geom-path.r +++ b/R/geom-path.r @@ -9,9 +9,11 @@ #' An alternative parameterisation is [geom_segment()], where each line #' corresponds to a single case which provides the start and end coordinates. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "path") #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param lineend Line end style (round, butt, square). #' @param linejoin Line join style (round, mitre, bevel). #' @param linemitre Line mitre limit (number greater than 1). @@ -35,6 +37,9 @@ #' ggplot(economics_long, aes(date, value01, colour = variable)) + #' geom_line() #' +#' # You can get a timeseries that run vertically by setting the orientation +#' ggplot(economics, aes(unemploy, date)) + geom_line(orientation = "y") +#' #' # geom_step() is useful when you want to highlight exactly when #' # the y value changes #' recent <- economics[economics$date > as.Date("2013-01-01"), ] @@ -236,7 +241,7 @@ keep_mid_true <- function(x) { #' @export #' @rdname geom_path geom_line <- function(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, + position = "identity", na.rm = FALSE, orientation = NA, show.legend = NA, inherit.aes = TRUE, ...) { layer( data = data, @@ -248,6 +253,7 @@ geom_line <- function(mapping = NULL, data = NULL, stat = "identity", inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) @@ -259,8 +265,18 @@ geom_line <- function(mapping = NULL, data = NULL, stat = "identity", #' @export #' @include geom-path.r GeomLine <- ggproto("GeomLine", GeomPath, + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) + params + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { - data[order(data$PANEL, data$group, data$x), ] + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) + data <- data[order(data$PANEL, data$group, data$x), ] + flip_data(data, params$flipped_aes) } ) diff --git a/R/geom-pointrange.r b/R/geom-pointrange.r index 6777aa0151..5b018c1253 100644 --- a/R/geom-pointrange.r +++ b/R/geom-pointrange.r @@ -5,6 +5,7 @@ geom_pointrange <- function(mapping = NULL, data = NULL, ..., fatten = 4, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -18,6 +19,7 @@ geom_pointrange <- function(mapping = NULL, data = NULL, params = list( fatten = fatten, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -33,15 +35,25 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, draw_key = draw_key_pointrange, - required_aes = c("x", "y", "ymin", "ymax"), + required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"), - draw_panel = function(data, panel_params, coord, fatten = 4) { - if (is.null(data$y)) - return(GeomLinerange$draw_panel(data, panel_params, coord)) + setup_params = function(data, params) { + GeomLinerange$setup_params(data, params) + }, + + extra_params = c("na.rm", "orientation"), + + setup_data = function(data, params) { + GeomLinerange$setup_data(data, params) + }, + + draw_panel = function(data, panel_params, coord, fatten = 4, flipped_aes = FALSE) { + if (is.null(data[[flipped_names(flipped_aes)$y]])) + return(GeomLinerange$draw_panel(data, panel_params, coord, flipped_aes = flipped_aes)) ggname("geom_pointrange", gTree(children = gList( - GeomLinerange$draw_panel(data, panel_params, coord), + GeomLinerange$draw_panel(data, panel_params, coord, flipped_aes = flipped_aes), GeomPoint$draw_panel(transform(data, size = size * fatten), panel_params, coord) )) ) diff --git a/R/geom-ribbon.r b/R/geom-ribbon.r index 17df0ed118..4625cdc2bd 100644 --- a/R/geom-ribbon.r +++ b/R/geom-ribbon.r @@ -12,13 +12,15 @@ #' see the individual pattern as you move up the stack. See #' [position_stack()] for the details of stacking algorithm. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "ribbon") #' @seealso #' [geom_bar()] for discrete intervals (bars), #' [geom_linerange()] for discrete intervals (lines), #' [geom_polygon()] for general polygons #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @export #' @examples #' # Generate data @@ -28,6 +30,9 @@ #' h + geom_ribbon(aes(ymin=0, ymax=level)) #' h + geom_area(aes(y = level)) #' +#' # Change orientation be switching the mapping +#' h + geom_area(aes(x = level, y = year)) +#' #' # Add aesthetic mappings #' h + #' geom_ribbon(aes(ymin = level - 1, ymax = level + 1), fill = "grey70") + @@ -36,6 +41,7 @@ geom_ribbon <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -48,6 +54,7 @@ geom_ribbon <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) @@ -61,15 +68,26 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, default_aes = aes(colour = NA, fill = "grey20", size = 0.5, linetype = 1, alpha = NA), - required_aes = c("x", "ymin", "ymax"), + required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), + + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) + params + }, + + extra_params = c("na.rm", "orientation"), setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) + if (is.null(data$ymin) && is.null(data$ymax)) { - stop("Either ymin or ymax must be given as an aesthetic.", call. = FALSE) + stop("Either ", flipped_names(params$flipped_aes)$ymin, " or ", + flipped_names(params$flipped_aes)$ymax, " must be given as an aesthetic.", call. = FALSE) } data <- data[order(data$PANEL, data$group, data$x), , drop = FALSE] data$y <- data$ymin %||% data$ymax - data + flip_data(data, params$flipped_aes) }, draw_key = draw_key_polygon, @@ -78,7 +96,8 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, data }, - draw_group = function(data, panel_params, coord, na.rm = FALSE) { + draw_group = function(data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ] data <- data[order(data$group), ] @@ -106,6 +125,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, y = c(data$ymax, rev(data$ymin)), id = c(ids, rev(ids)) )) + + positions <- flip_data(positions, flipped_aes) + munched <- coord_munch(coord, positions, panel_params) ggname("geom_ribbon", polygonGrob( @@ -123,8 +145,8 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, #' @rdname geom_ribbon #' @export geom_area <- function(mapping = NULL, data = NULL, stat = "identity", - position = "stack", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) { + position = "stack", na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE, ...) { layer( data = data, mapping = mapping, @@ -135,6 +157,7 @@ geom_area <- function(mapping = NULL, data = NULL, stat = "identity", inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, ... ) ) @@ -150,7 +173,15 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, required_aes = c("x", "y"), + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) + params + }, + setup_data = function(data, params) { - transform(data[order(data$PANEL, data$group, data$x), ], ymin = 0, ymax = y) + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) + data <- transform(data[order(data$PANEL, data$group, data$x), ], ymin = 0, ymax = y) + flip_data(data, params$flipped_aes) } ) diff --git a/R/geom-smooth.r b/R/geom-smooth.r index a4e224450f..05bd1a8f29 100644 --- a/R/geom-smooth.r +++ b/R/geom-smooth.r @@ -12,9 +12,11 @@ #' `glm()`, where the normal confidence interval is constructed on the link #' scale and then back-transformed to the response scale. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "smooth") #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param geom,stat Use to override the default connection between #' `geom_smooth()` and `stat_smooth()`. #' @seealso See individual modelling functions for more details: @@ -27,6 +29,11 @@ #' geom_point() + #' geom_smooth() #' +#' # If you need the fitting to be done along the y-axis set the orientation +#' ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' geom_smooth(orientation = "y") +#' #' # Use span to control the "wiggliness" of the default loess smoother. #' # The span is the fraction of points used to fit each local regression: #' # small numbers make a wigglier curve, larger numbers make a smoother curve. @@ -82,11 +89,13 @@ geom_smooth <- function(mapping = NULL, data = NULL, formula = NULL, se = TRUE, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { params <- list( na.rm = na.rm, + orientation = orientation, se = se, ... ) @@ -112,6 +121,13 @@ geom_smooth <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomSmooth <- ggproto("GeomSmooth", Geom, + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE, ambiguous = TRUE) + params + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { GeomLine$setup_data(data, params) }, @@ -123,14 +139,16 @@ GeomSmooth <- ggproto("GeomSmooth", Geom, # ribbon won't be drawn either in that case, keeping the overall # behavior predictable and sensible. The user will realize that they # need to set `se = TRUE` to obtain the ribbon and the legend key. - draw_group = function(data, panel_params, coord, se = FALSE) { + draw_group = function(data, panel_params, coord, se = FALSE, flipped_aes = FALSE) { ribbon <- transform(data, colour = NA) path <- transform(data, alpha = NA) - has_ribbon <- se && !is.null(data$ymax) && !is.null(data$ymin) + ymin = flipped_names(flipped_aes)$ymin + ymax = flipped_names(flipped_aes)$ymax + has_ribbon <- se && !is.null(data[[ymax]]) && !is.null(data[[ymin]]) gList( - if (has_ribbon) GeomRibbon$draw_group(ribbon, panel_params, coord), + if (has_ribbon) GeomRibbon$draw_group(ribbon, panel_params, coord, flipped_aes = flipped_aes), GeomLine$draw_panel(path, panel_params, coord) ) }, diff --git a/R/geom-violin.r b/R/geom-violin.r index 5a6be2add9..9a56f34639 100644 --- a/R/geom-violin.r +++ b/R/geom-violin.r @@ -5,9 +5,11 @@ #' violin plot is a mirrored density plot displayed in the same way as a #' boxplot. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("geom", "violin") #' @inheritParams layer -#' @inheritParams geom_point +#' @inheritParams geom_bar #' @param draw_quantiles If `not(NULL)` (default), draw horizontal lines #' at the given quantiles of the density estimate. #' @param trim If `TRUE` (default), trim the tails of the violins @@ -21,6 +23,10 @@ #' p <- ggplot(mtcars, aes(factor(cyl), mpg)) #' p + geom_violin() #' +#' # Orientation follows the discrete axis +#' ggplot(mtcars, aes(mpg, factor(cyl))) + +#' geom_violin() +#' #' \donttest{ #' p + geom_violin() + geom_jitter(height = 0, width = 0.1) #' @@ -75,6 +81,7 @@ geom_violin <- function(mapping = NULL, data = NULL, trim = TRUE, scale = "area", na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -90,6 +97,7 @@ geom_violin <- function(mapping = NULL, data = NULL, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -100,18 +108,28 @@ geom_violin <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomViolin <- ggproto("GeomViolin", Geom, + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) + params + }, + + extra_params = c("na.rm", "orientation"), + setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) - # ymin, ymax, xmin, and xmax define the bounding rectangle for each group - dapply(data, "group", transform, + data <- dapply(data, "group", transform, xmin = x - width / 2, xmax = x + width / 2 ) + flip_data(data, params$flipped_aes) }, - draw_group = function(self, data, ..., draw_quantiles = NULL) { + draw_group = function(self, data, ..., draw_quantiles = NULL, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) # Find the points for the line to go all the way around data <- transform(data, xminv = x - violinwidth * (x - xmin), @@ -127,6 +145,7 @@ GeomViolin <- ggproto("GeomViolin", Geom, # Close the polygon: set first and last point the same # Needed for coord_polar and such newdata <- rbind(newdata, newdata[1,]) + newdata <- flip_data(newdata, flipped_aes) # Draw quantiles if requested, so long as there is non-zero y range if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) { @@ -142,6 +161,7 @@ GeomViolin <- ggproto("GeomViolin", Geom, aesthetics$alpha <- rep(1, nrow(quantiles)) both <- cbind(quantiles, aesthetics) both <- both[!is.na(both$group), , drop = FALSE] + both <- flip_data(both, flipped_aes) quantile_grob <- if (nrow(both) == 0) { zeroGrob() } else { diff --git a/R/ggplot-global.R b/R/ggplot-global.R index e9b871ae6c..2fa0604024 100644 --- a/R/ggplot-global.R +++ b/R/ggplot-global.R @@ -44,3 +44,9 @@ ggplot_global$all_aesthetics <- .all_aesthetics ) ggplot_global$base_to_ggplot <- .base_to_ggplot + +ggplot_global$x_aes <- c("x", "xmin", "xmax", "xend", "xintercept", + "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper", "x0") + +ggplot_global$y_aes <- c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", + "ymax_final", "lower", "middle", "upper", "y0") diff --git a/R/position-dodge.r b/R/position-dodge.r index dd9f67fe52..4730a7fbf3 100644 --- a/R/position-dodge.r +++ b/R/position-dodge.r @@ -89,6 +89,8 @@ PositionDodge <- ggproto("PositionDodge", Position, width = NULL, preserve = "total", setup_params = function(self, data) { + flipped_aes <- has_flipped_aes(data) + data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { warning("Width not defined. Set with `position_dodge(width = ?)`", call. = FALSE) @@ -104,19 +106,22 @@ PositionDodge <- ggproto("PositionDodge", Position, list( width = self$width, - n = n + n = n, + flipped_aes = flipped_aes ) }, setup_data = function(self, data, params) { + data <- flip_data(data, params$flipped_aes) if (!"x" %in% names(data) && all(c("xmin", "xmax") %in% names(data))) { data$x <- (data$xmin + data$xmax) / 2 } - data + flip_data(data, params$flipped_aes) }, compute_panel = function(data, params, scales) { - collide( + data <- flip_data(data, params$flipped_aes) + collided <- collide( data, params$width, name = "position_dodge", @@ -124,6 +129,7 @@ PositionDodge <- ggproto("PositionDodge", Position, n = params$n, check.width = FALSE ) + flip_data(collided, params$flipped_aes) } ) diff --git a/R/position-dodge2.r b/R/position-dodge2.r index 2bab0ba4fc..8cb6cb6d77 100644 --- a/R/position-dodge2.r +++ b/R/position-dodge2.r @@ -24,6 +24,8 @@ PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, reverse = FALSE, setup_params = function(self, data) { + flipped_aes <- has_flipped_aes(data) + data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { warning("Width not defined. Set with `position_dodge2(width = ?)`", call. = FALSE) @@ -48,12 +50,14 @@ PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, width = self$width, n = n, padding = self$padding, - reverse = self$reverse + reverse = self$reverse, + flipped_aes = flipped_aes ) }, compute_panel = function(data, params, scales) { - collide2( + data <- flip_data(data, params$flipped_aes) + collided <- collide2( data, params$width, name = "position_dodge2", @@ -63,6 +67,7 @@ PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, check.width = FALSE, reverse = params$reverse ) + flip_data(collided, params$flipped_aes) } ) diff --git a/R/position-jitterdodge.R b/R/position-jitterdodge.R index 494db5f9f8..eba442395c 100644 --- a/R/position-jitterdodge.R +++ b/R/position-jitterdodge.R @@ -43,6 +43,8 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, required_aes = c("x", "y"), setup_params = function(self, data) { + flipped_aes <- has_flipped_aes(data) + data <- flip_data(data, flipped_aes) width <- self$jitter.width %||% (resolution(data$x, zero = FALSE) * 0.4) # Adjust the x transformation based on the number of 'dodge' variables dodgecols <- intersect(c("fill", "colour", "linetype", "shape", "size", "alpha"), colnames(data)) @@ -56,17 +58,20 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, dodge.width = self$dodge.width, jitter.height = self$jitter.height, jitter.width = width / (ndodge + 2), - seed = self$seed + seed = self$seed, + flipped_aes = flipped_aes ) }, compute_panel = function(data, params, scales) { + data <- flip_data(data, params$flipped_aes) data <- collide(data, params$dodge.width, "position_jitterdodge", pos_dodge, check.width = FALSE) trans_x <- if (params$jitter.width > 0) function(x) jitter(x, amount = params$jitter.width) trans_y <- if (params$jitter.height > 0) function(x) jitter(x, amount = params$jitter.height) - with_seed_null(params$seed, transform_position(data, trans_x, trans_y)) + data <- with_seed_null(params$seed, transform_position(data, trans_x, trans_y)) + flip_data(data, params$flipped_aes) } ) diff --git a/R/position-stack.r b/R/position-stack.r index 7e42a8aef3..2775235a89 100644 --- a/R/position-stack.r +++ b/R/position-stack.r @@ -146,15 +146,19 @@ PositionStack <- ggproto("PositionStack", Position, reverse = FALSE, setup_params = function(self, data) { + flipped_aes <- has_flipped_aes(data) + data <- flip_data(data, flipped_aes) list( var = self$var %||% stack_var(data), fill = self$fill, vjust = self$vjust, - reverse = self$reverse + reverse = self$reverse, + flipped_aes = flipped_aes ) }, setup_data = function(self, data, params) { + data <- flip_data(data, params$flipped_aes) if (is.null(params$var)) { return(data) } @@ -164,14 +168,16 @@ PositionStack <- ggproto("PositionStack", Position, ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) ) - remove_missing( + data <- remove_missing( data, vars = c("x", "xmin", "xmax", "y"), name = "position_stack" ) + flip_data(data, params$flip_data) }, compute_panel = function(data, params, scales) { + data <- flip_data(data, params$flipped_aes) if (is.null(params$var)) { return(data) } @@ -197,7 +203,8 @@ PositionStack <- ggproto("PositionStack", Position, ) } - rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))),] + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))),] + flip_data(data, params$flipped_aes) } ) diff --git a/R/stat-.r b/R/stat-.r index f1b1b77985..dc09bf99ba 100644 --- a/R/stat-.r +++ b/R/stat-.r @@ -144,7 +144,12 @@ Stat <- ggproto("Stat", }, aesthetics = function(self) { - c(union(self$required_aes, names(self$default_aes)), "group") + if (is.null(self$required_aes)) { + required_aes <- NULL + } else { + required_aes <- unlist(strsplit(self$required_aes, '|', fixed = TRUE)) + } + c(union(required_aes, names(self$default_aes)), "group") } ) diff --git a/R/stat-bin.r b/R/stat-bin.r index 591034bbfb..ca4e8163c0 100644 --- a/R/stat-bin.r +++ b/R/stat-bin.r @@ -51,6 +51,7 @@ stat_bin <- function(mapping = NULL, data = NULL, closed = c("right", "left"), pad = FALSE, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -71,6 +72,7 @@ stat_bin <- function(mapping = NULL, data = NULL, closed = closed, pad = pad, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -82,11 +84,21 @@ stat_bin <- function(mapping = NULL, data = NULL, #' @export StatBin <- ggproto("StatBin", Stat, setup_params = function(data, params) { - if (!is.null(data$y) || !is.null(params$y)) { - stop("stat_bin() must not be used with a y aesthetic.", call. = FALSE) + params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) + + has_x <- !(is.null(data$x) && is.null(params$x)) + has_y <- !(is.null(data$y) && is.null(params$y)) + if (!has_x && !has_y) { + stop("stat_bin() requires an x or y aesthetic.", call. = FALSE) + } + if (has_x && has_y) { + stop("stat_bin() can only have an x or y aesthetic.", call. = FALSE) } - if (is.integer(data$x)) { - stop('StatBin requires a continuous x variable: the x variable is discrete. Perhaps you want stat="count"?', + + x <- flipped_names(params$flipped_aes)$x + if (is.integer(data[[x]])) { + stop('StatBin requires a continuous ', x, ' variable: the ', + x, ' variable is discrete. Perhaps you want stat="count"?', call. = FALSE) } @@ -119,34 +131,39 @@ StatBin <- ggproto("StatBin", Stat, params }, + extra_params = c("na.rm", "orientation"), + compute_group = function(data, scales, binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, closed = c("right", "left"), pad = FALSE, - breaks = NULL, + breaks = NULL, flipped_aes = FALSE, # The following arguments are not used, but must # be listed so parameters are computed correctly origin = NULL, right = NULL, drop = NULL, width = NULL) { - + x <- flipped_names(flipped_aes)$x if (!is.null(breaks)) { - if (!scales$x$is_discrete()){ - breaks <- scales$x$transform(breaks) + if (!scales[[x]]$is_discrete()) { + breaks <- scales[[x]]$transform(breaks) } bins <- bin_breaks(breaks, closed) } else if (!is.null(binwidth)) { if (is.function(binwidth)) { - binwidth <- binwidth(data$x) + binwidth <- binwidth(data[[x]]) } - bins <- bin_breaks_width(scales$x$dimension(), binwidth, + bins <- bin_breaks_width(scales[[x]]$dimension(), binwidth, center = center, boundary = boundary, closed = closed) } else { - bins <- bin_breaks_bins(scales$x$dimension(), bins, center = center, + bins <- bin_breaks_bins(scales[[x]]$dimension(), bins, center = center, boundary = boundary, closed = closed) } - bin_vector(data$x, bins, weight = data$weight, pad = pad) + bins <- bin_vector(data[[x]], bins, weight = data$weight, pad = pad) + bins$flipped_aes <- flipped_aes + flip_data(bins, flipped_aes) }, - default_aes = aes(y = stat(count), weight = 1), - required_aes = c("x") + default_aes = aes(x = stat(count), y = stat(count), weight = 1), + + required_aes = "x|y" ) diff --git a/R/stat-boxplot.r b/R/stat-boxplot.r index 618d57e99c..ac8ab5dc27 100644 --- a/R/stat-boxplot.r +++ b/R/stat-boxplot.r @@ -18,6 +18,7 @@ stat_boxplot <- function(mapping = NULL, data = NULL, ..., coef = 1.5, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -30,6 +31,7 @@ stat_boxplot <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( na.rm = na.rm, + orientation = orientation, coef = coef, ... ) @@ -42,9 +44,10 @@ stat_boxplot <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export StatBoxplot <- ggproto("StatBoxplot", Stat, - required_aes = c("y"), + required_aes = c("y|x"), non_missing_aes = "weight", setup_data = function(data, params) { + data <- flip_data(data, params$flipped_aes) data$x <- data$x %||% 0 data <- remove_missing( data, @@ -52,22 +55,34 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, vars = "x", name = "stat_boxplot" ) - data + flip_data(data, params$flipped_aes) }, setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) + data <- flip_data(data, params$flipped_aes) + + has_x <- !(is.null(data$x) && is.null(params$x)) + has_y <- !(is.null(data$y) && is.null(params$y)) + if (!has_x && !has_y) { + stop("stat_boxplot() requires an x or y aesthetic.", call. = FALSE) + } + params$width <- params$width %||% (resolution(data$x %||% 0) * 0.75) if (is.double(data$x) && !has_groups(data) && any(data$x != data$x[1L])) { warning( - "Continuous x aesthetic -- did you forget aes(group=...)?", + "Continuous ", flipped_names(params$flipped_aes)$x, " aesthetic -- did you forget aes(group=...)?", call. = FALSE) } params }, - compute_group = function(data, scales, width = NULL, na.rm = FALSE, coef = 1.5) { + extra_params = c("na.rm", "orientation"), + + compute_group = function(data, scales, width = NULL, na.rm = FALSE, coef = 1.5, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) qs <- c(0, 0.25, 0.5, 0.75, 1) if (!is.null(data$weight)) { @@ -103,6 +118,7 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, df$x <- if (is.factor(data$x)) data$x[1] else mean(range(data$x)) df$width <- width df$relvarwidth <- sqrt(n) - df + df$flipped_aes <- flipped_aes + flip_data(df, flipped_aes) } ) diff --git a/R/stat-count.r b/R/stat-count.r index c08381d8c7..2276f56549 100644 --- a/R/stat-count.r +++ b/R/stat-count.r @@ -16,11 +16,13 @@ stat_count <- function(mapping = NULL, data = NULL, ..., width = NULL, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { params <- list( na.rm = na.rm, + orientation = orientation, width = width, ... ) @@ -46,17 +48,29 @@ stat_count <- function(mapping = NULL, data = NULL, #' @export #' @include stat-.r StatCount <- ggproto("StatCount", Stat, - required_aes = "x", - default_aes = aes(y = stat(count), weight = 1), + required_aes = "x|y", + + default_aes = aes(x = stat(count), y = stat(count), weight = 1), setup_params = function(data, params) { - if (!is.null(data$y)) { - stop("stat_count() must not be used with a y aesthetic.", call. = FALSE) + params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) + + has_x <- !(is.null(data$x) && is.null(params$x)) + has_y <- !(is.null(data$y) && is.null(params$y)) + if (!has_x && !has_y) { + stop("stat_count() requires an x or y aesthetic.", call. = FALSE) + } + if (has_x && has_y) { + stop("stat_count() can only have an x or y aesthetic.", call. = FALSE) } + params }, - compute_group = function(self, data, scales, width = NULL) { + extra_params = c("na.rm", "orientation"), + + compute_group = function(self, data, scales, width = NULL, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) x <- data$x weight <- data$weight %||% rep(1, length(x)) width <- width %||% (resolution(x) * 0.9) @@ -64,11 +78,13 @@ StatCount <- ggproto("StatCount", Stat, count <- as.numeric(tapply(weight, x, sum, na.rm = TRUE)) count[is.na(count)] <- 0 - new_data_frame(list( + bars <- new_data_frame(list( count = count, prop = count / sum(abs(count)), x = sort(unique(x)), - width = width + width = width, + flipped_aes = flipped_aes ), n = length(count)) + flip_data(bars, flipped_aes) } ) diff --git a/R/stat-density.r b/R/stat-density.r index 6d18b8bb12..804d2c6e0c 100644 --- a/R/stat-density.r +++ b/R/stat-density.r @@ -35,6 +35,7 @@ stat_density <- function(mapping = NULL, data = NULL, n = 512, trim = FALSE, na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -53,6 +54,7 @@ stat_density <- function(mapping = NULL, data = NULL, n = n, trim = trim, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -63,19 +65,37 @@ stat_density <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export StatDensity <- ggproto("StatDensity", Stat, - required_aes = "x", - default_aes = aes(y = stat(density), fill = NA, weight = NULL), + required_aes = "x|y", + + default_aes = aes(x = stat(density), y = stat(density), fill = NA, weight = NULL), + + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE) + + has_x <- !(is.null(data$x) && is.null(params$x)) + has_y <- !(is.null(data$y) && is.null(params$y)) + if (!has_x && !has_y) { + stop("stat_density() requires an x or y aesthetic.", call. = FALSE) + } + + params + }, + + extra_params = c("na.rm", "orientation"), compute_group = function(data, scales, bw = "nrd0", adjust = 1, kernel = "gaussian", - n = 512, trim = FALSE, na.rm = FALSE) { + n = 512, trim = FALSE, na.rm = FALSE, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) if (trim) { range <- range(data$x, na.rm = TRUE) } else { - range <- scales$x$dimension() + range <- scales[[flipped_names(flipped_aes)$x]]$dimension() } - compute_density(data$x, data$weight, from = range[1], to = range[2], - bw = bw, adjust = adjust, kernel = kernel, n = n) + density <- compute_density(data$x, data$weight, from = range[1], + to = range[2], bw = bw, adjust = adjust, kernel = kernel, n = n) + density$flipped_aes <- flipped_aes + flip_data(density, flipped_aes) } ) diff --git a/R/stat-smooth.r b/R/stat-smooth.r index a1cc84d762..31a7941bb2 100644 --- a/R/stat-smooth.r +++ b/R/stat-smooth.r @@ -50,6 +50,7 @@ stat_smooth <- function(mapping = NULL, data = NULL, level = 0.95, method.args = list(), na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { layer( @@ -68,6 +69,7 @@ stat_smooth <- function(mapping = NULL, data = NULL, fullrange = fullrange, level = level, na.rm = na.rm, + orientation = orientation, method.args = method.args, span = span, ... @@ -81,6 +83,7 @@ stat_smooth <- function(mapping = NULL, data = NULL, #' @export StatSmooth <- ggproto("StatSmooth", Stat, setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) msg <- character() if (is.null(params$method) || identical(params$method, "auto")) { # Use loess for small datasets, gam with a cubic regression basis for @@ -115,10 +118,13 @@ StatSmooth <- ggproto("StatSmooth", Stat, params }, + extra_params = c("na.rm", "orientation"), + compute_group = function(data, scales, method = NULL, formula = NULL, se = TRUE, n = 80, span = 0.75, fullrange = FALSE, xseq = NULL, level = 0.95, method.args = list(), - na.rm = FALSE) { + na.rm = FALSE, flipped_aes = NA) { + data <- flip_data(data, flipped_aes) if (length(unique(data$x)) < 2) { # Not enough data to perform fit return(new_data_frame()) @@ -163,7 +169,9 @@ StatSmooth <- ggproto("StatSmooth", Stat, base.args <- list(quote(formula), data = quote(data), weights = quote(weight)) model <- do.call(method, c(base.args, method.args)) - predictdf(model, xseq, se, level) + prediction <- predictdf(model, xseq, se, level) + prediction$flipped_aes <- flipped_aes + flip_data(prediction, flipped_aes) }, required_aes = c("x", "y") diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index 0aa8a2dcaa..811f598faa 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -5,16 +5,30 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, geom = "pointrange", position = "identity", ..., fun.data = NULL, - fun.y = NULL, - fun.ymax = NULL, - fun.ymin = NULL, + fun = NULL, + fun.max = NULL, + fun.min = NULL, fun.args = list(), bins = 30, binwidth = NULL, breaks = NULL, na.rm = FALSE, + orientation = NA, show.legend = NA, - inherit.aes = TRUE) { + inherit.aes = TRUE, + fun.y, fun.ymin, fun.ymax) { + if (!missing(fun.y)) { + warn("`fun.y` is deprecated. Use `fun` instead.") + fun = fun %||% fun.y + } + if (!missing(fun.ymin)) { + warn("`fun.ymin` is deprecated. Use `fun.min` instead.") + fun.min = fun.min %||% fun.ymin + } + if (!missing(fun.ymax)) { + warn("`fun.ymax` is deprecated. Use `fun.max` instead.") + fun.max = fun.max %||% fun.ymax + } layer( data = data, mapping = mapping, @@ -25,14 +39,15 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( fun.data = fun.data, - fun.y = fun.y, - fun.ymax = fun.ymax, - fun.ymin = fun.ymin, + fun = fun, + fun.max = fun.max, + fun.min = fun.min, fun.args = fun.args, bins = bins, binwidth = binwidth, breaks = breaks, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -45,30 +60,38 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, StatSummaryBin <- ggproto("StatSummaryBin", Stat, required_aes = c("x", "y"), - compute_group = function(data, scales, fun.data = NULL, fun.y = NULL, - fun.ymax = NULL, fun.ymin = NULL, fun.args = list(), - bins = 30, binwidth = NULL, breaks = NULL, - origin = NULL, right = FALSE, na.rm = FALSE) { - - fun <- make_summary_fun(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) + extra_params = c("na.rm", "orientation"), + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) + params + }, - breaks <- bin2d_breaks(scales$x, breaks, origin, binwidth, bins, right = right) + compute_group = function(data, scales, fun.data = NULL, fun = NULL, + fun.max = NULL, fun.min = NULL, fun.args = list(), + bins = 30, binwidth = NULL, breaks = NULL, + origin = NULL, right = FALSE, na.rm = FALSE, + flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) + fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args) + x <- flipped_names(flipped_aes)$x + breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, right = right) data$bin <- cut(data$x, breaks, include.lowest = TRUE, labels = FALSE) out <- dapply(data, "bin", fun) locs <- bin_loc(breaks, out$bin) out$x <- locs$mid - out$width <- if (scales$x$is_discrete()) 0.9 else locs$length - out + out$width <- if (scales[[x]]$is_discrete()) 0.9 else locs$length + out$flipped_aes <- flipped_aes + flip_data(out, flipped_aes) } ) -make_summary_fun <- function(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) { +make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { force(fun.data) - force(fun.y) - force(fun.ymax) - force(fun.ymin) + force(fun) + force(fun.max) + force(fun.min) force(fun.args) if (!is.null(fun.data)) { @@ -77,7 +100,7 @@ make_summary_fun <- function(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) { function(df) { do.call(fun.data, c(list(quote(df$y)), fun.args)) } - } else if (!is.null(fun.y) || !is.null(fun.ymax) || !is.null(fun.ymin)) { + } else if (!is.null(fun) || !is.null(fun.max) || !is.null(fun.min)) { # Three functions that take vectors as inputs call_f <- function(fun, x) { @@ -87,9 +110,9 @@ make_summary_fun <- function(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) { function(df, ...) { new_data_frame(list( - ymin = call_f(fun.ymin, df$y), - y = call_f(fun.y, df$y), - ymax = call_f(fun.ymax, df$y) + ymin = call_f(fun.min, df$y), + y = call_f(fun, df$y), + ymax = call_f(fun.max, df$y) )) } } else { diff --git a/R/stat-summary.r b/R/stat-summary.r index 27ed095e3f..b4a43ebb8d 100644 --- a/R/stat-summary.r +++ b/R/stat-summary.r @@ -1,66 +1,84 @@ #' Summarise y values at unique/binned x #' -#' `stat_summary` operates on unique `x`; `stat_summary_bin` -#' operates on binned `x`. They are more flexible versions of +#' `stat_summary` operates on unique `x` or `y`; `stat_summary_bin` +#' operates on binned `x` or `y`. They are more flexible versions of #' [stat_bin()]: instead of just counting, they can compute any #' aggregate. #' +#' @eval rd_orientation() +#' #' @eval rd_aesthetics("stat", "summary") #' @seealso [geom_errorbar()], [geom_pointrange()], #' [geom_linerange()], [geom_crossbar()] for geoms to #' display summarised data #' @inheritParams stat_identity #' @section Summary functions: -#' You can either supply summary functions individually (`fun.y`, -#' `fun.ymax`, `fun.ymin`), or as a single function (`fun.data`): +#' You can either supply summary functions individually (`fun`, +#' `fun.max`, `fun.min`), or as a single function (`fun.data`): #' #' \describe{ #' \item{fun.data}{Complete summary function. Should take numeric vector as #' input and return data frame as output} -#' \item{fun.ymin}{ymin summary function (should take numeric vector and +#' \item{fun.min}{min summary function (should take numeric vector and #' return single number)} -#' \item{fun.y}{y summary function (should take numeric vector and return +#' \item{fun}{main summary function (should take numeric vector and return #' single number)} -#' \item{fun.ymax}{ymax summary function (should take numeric vector and +#' \item{fun.max}{max summary function (should take numeric vector and #' return single number)} #' } #' #' A simple vector function is easiest to work with as you can return a single #' number, but is somewhat less flexible. If your summary function computes -#' multiple values at once (e.g. ymin and ymax), use `fun.data`. +#' multiple values at once (e.g. min and max), use `fun.data`. +#' +#' `fun.data` will recieve data as if it was oriented along the x-axis and +#' should return a data.frame that corresponds to that orientation. The layer +#' will take care of flipping the input and output if it is oriented along the +#' y-axis. #' #' If no aggregation functions are supplied, will default to #' [mean_se()]. #' #' @param fun.data A function that is given the complete data and should #' return a data frame with variables `ymin`, `y`, and `ymax`. -#' @param fun.ymin,fun.y,fun.ymax Alternatively, supply three individual -#' functions that are each passed a vector of x's and should return a +#' @param fun.min,fun,fun.max Alternatively, supply three individual +#' functions that are each passed a vector of values and should return a #' single number. +#' @param fun.ymin,fun.y,fun.ymax Deprecated, use the versions specified above +#' instead. #' @param fun.args Optional additional arguments passed on to the functions. #' @export #' @examples #' d <- ggplot(mtcars, aes(cyl, mpg)) + geom_point() #' d + stat_summary(fun.data = "mean_cl_boot", colour = "red", size = 2) #' +#' # Orientation follows the discrete axis +#' ggplot(mtcars, aes(mpg, cyl)) + +#' geom_point() + +#' stat_summary(fun.data = "mean_cl_boot", colour = "red", size = 2) +#' #' # You can supply individual functions to summarise the value at #' # each x: -#' d + stat_summary(fun.y = "median", colour = "red", size = 2, geom = "point") -#' d + stat_summary(fun.y = "mean", colour = "red", size = 2, geom = "point") -#' d + aes(colour = factor(vs)) + stat_summary(fun.y = mean, geom="line") +#' d + stat_summary(fun = "median", colour = "red", size = 2, geom = "point") +#' d + stat_summary(fun = "mean", colour = "red", size = 2, geom = "point") +#' d + aes(colour = factor(vs)) + stat_summary(fun = mean, geom="line") #' -#' d + stat_summary(fun.y = mean, fun.ymin = min, fun.ymax = max, +#' d + stat_summary(fun = mean, fun.min = min, fun.max = max, #' colour = "red") #' #' d <- ggplot(diamonds, aes(cut)) #' d + geom_bar() -#' d + stat_summary_bin(aes(y = price), fun.y = "mean", geom = "bar") +#' d + stat_summary(aes(y = price), fun = "mean", geom = "bar") +#' +#' # Orientation of stat_summary_bin is ambiguous and must be specified directly +#' ggplot(diamonds, aes(carat, price)) + +#' stat_summary_bin(fun = "mean", geom = "bar", orientation = 'y') #' #' \donttest{ #' # Don't use ylim to zoom into a summary plot - this throws the #' # data away #' p <- ggplot(mtcars, aes(cyl, mpg)) + -#' stat_summary(fun.y = "mean", geom = "point") +#' stat_summary(fun = "mean", geom = "point") #' p #' p + ylim(15, 30) #' # Instead use coord_cartesian @@ -105,13 +123,27 @@ stat_summary <- function(mapping = NULL, data = NULL, geom = "pointrange", position = "identity", ..., fun.data = NULL, - fun.y = NULL, - fun.ymax = NULL, - fun.ymin = NULL, + fun = NULL, + fun.max = NULL, + fun.min = NULL, fun.args = list(), na.rm = FALSE, + orientation = NA, show.legend = NA, - inherit.aes = TRUE) { + inherit.aes = TRUE, + fun.y, fun.ymin, fun.ymax) { + if (!missing(fun.y)) { + warn("`fun.y` is deprecated. Use `fun` instead.") + fun = fun %||% fun.y + } + if (!missing(fun.ymin)) { + warn("`fun.ymin` is deprecated. Use `fun.min` instead.") + fun.min = fun.min %||% fun.ymin + } + if (!missing(fun.ymax)) { + warn("`fun.ymax` is deprecated. Use `fun.max` instead.") + fun.max = fun.max %||% fun.ymax + } layer( data = data, mapping = mapping, @@ -122,11 +154,12 @@ stat_summary <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list( fun.data = fun.data, - fun.y = fun.y, - fun.ymax = fun.ymax, - fun.ymin = fun.ymin, + fun = fun, + fun.max = fun.max, + fun.min = fun.min, fun.args = fun.args, na.rm = na.rm, + orientation = orientation, ... ) ) @@ -139,12 +172,20 @@ stat_summary <- function(mapping = NULL, data = NULL, StatSummary <- ggproto("StatSummary", Stat, required_aes = c("x", "y"), - compute_panel = function(data, scales, fun.data = NULL, fun.y = NULL, - fun.ymax = NULL, fun.ymin = NULL, fun.args = list(), - na.rm = FALSE) { + extra_params = c("na.rm", "orientation"), + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params) + params + }, - fun <- make_summary_fun(fun.data, fun.y, fun.ymax, fun.ymin, fun.args) - summarise_by_x(data, fun) + compute_panel = function(data, scales, fun.data = NULL, fun = NULL, + fun.max = NULL, fun.min = NULL, fun.args = list(), + na.rm = FALSE, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) + fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args) + summarised <- summarise_by_x(data, fun) + summarised$flipped_aes <- flipped_aes + flip_data(summarised, flipped_aes) } ) diff --git a/R/stat-ydensity.r b/R/stat-ydensity.r index 978f60ad0c..b246c477fa 100644 --- a/R/stat-ydensity.r +++ b/R/stat-ydensity.r @@ -27,6 +27,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL, trim = TRUE, scale = "area", na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE) { scale <- match.arg(scale, c("area", "count", "width")) @@ -60,8 +61,16 @@ StatYdensity <- ggproto("StatYdensity", Stat, required_aes = c("x", "y"), non_missing_aes = "weight", + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) + + params + }, + + extra_params = c("na.rm", "orientation"), + compute_group = function(data, scales, width = NULL, bw = "nrd0", adjust = 1, - kernel = "gaussian", trim = TRUE, na.rm = FALSE) { + kernel = "gaussian", trim = TRUE, na.rm = FALSE, flipped_aes = FALSE) { if (nrow(data) < 3) return(new_data_frame()) range <- range(data$y, na.rm = TRUE) modifier <- if (trim) 0 else 3 @@ -83,7 +92,8 @@ StatYdensity <- ggproto("StatYdensity", Stat, compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, na.rm = FALSE, - scale = "area") { + scale = "area", flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) data <- ggproto_parent(Stat, self)$compute_panel( data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel, trim = trim, na.rm = na.rm @@ -100,7 +110,8 @@ StatYdensity <- ggproto("StatYdensity", Stat, # width: constant width (density scaled to a maximum of 1) width = data$scaled ) - data + data$flipped_aes <- flipped_aes + flip_data(data, flipped_aes) } ) diff --git a/R/utilities-help.r b/R/utilities-help.r index bff0a4fbe3..341fe257d1 100644 --- a/R/utilities-help.r +++ b/R/utilities-help.r @@ -21,6 +21,7 @@ rd_aesthetics <- function(type, name) { rd_aesthetics_item <- function(x) { req <- x$required_aes + req <- sub("|", "} \\emph{or} \\code{", req, fixed = TRUE) all <- union(req, sort(x$aesthetics())) ifelse(all %in% req, @@ -28,3 +29,19 @@ rd_aesthetics_item <- function(x) { paste0("\\code{", all, "}") ) } + +rd_orientation <- function() { + c( + "@section Orientation: ", + paste( + 'This geom treats each axis differently and, thus, can thus have two orientations.', + 'Often the orientation is easy to deduce from a combination of the given', + 'mappings and the types of positional scales in use. Thus, ggplot2 will by', + 'default try to guess which orientation the layer should have. Under rare', + 'circumstances, the orientation is ambiguous and guessing may fail. In that', + 'case the orientation can be specified directly using the \\code{orientation} parameter,', + 'which can be either \\code{"x"} or \\code{"y"}. The value gives the axis that the geom', + 'should run along, \\code{"x"} being the default orientation you would expect for the geom.' + ) + ) +} diff --git a/R/utilities.r b/R/utilities.r index 29edb19f16..3334463ab0 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -24,11 +24,23 @@ scales::alpha # @param name of object for error message # @keyword internal check_required_aesthetics <- function(required, present, name) { - missing_aes <- setdiff(required, present) - if (length(missing_aes) == 0) return() + if (is.null(required)) return() + + required <- strsplit(required, "|", fixed = TRUE) + if (any(vapply(required, length, integer(1)) > 1)) { + required <- lapply(required, rep_len, 2) + required <- list( + vapply(required, `[`, character(1), 1), + vapply(required, `[`, character(1), 2) + ) + } else { + required <- list(unlist(required)) + } + missing_aes <- lapply(required, setdiff, present) + if (any(vapply(missing_aes, length, integer(1)) == 0)) return() stop(name, " requires the following missing aesthetics: ", - paste(missing_aes, collapse = ", "), call. = FALSE) + paste(lapply(missing_aes, paste, collapse = ", "), collapse = " or "), call. = FALSE) } # Concatenate a named list for output @@ -394,3 +406,214 @@ parse_safe <- function(text) { } out } + +switch_orientation <- function(aesthetics) { + # We should have these as globals somewhere + x <- ggplot_global$x_aes + y <- ggplot_global$y_aes + x_aes <- match(aesthetics, x) + x_aes_pos <- which(!is.na(x_aes)) + y_aes <- match(aesthetics, y) + y_aes_pos <- which(!is.na(y_aes)) + if (length(x_aes_pos) > 0) { + aesthetics[x_aes_pos] <- y[x_aes[x_aes_pos]] + } + if (length(y_aes_pos) > 0) { + aesthetics[y_aes_pos] <- x[y_aes[y_aes_pos]] + } + aesthetics +} + +#' Utilities for working with bidirecitonal layers +#' +#' These functions are what underpins the ability of certain geoms to work +#' automatically in both directions. See the *Extending ggplot2* for how they +#' are used when implementing `Geom`, `Stat`, and `Position` classes. +#' +#' `has_flipped_aes()` is used to sniff out the orientation of the layer from +#' the data. It has a range of arguments that can be used to finetune the +#' sniffing based on what the data should look like. `flip_data()` will switch +#' the column names of the data so that it looks like x-oriented data. +#' `flipped_names()` provides a named list of aesthetic names that corresponds +#' to the orientation of the layer. +#' +#' @section Controlling the sniffing: +#' How the layer data should be interpreted depends on its specific features. +#' `has_flipped_aes()` contains a range of flags for defining what certain +#' features in the data correspond to: +#' +#' - `main_is_orthogonal`: This argument controls how the existence of only a `x` +#' or `y` aesthetic is understood. If `TRUE` then the exisiting aesthetic +#' would be then secondary axis. This behaviour is present in [stat_ydensity()] +#' and [stat_boxplot()]. If `FALSE` then the exisiting aesthetic is the main +#' axis as seen in e.g. [stat_bin()], [geom_count()], and [stat_density()]. +#' - `range_is_orthogonal`: This argument controls whether the existance of +#' range-like aesthetics (e.g. `xmin` and `xmax`) represents the main or +#' secondary axis. If `TRUE` then the range is given for the secondary axis as +#' seen in e.g. [geom_ribbon()] and [geom_linerange()]. `FALSE` is less +#' prevalent but can be seen in [geom_bar()] where it may encode the span of +#' each bar. +#' - `group_has_equal`: This argument controls whether to test for equality of +#' all `x` and `y` values inside each group and set the main axis to the one +#' where all is equal. This test is only performed if `TRUE`, and only after +#' less computationally heavy tests has come up empty handed. Examples are +#' [stat_boxplot()] and [stat_ydensity] +#' - `ambiguous`: This argument tells the function that the layer, while +#' bidirectional, doesn't treat each axis differently. It will circumvent any +#' data based guessing and only take hint from the `orientation` element in +#' `params`. If this is not present it will fall back to `FALSE`. Examples are +#' [geom_line()] and [geom_area()] +#' - `main_is_continuous`: This argument controls how the test for discreteness +#' in the scales should be interpreted. If `TRUE` then the main axis will be +#' the one which is not discrete-like. Conversely, if `FALSE` the main axis +#' will be the discrete-like one. Examples of `TRUE` is [stat_density()] and +#' [stat_bin()], while examples of `FALSE` is [stat_ydensity()] and +#' [stat_boxplot()] +#' +#' @param data The layer data +#' @param params The parameters of the `Stat`/`Geom`. Only the `orientation` +#' parameter will be used. +#' @param main_is_orthogonal If only `x` or `y` are present do they correspond +#' to the main orientation or the reverse. E.g. If `TRUE` and `y` is present +#' it is not flipped. If `NA` this check will be ignored. +#' @param range_is_orthogonal If `xmin`/`xmax` or `ymin`/`ymax` is present do +#' they correspond to the main orientation or reverse. If `NA` this check will +#' be ignored. +#' @param group_has_equal Is it expected that grouped data has either a single +#' `x` or `y` value that will correspond to the orientation. +#' @param ambiguous Is the layer ambiguous in its mapping by nature. If so, it +#' will only be flipped if `params$orientation == "y"` +#' @param main_is_continuous If there is a discrete and continuous axis, does +#' the continuous one correspond to the main orientation? +#' @param flip Logical. Is the layer flipped. +#' +#' @return `has_flipped_aes()` returns `TRUE` if it detects a layer in the other +#' orientation and `FALSE` otherwise. `flip_data()` will return the input +#' unchanged if `flip = FALSE` and the data with flipped aesthetic names if +#' `flip = TRUE`. `flipped_names()` returns a named list of strings. If +#' `flip = FALSE` the name of the element will correspond to the element, e.g. +#' `flipped_names(FALSE)$x == "x"` and if `flip = TRUE` it will correspond to +#' the flipped name, e.g. `flipped_names(FALSE)$x == "y"` +#' +#' @export +#' @keywords internal +#' @name bidirection +#' +has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA, + range_is_orthogonal = NA, group_has_equal = FALSE, + ambiguous = FALSE, main_is_continuous = FALSE) { + # Is orientation already encoded in data? + if (!is.null(data$flipped_aes)) { + return(data$flipped_aes[[1]]) + } + + # Is orientation requested in the params + if (!is.null(params$orientation) && !is.na(params$orientation)) { + return(params$orientation == "y") + } + + # Does a single x or y aesthetic corespond to a specific orientation + if (!is.na(main_is_orthogonal) && sum(c("x", "y") %in% names(data)) + sum(c("x", "y") %in% names(params)) == 1) { + return(("x" %in% names(data) || "x" %in% names(params)) == main_is_orthogonal) + } + + has_x <- !is.null(data$x) + has_y <- !is.null(data$y) + + # Does a provided range indicate an orientation + if (!is.na(range_is_orthogonal)) { + if (any(c("ymin", "ymax") %in% names(data))) { + return(!range_is_orthogonal) + } + if (any(c("xmin", "xmax") %in% names(data))) { + return(range_is_orthogonal) + } + } + + # If ambiguous orientation = NA will give FALSE + if (ambiguous && (is.null(params$orientation) || is.na(params$orientation))) { + return(FALSE) + } + + # Is there a single actual discrete position + y_is_int <- is.integer(data$y) + x_is_int <- is.integer(data$x) + if (xor(y_is_int, x_is_int)) { + return(y_is_int != main_is_continuous) + } + + # Does each group have a single x or y value + if (group_has_equal) { + if (has_x) { + x_groups <- vapply(split(data$x, data$group), function(x) length(unique(x)), integer(1)) + if (all(x_groups == 1)) { + return(FALSE) + } + } + if (has_y) { + y_groups <- vapply(split(data$y, data$group), function(x) length(unique(x)), integer(1)) + if (all(y_groups == 1)) { + return(TRUE) + } + } + } + + # give up early + if (!has_x && !has_y) { + return(FALSE) + } + + # Both true discrete. give up + if (y_is_int && x_is_int) { + return(FALSE) + } + # Is there a single discrete-like position + y_is_int <- if (has_y) isTRUE(all.equal(data$y, round(data$y))) else FALSE + x_is_int <- if (has_x) isTRUE(all.equal(data$x, round(data$x))) else FALSE + if (xor(y_is_int, x_is_int)) { + return(y_is_int != main_is_continuous) + } + # Is one of the axes a single value + if (all(data$x == 1)) { + return(main_is_continuous) + } + if (all(data$y == 1)) { + return(!main_is_continuous) + } + # If both are discrete like, which have most 0 or 1-spaced values + y_diff <- diff(sort(data$y)) + x_diff <- diff(sort(data$x)) + if (y_is_int && x_is_int) { + return((sum(x_diff <= 1) < sum(y_diff <= 1)) != main_is_continuous) + } + # If none are discrete is either regularly spaced + y_is_regular <- if (has_y) all((y_diff / min(y_diff)) %% 1 < .Machine$double.eps) else FALSE + x_is_regular <- if (has_x) all((x_diff / min(x_diff)) %% 1 < .Machine$double.eps) else FALSE + if (xor(y_is_regular, x_is_regular)) { + return(y_is_regular != main_is_continuous) + } + # default to no + FALSE +} +#' @rdname bidirection +#' @export +flip_data <- function(data, flip = NULL) { + flip <- flip %||% data$flipped_aes[1] %||% FALSE + if (flip) { + names(data) <- switch_orientation(names(data)) + } + data +} +#' @rdname bidirection +#' @export +flipped_names <- function(flip = FALSE) { + x_aes <- ggplot_global$x_aes + y_aes <- ggplot_global$y_aes + if (flip) { + ret <- as.list(c(y_aes, x_aes)) + } else { + ret <- as.list(c(x_aes, y_aes)) + } + names(ret) <- c(x_aes, y_aes) + ret +} diff --git a/man/bidirection.Rd b/man/bidirection.Rd new file mode 100644 index 0000000000..1542f5780a --- /dev/null +++ b/man/bidirection.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.r +\name{bidirection} +\alias{bidirection} +\alias{has_flipped_aes} +\alias{flip_data} +\alias{flipped_names} +\title{Utilities for working with bidirecitonal layers} +\usage{ +has_flipped_aes(data, params = list(), main_is_orthogonal = NA, + range_is_orthogonal = NA, group_has_equal = FALSE, + ambiguous = FALSE, main_is_continuous = FALSE) + +flip_data(data, flip = NULL) + +flipped_names(flip = FALSE) +} +\arguments{ +\item{data}{The layer data} + +\item{params}{The parameters of the \code{Stat}/\code{Geom}. Only the \code{orientation} +parameter will be used.} + +\item{main_is_orthogonal}{If only \code{x} or \code{y} are present do they correspond +to the main orientation or the reverse. E.g. If \code{TRUE} and \code{y} is present +it is not flipped. If \code{NA} this check will be ignored.} + +\item{range_is_orthogonal}{If \code{xmin}/\code{xmax} or \code{ymin}/\code{ymax} is present do +they correspond to the main orientation or reverse. If \code{NA} this check will +be ignored.} + +\item{group_has_equal}{Is it expected that grouped data has either a single +\code{x} or \code{y} value that will correspond to the orientation.} + +\item{ambiguous}{Is the layer ambiguous in its mapping by nature. If so, it +will only be flipped if \code{params$orientation == "y"}} + +\item{main_is_continuous}{If there is a discrete and continuous axis, does +the continuous one correspond to the main orientation?} + +\item{flip}{Logical. Is the layer flipped.} +} +\value{ +\code{has_flipped_aes()} returns \code{TRUE} if it detects a layer in the other +orientation and \code{FALSE} otherwise. \code{flip_data()} will return the input +unchanged if \code{flip = FALSE} and the data with flipped aesthetic names if +\code{flip = TRUE}. \code{flipped_names()} returns a named list of strings. If +\code{flip = FALSE} the name of the element will correspond to the element, e.g. +\code{flipped_names(FALSE)$x == "x"} and if \code{flip = TRUE} it will correspond to +the flipped name, e.g. \code{flipped_names(FALSE)$x == "y"} +} +\description{ +These functions are what underpins the ability of certain geoms to work +automatically in both directions. See the \emph{Extending ggplot2} for how they +are used when implementing \code{Geom}, \code{Stat}, and \code{Position} classes. +} +\details{ +\code{has_flipped_aes()} is used to sniff out the orientation of the layer from +the data. It has a range of arguments that can be used to finetune the +sniffing based on what the data should look like. \code{flip_data()} will switch +the column names of the data so that it looks like x-oriented data. +\code{flipped_names()} provides a named list of aesthetic names that corresponds +to the orientation of the layer. +} +\section{Controlling the sniffing}{ + +How the layer data should be interpreted depends on its specific features. +\code{has_flipped_aes()} contains a range of flags for defining what certain +features in the data correspond to: +\itemize{ +\item \code{main_is_orthogonal}: This argument controls how the existence of only a \code{x} +or \code{y} aesthetic is understood. If \code{TRUE} then the exisiting aesthetic +would be then secondary axis. This behaviour is present in \code{\link[=stat_ydensity]{stat_ydensity()}} +and \code{\link[=stat_boxplot]{stat_boxplot()}}. If \code{FALSE} then the exisiting aesthetic is the main +axis as seen in e.g. \code{\link[=stat_bin]{stat_bin()}}, \code{\link[=geom_count]{geom_count()}}, and \code{\link[=stat_density]{stat_density()}}. +\item \code{range_is_orthogonal}: This argument controls whether the existance of +range-like aesthetics (e.g. \code{xmin} and \code{xmax}) represents the main or +secondary axis. If \code{TRUE} then the range is given for the secondary axis as +seen in e.g. \code{\link[=geom_ribbon]{geom_ribbon()}} and \code{\link[=geom_linerange]{geom_linerange()}}. \code{FALSE} is less +prevalent but can be seen in \code{\link[=geom_bar]{geom_bar()}} where it may encode the span of +each bar. +\item \code{group_has_equal}: This argument controls whether to test for equality of +all \code{x} and \code{y} values inside each group and set the main axis to the one +where all is equal. This test is only performed if \code{TRUE}, and only after +less computationally heavy tests has come up empty handed. Examples are +\code{\link[=stat_boxplot]{stat_boxplot()}} and \link{stat_ydensity} +\item \code{ambiguous}: This argument tells the function that the layer, while +bidirectional, doesn't treat each axis differently. It will circumvent any +data based guessing and only take hint from the \code{orientation} element in +\code{params}. If this is not present it will fall back to \code{FALSE}. Examples are +\code{\link[=geom_line]{geom_line()}} and \code{\link[=geom_area]{geom_area()}} +\item \code{main_is_continuous}: This argument controls how the test for discreteness +in the scales should be interpreted. If \code{TRUE} then the main axis will be +the one which is not discrete-like. Conversely, if \code{FALSE} the main axis +will be the discrete-like one. Examples of \code{TRUE} is \code{\link[=stat_density]{stat_density()}} and +\code{\link[=stat_bin]{stat_bin()}}, while examples of \code{FALSE} is \code{\link[=stat_ydensity]{stat_ydensity()}} and +\code{\link[=stat_boxplot]{stat_boxplot()}} +} +} + +\keyword{internal} diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index d6245de4a9..aa3d2737e8 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -8,7 +8,8 @@ \usage{ geom_bar(mapping = NULL, data = NULL, stat = "count", position = "stack", ..., width = NULL, binwidth = NULL, - na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + na.rm = FALSE, orientation = NA, show.legend = NA, + inherit.aes = TRUE) geom_col(mapping = NULL, data = NULL, position = "stack", ..., width = NULL, na.rm = FALSE, show.legend = NA, @@ -16,7 +17,7 @@ geom_col(mapping = NULL, data = NULL, position = "stack", ..., stat_count(mapping = NULL, data = NULL, geom = "bar", position = "stack", ..., width = NULL, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -56,6 +57,11 @@ you use it you'll get an warning telling to you use \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -91,6 +97,11 @@ side-to-side, use \code{\link[=position_dodge]{position_dodge()}} or \code{\link \code{\link[=position_fill]{position_fill()}} shows relative proportions at each \code{x} by stacking the bars and then standardising each bar to have the same height. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_bar()} understands the following aesthetics (required aesthetics are in bold): @@ -123,9 +134,10 @@ Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. \code{stat_count()} understands the following aesthetics (required aesthetics are in bold): \itemize{ -\item \strong{\code{x}} +\item \strong{\code{x} \emph{or} \code{y}} \item \code{group} \item \code{weight} +\item \code{x} \item \code{y} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. @@ -147,17 +159,18 @@ g <- ggplot(mpg, aes(class)) g + geom_bar() # Total engine displacement of each class g + geom_bar(aes(weight = displ)) +# Map class to y instead to flip the orientation +ggplot(mpg) + geom_bar(aes(y = class)) # Bar charts are automatically stacked when multiple bars are placed # at the same location. The order of the fill is designed to match # the legend g + geom_bar(aes(fill = drv)) -# If you need to flip the order (because you've flipped the plot) +# If you need to flip the order (because you've flipped the orientation) # call position_stack() explicitly: -g + +ggplot(mpg, aes(y = class)) + geom_bar(aes(fill = drv), position = position_stack(reverse = TRUE)) + - coord_flip() + theme(legend.position = "top") # To show (e.g.) means, you need geom_col() diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index 19b56385ec..32d492425c 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -10,11 +10,11 @@ geom_boxplot(mapping = NULL, data = NULL, stat = "boxplot", outlier.color = NULL, outlier.fill = NULL, outlier.shape = 19, outlier.size = 1.5, outlier.stroke = 0.5, outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, varwidth = FALSE, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) stat_boxplot(mapping = NULL, data = NULL, geom = "boxplot", position = "dodge2", ..., coef = 1.5, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -73,6 +73,11 @@ weighted, using the \code{weight} aesthetic).} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -94,6 +99,11 @@ The boxplot compactly displays the distribution of a continuous variable. It visualises five summary statistics (the median, two hinges and two whiskers), and all "outlying" points individually. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Summary statistics}{ The lower and upper hinges correspond to the first and third quartiles @@ -118,20 +128,32 @@ See McGill et al. (1978) for more details. \code{geom_boxplot()} understands the following aesthetics (required aesthetics are in bold): \itemize{ -\item \strong{\code{x}} -\item \strong{\code{lower}} -\item \strong{\code{upper}} -\item \strong{\code{middle}} -\item \strong{\code{ymin}} -\item \strong{\code{ymax}} +\item \strong{\code{x} \emph{or} \code{y}} +\item \strong{\code{lower} \emph{or} \code{xlower}} +\item \strong{\code{upper} \emph{or} \code{xupper}} +\item \strong{\code{middle} \emph{or} \code{xmiddle}} +\item \strong{\code{ymin} \emph{or} \code{xmin}} +\item \strong{\code{ymax} \emph{or} \code{xmax}} \item \code{alpha} \item \code{colour} \item \code{fill} \item \code{group} \item \code{linetype} +\item \code{lower} +\item \code{middle} \item \code{shape} \item \code{size} +\item \code{upper} \item \code{weight} +\item \code{x} +\item \code{xlower} +\item \code{xmax} +\item \code{xmiddle} +\item \code{xmin} +\item \code{xupper} +\item \code{y} +\item \code{ymax} +\item \code{ymin} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -153,7 +175,8 @@ Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. \examples{ p <- ggplot(mpg, aes(class, hwy)) p + geom_boxplot() -p + geom_boxplot() + coord_flip() +# Orientation follows the discrete axis +ggplot(mpg, aes(hwy, class)) + geom_boxplot() p + geom_boxplot(notch = TRUE) p + geom_boxplot(varwidth = TRUE) diff --git a/man/geom_density.Rd b/man/geom_density.Rd index 3ccef5179d..4aa678c18f 100644 --- a/man/geom_density.Rd +++ b/man/geom_density.Rd @@ -6,13 +6,13 @@ \title{Smoothed density estimates} \usage{ geom_density(mapping = NULL, data = NULL, stat = "density", - position = "identity", ..., na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + position = "identity", ..., na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE) stat_density(mapping = NULL, data = NULL, geom = "area", position = "stack", ..., bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, trim = FALSE, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -46,6 +46,11 @@ to the paired geom/stat.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -87,6 +92,11 @@ Computes and draws kernel density estimate, which is a smoothed version of the histogram. This is a useful alternative to the histogram for continuous data that comes from an underlying smooth distribution. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_density()} understands the following aesthetics (required aesthetics are in bold): @@ -119,6 +129,9 @@ plots} \examples{ ggplot(diamonds, aes(carat)) + geom_density() +# Map the values to y to flip the orientation +ggplot(diamonds, aes(y = carat)) + + geom_density() ggplot(diamonds, aes(carat)) + geom_density(adjust = 1/5) diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index 1cf44f65cf..228c06c73a 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -13,13 +13,14 @@ geom_freqpoly(mapping = NULL, data = NULL, stat = "bin", geom_histogram(mapping = NULL, data = NULL, stat = "bin", position = "stack", ..., binwidth = NULL, bins = NULL, - na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + na.rm = FALSE, orientation = NA, show.legend = NA, + inherit.aes = TRUE) stat_bin(mapping = NULL, data = NULL, geom = "bar", position = "stack", ..., binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, breaks = NULL, closed = c("right", "left"), pad = FALSE, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -79,6 +80,11 @@ bin width of a time variable is the number of seconds.} \item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{geom, stat}{Use to override the default connection between \code{geom_histogram()}/\code{geom_freqpoly()} and \code{stat_bin()}.} @@ -121,6 +127,11 @@ different number of bins. You can also experiment modifying the \code{binwidth} one change at a time. You may need to look at a few options to uncover the full story behind your data. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_histogram()} uses the same aesthetics as \code{\link[=geom_bar]{geom_bar()}}; @@ -144,6 +155,9 @@ ggplot(diamonds, aes(carat)) + geom_histogram(binwidth = 0.01) ggplot(diamonds, aes(carat)) + geom_histogram(bins = 200) +# Map values to y to flip the orientation +ggplot(diamonds, aes(y = carat)) + + geom_histogram() # Rather than stacking histograms, it's easier to compare frequency # polygons diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index fcb57f367f..9e18cdfe89 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -10,19 +10,19 @@ \usage{ geom_crossbar(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., fatten = 2.5, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) geom_errorbar(mapping = NULL, data = NULL, stat = "identity", - position = "identity", ..., na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + position = "identity", ..., na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE) geom_linerange(mapping = NULL, data = NULL, stat = "identity", - position = "identity", ..., na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + position = "identity", ..., na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE) geom_pointrange(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., fatten = 4, na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -63,6 +63,11 @@ middle bar in \code{geom_crossbar()} and the middle point in \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -78,18 +83,29 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} Various ways of representing a vertical interval defined by \code{x}, \code{ymin} and \code{ymax}. Each case draws a single graphical object. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_linerange()} understands the following aesthetics (required aesthetics are in bold): \itemize{ -\item \strong{\code{x}} -\item \strong{\code{ymin}} -\item \strong{\code{ymax}} +\item \strong{\code{x} \emph{or} \code{y}} +\item \strong{\code{ymin} \emph{or} \code{xmin}} +\item \strong{\code{ymax} \emph{or} \code{xmax}} \item \code{alpha} \item \code{colour} \item \code{group} \item \code{linetype} \item \code{size} +\item \code{x} +\item \code{xmax} +\item \code{xmin} +\item \code{y} +\item \code{ymax} +\item \code{ymin} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -110,6 +126,10 @@ p + geom_pointrange(aes(ymin = lower, ymax = upper)) p + geom_crossbar(aes(ymin = lower, ymax = upper), width = 0.2) p + geom_errorbar(aes(ymin = lower, ymax = upper), width = 0.2) +# Flip the orientation by changing mapping +ggplot(df, aes(resp, trt, colour = group)) + + geom_linerange(aes(xmin = lower, xmax = upper)) + # Draw lines connecting group means p + geom_line(aes(group = group)) + diff --git a/man/geom_path.Rd b/man/geom_path.Rd index 87042c73f0..5685b91c23 100644 --- a/man/geom_path.Rd +++ b/man/geom_path.Rd @@ -12,8 +12,8 @@ geom_path(mapping = NULL, data = NULL, stat = "identity", inherit.aes = TRUE) geom_line(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) + position = "identity", na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE, ...) geom_step(mapping = NULL, data = NULL, stat = "identity", position = "identity", direction = "hv", na.rm = FALSE, @@ -73,6 +73,11 @@ 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, e.g. \code{\link[=borders]{borders()}}.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{direction}{direction of stairs: 'vh' for vertical then horizontal, 'hv' for horizontal then vertical, or 'mid' for step half-way between adjacent x-values.} @@ -88,6 +93,11 @@ connected together. An alternative parameterisation is \code{\link[=geom_segment]{geom_segment()}}, where each line corresponds to a single case which provides the start and end coordinates. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_path()} understands the following aesthetics (required aesthetics are in bold): @@ -122,6 +132,9 @@ ggplot(economics, aes(date, unemploy)) + geom_line() ggplot(economics_long, aes(date, value01, colour = variable)) + geom_line() +# You can get a timeseries that run vertically by setting the orientation +ggplot(economics, aes(unemploy, date)) + geom_line(orientation = "y") + # geom_step() is useful when you want to highlight exactly when # the y value changes recent <- economics[economics$date > as.Date("2013-01-01"), ] diff --git a/man/geom_ribbon.Rd b/man/geom_ribbon.Rd index f5142578ec..06b5b619d0 100644 --- a/man/geom_ribbon.Rd +++ b/man/geom_ribbon.Rd @@ -6,12 +6,12 @@ \title{Ribbons and area plots} \usage{ geom_ribbon(mapping = NULL, data = NULL, stat = "identity", - position = "identity", ..., na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + position = "identity", ..., na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE) geom_area(mapping = NULL, data = NULL, stat = "identity", - position = "stack", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) + position = "stack", na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE, ...) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -48,6 +48,11 @@ to the paired geom/stat.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -73,19 +78,30 @@ components is stacked is very important, as it becomes increasing hard to see the individual pattern as you move up the stack. See \code{\link[=position_stack]{position_stack()}} for the details of stacking algorithm. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_ribbon()} understands the following aesthetics (required aesthetics are in bold): \itemize{ -\item \strong{\code{x}} -\item \strong{\code{ymin}} -\item \strong{\code{ymax}} +\item \strong{\code{x} \emph{or} \code{y}} +\item \strong{\code{ymin} \emph{or} \code{xmin}} +\item \strong{\code{ymax} \emph{or} \code{xmax}} \item \code{alpha} \item \code{colour} \item \code{fill} \item \code{group} \item \code{linetype} \item \code{size} +\item \code{x} +\item \code{xmax} +\item \code{xmin} +\item \code{y} +\item \code{ymax} +\item \code{ymin} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -98,6 +114,9 @@ h <- ggplot(huron, aes(year)) h + geom_ribbon(aes(ymin=0, ymax=level)) h + geom_area(aes(y = level)) +# Change orientation be switching the mapping +h + geom_area(aes(x = level, y = year)) + # Add aesthetic mappings h + geom_ribbon(aes(ymin = level - 1, ymax = level + 1), fill = "grey70") + diff --git a/man/geom_smooth.Rd b/man/geom_smooth.Rd index 540207b2db..7b7d67cfa1 100644 --- a/man/geom_smooth.Rd +++ b/man/geom_smooth.Rd @@ -7,13 +7,14 @@ \usage{ geom_smooth(mapping = NULL, data = NULL, stat = "smooth", position = "identity", ..., method = NULL, formula = NULL, - se = TRUE, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + se = TRUE, na.rm = FALSE, orientation = NA, show.legend = NA, + inherit.aes = TRUE) stat_smooth(mapping = NULL, data = NULL, geom = "smooth", position = "identity", ..., method = NULL, formula = NULL, se = TRUE, n = 80, span = 0.75, fullrange = FALSE, level = 0.95, method.args = list(), na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -72,6 +73,11 @@ observations and \code{formula = y ~ s(x, bs = "cs")} otherwise.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -114,6 +120,11 @@ exceptions are \code{loess()}, which uses a t-based approximation, and \code{glm()}, where the normal confidence interval is constructed on the link scale and then back-transformed to the response scale. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_smooth()} understands the following aesthetics (required aesthetics are in bold): @@ -148,6 +159,11 @@ ggplot(mpg, aes(displ, hwy)) + geom_point() + geom_smooth() +# If you need the fitting to be done along the y-axis set the orientation +ggplot(mpg, aes(displ, hwy)) + + geom_point() + + geom_smooth(orientation = "y") + # Use span to control the "wiggliness" of the default loess smoother. # The span is the fraction of points used to fit each local regression: # small numbers make a wigglier curve, larger numbers make a smoother curve. diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 247949f78d..a290448257 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -7,13 +7,13 @@ \usage{ geom_violin(mapping = NULL, data = NULL, stat = "ydensity", position = "dodge", ..., draw_quantiles = NULL, trim = TRUE, - scale = "area", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + scale = "area", na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE) stat_ydensity(mapping = NULL, data = NULL, geom = "violin", position = "dodge", ..., bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, scale = "area", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) + orientation = NA, show.legend = NA, inherit.aes = TRUE) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -57,6 +57,11 @@ observations. If "width", all violins have the same maximum width.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -88,6 +93,11 @@ blend of \code{\link[=geom_boxplot]{geom_boxplot()}} and \code{\link[=geom_densi violin plot is a mirrored density plot displayed in the same way as a boxplot. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{geom_violin()} understands the following aesthetics (required aesthetics are in bold): @@ -122,6 +132,10 @@ or to a constant maximum width} p <- ggplot(mtcars, aes(factor(cyl), mpg)) p + geom_violin() +# Orientation follows the discrete axis +ggplot(mtcars, aes(mpg, factor(cyl))) + + geom_violin() + \donttest{ p + geom_violin() + geom_jitter(height = 0, width = 0.1) diff --git a/man/stat_summary.Rd b/man/stat_summary.Rd index 3acd3a2588..6480650e9d 100644 --- a/man/stat_summary.Rd +++ b/man/stat_summary.Rd @@ -6,15 +6,16 @@ \title{Summarise y values at unique/binned x} \usage{ stat_summary_bin(mapping = NULL, data = NULL, geom = "pointrange", - position = "identity", ..., fun.data = NULL, fun.y = NULL, - fun.ymax = NULL, fun.ymin = NULL, fun.args = list(), bins = 30, - binwidth = NULL, breaks = NULL, na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE) + position = "identity", ..., fun.data = NULL, fun = NULL, + fun.max = NULL, fun.min = NULL, fun.args = list(), bins = 30, + binwidth = NULL, breaks = NULL, na.rm = FALSE, orientation = NA, + show.legend = NA, inherit.aes = TRUE, fun.y, fun.ymin, fun.ymax) stat_summary(mapping = NULL, data = NULL, geom = "pointrange", - position = "identity", ..., fun.data = NULL, fun.y = NULL, - fun.ymax = NULL, fun.ymin = NULL, fun.args = list(), - na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + position = "identity", ..., fun.data = NULL, fun = NULL, + fun.max = NULL, fun.min = NULL, fun.args = list(), na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE, fun.y, + fun.ymin, fun.ymax) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -51,8 +52,8 @@ to the paired geom/stat.} \item{fun.data}{A function that is given the complete data and should return a data frame with variables \code{ymin}, \code{y}, and \code{ymax}.} -\item{fun.ymin, fun.y, fun.ymax}{Alternatively, supply three individual -functions that are each passed a vector of x's and should return a +\item{fun.min, fun, fun.max}{Alternatively, supply three individual +functions that are each passed a vector of values and should return a single number.} \item{fun.args}{Optional additional arguments passed on to the functions.} @@ -79,6 +80,11 @@ and \code{boundary}.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} +\item{orientation}{The orientation of the layer. The default (\code{NA}) +automatically determines the orientation from the aesthetic mapping. In the +rare event that this fails it can be given explicitly by setting \code{orientation} +to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more detail.} + \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. @@ -89,13 +95,21 @@ display.} 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, e.g. \code{\link[=borders]{borders()}}.} + +\item{fun.ymin, fun.y, fun.ymax}{Deprecated, use the versions specified above +instead.} } \description{ -\code{stat_summary} operates on unique \code{x}; \code{stat_summary_bin} -operates on binned \code{x}. They are more flexible versions of +\code{stat_summary} operates on unique \code{x} or \code{y}; \code{stat_summary_bin} +operates on binned \code{x} or \code{y}. They are more flexible versions of \code{\link[=stat_bin]{stat_bin()}}: instead of just counting, they can compute any aggregate. } +\section{Orientation}{ + +This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. +} + \section{Aesthetics}{ \code{stat_summary()} understands the following aesthetics (required aesthetics are in bold): @@ -109,23 +123,28 @@ Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. \section{Summary functions}{ -You can either supply summary functions individually (\code{fun.y}, -\code{fun.ymax}, \code{fun.ymin}), or as a single function (\code{fun.data}): +You can either supply summary functions individually (\code{fun}, +\code{fun.max}, \code{fun.min}), or as a single function (\code{fun.data}): \describe{ \item{fun.data}{Complete summary function. Should take numeric vector as input and return data frame as output} -\item{fun.ymin}{ymin summary function (should take numeric vector and +\item{fun.min}{min summary function (should take numeric vector and return single number)} -\item{fun.y}{y summary function (should take numeric vector and return +\item{fun}{main summary function (should take numeric vector and return single number)} -\item{fun.ymax}{ymax summary function (should take numeric vector and +\item{fun.max}{max summary function (should take numeric vector and return single number)} } A simple vector function is easiest to work with as you can return a single number, but is somewhat less flexible. If your summary function computes -multiple values at once (e.g. ymin and ymax), use \code{fun.data}. +multiple values at once (e.g. min and max), use \code{fun.data}. + +\code{fun.data} will recieve data as if it was oriented along the x-axis and +should return a data.frame that corresponds to that orientation. The layer +will take care of flipping the input and output if it is oriented along the +y-axis. If no aggregation functions are supplied, will default to \code{\link[=mean_se]{mean_se()}}. @@ -135,24 +154,33 @@ If no aggregation functions are supplied, will default to d <- ggplot(mtcars, aes(cyl, mpg)) + geom_point() d + stat_summary(fun.data = "mean_cl_boot", colour = "red", size = 2) +# Orientation follows the discrete axis +ggplot(mtcars, aes(mpg, cyl)) + + geom_point() + + stat_summary(fun.data = "mean_cl_boot", colour = "red", size = 2) + # You can supply individual functions to summarise the value at # each x: -d + stat_summary(fun.y = "median", colour = "red", size = 2, geom = "point") -d + stat_summary(fun.y = "mean", colour = "red", size = 2, geom = "point") -d + aes(colour = factor(vs)) + stat_summary(fun.y = mean, geom="line") +d + stat_summary(fun = "median", colour = "red", size = 2, geom = "point") +d + stat_summary(fun = "mean", colour = "red", size = 2, geom = "point") +d + aes(colour = factor(vs)) + stat_summary(fun = mean, geom="line") -d + stat_summary(fun.y = mean, fun.ymin = min, fun.ymax = max, +d + stat_summary(fun = mean, fun.min = min, fun.max = max, colour = "red") d <- ggplot(diamonds, aes(cut)) d + geom_bar() -d + stat_summary_bin(aes(y = price), fun.y = "mean", geom = "bar") +d + stat_summary(aes(y = price), fun = "mean", geom = "bar") + +# Orientation of stat_summary_bin is ambiguous and must be specified directly +ggplot(diamonds, aes(carat, price)) + + stat_summary_bin(fun = "mean", geom = "bar", orientation = 'y') \donttest{ # Don't use ylim to zoom into a summary plot - this throws the # data away p <- ggplot(mtcars, aes(cyl, mpg)) + - stat_summary(fun.y = "mean", geom = "point") + stat_summary(fun = "mean", geom = "point") p p + ylim(15, 30) # Instead use coord_cartesian diff --git a/tests/testthat/test-geom-bar.R b/tests/testthat/test-geom-bar.R index b71febb4e4..fa3f6bd7a3 100644 --- a/tests/testthat/test-geom-bar.R +++ b/tests/testthat/test-geom-bar.R @@ -10,3 +10,19 @@ test_that("geom_bar removes bars with parts outside the plot limits", { "Removed 1 rows containing missing values" ) }) + +test_that("geom_bar works in both directions", { + dat <- data_frame(x = c("a", "b", "b", "c", "c", "c")) + + p <- ggplot(dat, aes(x)) + geom_bar() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(dat, aes(y = x)) + geom_bar() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)) +}) diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index 99ae3ab511..ca484f77cf 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -12,6 +12,22 @@ test_that("geom_boxplot range includes all outliers", { expect_true(maxy >= max(dat$y)) }) +test_that("geom_boxplot works in both directions", { + dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) + + p <- ggplot(dat, aes(x, y)) + geom_boxplot() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(dat, aes(y, x)) + geom_boxplot() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)) +}) + test_that("geom_boxplot for continuous x gives warning if more than one x (#992)", { dat <- expand.grid(x = 1:2, y = c(-(1:5) ^ 3, (1:5) ^ 3) ) diff --git a/tests/testthat/test-geom-col.R b/tests/testthat/test-geom-col.R index ed10be1883..7d8b0548f1 100644 --- a/tests/testthat/test-geom-col.R +++ b/tests/testthat/test-geom-col.R @@ -14,3 +14,19 @@ test_that("geom_col removes columns with parts outside the plot limits", { "Removed 1 rows containing missing values" ) }) + +test_that("geom_col works in both directions", { + dat <- data_frame(x = c("a", "b", "c"), y = c(1.2, 2.5, 3.1)) + + p <- ggplot(dat, aes(x, y)) + geom_col() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(dat, aes(y, x)) + geom_col() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) diff --git a/tests/testthat/test-geom-ribbon.R b/tests/testthat/test-geom-ribbon.R index ecd0f9a40c..b8e01b7484 100644 --- a/tests/testthat/test-geom-ribbon.R +++ b/tests/testthat/test-geom-ribbon.R @@ -8,3 +8,21 @@ test_that("NAs are not dropped from the data", { expect_equal(layer_data(p)$ymin, c(0, 0, NA, 0, 0)) }) + +test_that("geom_ribbon works in both directions", { + dat <- data_frame(x = seq_len(5), + ymin = c(1, 2, 1.5, 1.8, 1), + ymax = c(4, 6, 5, 4.5, 5.2)) + + p <- ggplot(dat, aes(x, ymin = ymin, ymax = ymax)) + geom_ribbon() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(dat, aes(y = x, xmin = ymin, xmax = ymax)) + geom_ribbon() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index e84f8dae6a..14c00b8279 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -9,6 +9,20 @@ test_that("data is ordered by x", { expect_equal(layer_data(ps)[c("x", "y")], df[order(df$x), ]) }) +test_that("geom_smooth works in both directions", { + p <- ggplot(mpg, aes(displ, hwy)) + geom_smooth() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(mpg, aes(hwy, displ)) + geom_smooth(orientation = "y") + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) + test_that("default smoothing methods for small and large data sets work", { # test small data set set.seed(6531) diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index 4c4a3d10ff..1dd50a542c 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -16,6 +16,20 @@ test_that("range is expanded", { expect_equal(layer_scales(p, 2)$y$dimension(), c(0 - expand_b, 2 + expand_b)) }) +test_that("geom_violin works in both directions", { + p <- ggplot(mpg) + geom_violin(aes(drv, hwy)) + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(mpg) + geom_violin(aes(hwy, drv)) + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) + # create_quantile_segment_frame ------------------------------------------------- test_that("create_quantile_segment_frame functions for 3 quantiles", { diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index c76520a4c6..818bb41135 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -4,7 +4,7 @@ test_that("stat_bin throws error when y aesthetic is present", { dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) expect_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_bin()), - "must not be used with a y aesthetic.") + "can only have an x or y aesthetic.") expect_error( ggplot_build(ggplot(dat, aes(x)) + stat_bin(y = 5)), @@ -12,6 +12,20 @@ test_that("stat_bin throws error when y aesthetic is present", { ) }) +test_that("stat_bin works in both directions", { + p <- ggplot(mpg, aes(hwy)) + stat_bin() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(mpg, aes(y = hwy)) + stat_bin() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) + test_that("bins specifies the number of bins", { df <- data_frame(x = 1:10) out <- function(x, ...) { @@ -144,7 +158,7 @@ test_that("stat_count throws error when y aesthetic present", { expect_error( ggplot_build(ggplot(dat, aes(x, y)) + stat_count()), - "must not be used with a y aesthetic.") + "can only have an x or y aesthetic.") expect_error( ggplot_build(ggplot(dat, aes(x)) + stat_count(y = 5)), diff --git a/tests/testthat/test-stat-density.R b/tests/testthat/test-stat-density.R index 9c4791e337..4a26927a0c 100644 --- a/tests/testthat/test-stat-density.R +++ b/tests/testthat/test-stat-density.R @@ -5,6 +5,20 @@ test_that("compute_density succeeds when variance is zero", { expect_equal(dens$n, rep(10, 512)) }) +test_that("stat_density works in both directions", { + p <- ggplot(mpg, aes(hwy)) + stat_density() + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(mpg, aes(y = hwy)) + stat_density() + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) + test_that("compute_density returns useful df and throws warning when <2 values", { expect_warning(dens <- compute_density(1, NULL, from = 0, to = 0)) diff --git a/tests/testthat/test-stats.r b/tests/testthat/test-stats.r index 2374b9ee57..019d752fde 100644 --- a/tests/testthat/test-stats.r +++ b/tests/testthat/test-stats.r @@ -13,6 +13,6 @@ test_that("plot succeeds even if some computation fails", { }) test_that("error message is thrown when aesthetics are missing", { - p <- ggplot(mtcars) + stat_bin() - expect_error(ggplot_build(p), "x$") + p <- ggplot(mtcars) + stat_sum() + expect_error(ggplot_build(p), "x, y$") }) diff --git a/vignettes/extending-ggplot2.Rmd b/vignettes/extending-ggplot2.Rmd index a90aea4fb2..6719ee2639 100644 --- a/vignettes/extending-ggplot2.Rmd +++ b/vignettes/extending-ggplot2.Rmd @@ -489,6 +489,52 @@ This doesn't allow you to use different geoms with the stat, but that seems appr 1. Compare and contrast `GeomPolygon` with `GeomSimplePolygon`. +## Geoms and Stats with multiple orientation +Some layers have a specific orientation. `geom_bar()` e.g. have the bars along one axis, `geom_line()` will sort the input by one axis, etc. The original approach to using these geoms in the other orientation was to add `coord_flip()` to the plot to switch the position of the x and y axes. Following ggplot2 v3.3 all the geoms will natively work in both orientations without `coord_flip()`. The mechanism is that the layer will try to guess the orientation from the mapped data, or take direction from the user using the `orientation` parameter. To replicate this functionality in new stats and geoms there's a few steps to take. We wll look at the boxplot layer as an example instead of creating a new from scratch. + +### Omnidirectional stats +The actual guessing of orientation will happen in `setup_params()` using the `has_flipped_aes()` helper: + +```{r} +StatBoxplot$setup_params +``` + +Following this is a call to `flip_data()` which will make sure the data is in horizontal orientation. The rest of the code can then simply assume that the data is in a specific orientation. The same thing happens in `setup_data()`: + +```{r} +StatBoxplot$setup_data +``` + +The data is flipped (if needed), manipulated, and flipped back as it is returned. + +During the computation, this sandwiching between `flip_data()` is used as well, but right before the data is returned it will also get a `flipped_aes` column denoting if the data is flipped or not. This allow the +stat to communicate to the geom that orientation has already been determined. + +### Omnidirecitonal geoms +The setup for geoms is pretty much the same, with a few twists. `has_flipped_aes()` is also used in `setup_params()`, where it will usually be picked up from the `flipped_aes` column given by the stat. In `setup_data()` you will often see that `flipped_aes` is reassigned, to make sure it exist prior to position adjustment. This is needed if the geom is used together with a stat that doesn't handle orientation (often `stat_identity()`): + +```{r} +GeomBoxplot$setup_data +``` + +In the `draw_*()` method you will once again sandwich any data manipulation between `flip_data()` calls. It is important to make sure that the data is flipped back prior to creating the grob or calling draw methods from other geoms. + +### Dealing with required aesthetics +Omnidirectional layers usually have two different sets of required aesthetics. Which set is used is often how it knows the orientation. To handle this gracefully the `required_aes` field of `Stat` and `Geom` classes understands the `|` (or) operator. Looking at `GeomBoxplot` we can see how it is used: + +```{r} +GeomBoxplot$required_aes +``` + +This tells ggplot2 that either all the aesthetics before `|` are required or all the aesthetics after are required. + +### Ambiguous layers +Some layers will not have a clear interpretation of their data in terms of orientation. A classic example is `geom_line()` which just by convention runs along the x-axis. There is nothing in the data itself that indicates that. For these geoms the user must indicate a flipped orientation by setting `orientation = "y"`. The stat or geom will then call `has_flipped_aes()` with `ambiguous = TRUE` to cancel any guessing based on data format. As an example we can see the `setup_params()` method of `GeomLine`: + +```{r} +GeomLine$setup_params +``` + ## Creating your own theme If you're going to create your own complete theme, there are a few things you need to know: From 14fd33d8023ad74e2a8d52b814d4ffb1c1330157 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:09:06 +0200 Subject: [PATCH 067/125] Add position_nudgestack --- R/position-nudgestack.R | 117 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 R/position-nudgestack.R diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R new file mode 100644 index 0000000000..f978593441 --- /dev/null +++ b/R/position-nudgestack.R @@ -0,0 +1,117 @@ +#' Simultaneously nudge and stack +#' +#' This is primarily used for set stacked columns between the ticks on the +#' x-axis. +#' +#' @family position adjustments +#' @param x,y Amount of vertical and horizontal distance to move. +#' @param vjust Vertical adjustment for geoms that have a position +#' (like points or lines), not a dimension (like bars or areas). Set to +#' `0` to align with the bottom, `0.5` for the middle, +#' and `1` (the default) for the top. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. +#' @export +#' @examples +#' data <- mtcars +#' ggplot() + +#' geom_col( +#' data, +#' aes(x = cyl, y = gear, fill = gear), +#' position = position_nudgestack(x = 1) +#' ) +position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { + ggproto(NULL, PositionNudgeStack, + x = x, + y = y, + vjust = vjust, + reverse = reverse + ) +} + + + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionNudgeStack <- ggproto("PositionNudgeStack", Position, + x = 0, + y = 0, + type = NULL, + vjust = 1, + fill = FALSE, + reverse = FALSE, + + setup_params = function(self, data) { + list( + x = self$x, + y = self$y, + var = if (!is.null(self$var)) self$var else stack_var(data), + fill = self$fill, + vjust = self$vjust, + reverse = self$reverse + ) + }, + + setup_data = function(self, data, params) { + if (is.null(params$var)) { + return(data) + } + + data$ymax <- switch(params$var, + y = data$y, + ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) + ) + + remove_missing( + data, + vars = c("x", "xmin", "xmax", "y"), + name = "position_stack" + ) + }, + + compute_layer = function(self, data, params, layout) { + if (is.null(params$var)) { + return(data) + } + + negative <- data$ymax < 0 + negative[is.na(negative)] <- FALSE + + neg <- data[negative, , drop = FALSE] + pos <- data[!negative, , drop = FALSE] + + if (any(negative)) { + neg <- collide(neg, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + if (any(!negative)) { + pos <- collide(pos, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] + + + + # transform only the dimensions for which non-zero nudging is requested + if (any(params$x != 0)) { + if (any(params$y != 0)) { + transform_position(data, function(x) x + params$x, function(y) y + params$y) + } else { + transform_position(data, function(x) x + params$x, NULL) + } + } else if (any(params$y != 0)) { + transform_position(data, NULL, function(y) y + params$y) + } else { + data # if both x and y are 0 we don't need to transform + } + } +) From f67ae707652246416a9dc8b019b9b1cdb7bb524c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:26:32 +0200 Subject: [PATCH 068/125] Delete emtpy rows --- R/position-nudgestack.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index f978593441..60e67169dd 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -29,8 +29,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ) } - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -99,8 +97,6 @@ PositionNudgeStack <- ggproto("PositionNudgeStack", Position, data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] - - # transform only the dimensions for which non-zero nudging is requested if (any(params$x != 0)) { if (any(params$y != 0)) { From 6d76c3ac31756433becabadc3f583cbd5a0331d1 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 069/125] Add time series example --- R/position-nudgestack.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 60e67169dd..a2837ba90e 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,13 +13,23 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' data <- mtcars -#' ggplot() + -#' geom_col( -#' data, -#' aes(x = cyl, y = gear, fill = gear), -#' position = position_nudgestack(x = 1) +#' library(dplyr) +#' library(ggplot2) +#' ESM <- data.frame( +#' as.matrix(EuStockMarkets), +#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), +#' format = "%d %b %Y" #' ) +#' ) +#' +#' ESM_prep <- ESM %>% +#' tidyr::gather(key = key, value = value, -date) %>% +#' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' +#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, x = x, @@ -36,7 +46,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 1b7c4c02074f20ed9fb1ec671e376abeb8d1875d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:56:35 +0200 Subject: [PATCH 070/125] Add new position to DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 7af9aac5ab..7d23fb894f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -182,6 +182,7 @@ Collate: 'position-jitter.r' 'position-jitterdodge.R' 'position-nudge.R' + 'position-nudgestack.R' 'position-stack.r' 'quick-plot.r' 'range.r' From 9f6aa7dddde8d97fb0b653737b9495a6e24b5d2d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:58:38 +0200 Subject: [PATCH 071/125] Add new position_nudgestack into NAMESPACE --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 7a90dd5f5f..62e0efb2d1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -204,6 +204,7 @@ export(PositionIdentity) export(PositionJitter) export(PositionJitterdodge) export(PositionNudge) +export(PositionNudgeStack) export(PositionStack) export(Scale) export(ScaleBinned) @@ -432,6 +433,7 @@ export(position_identity) export(position_jitter) export(position_jitterdodge) export(position_nudge) +export(position_nudgestack) export(position_stack) export(qplot) export(quickplot) From 55602af4c53a6867a7e42ebbc3f47365bc2f71d3 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 072/125] Add position-nudgestack.R into man --- man/ggplot2-ggproto.Rd | 19 +++++++------- man/position_dodge.Rd | 1 + man/position_identity.Rd | 1 + man/position_jitter.Rd | 1 + man/position_jitterdodge.Rd | 1 + man/position_nudge.Rd | 1 + man/position_nudgestack.Rd | 51 +++++++++++++++++++++++++++++++++++++ man/position_stack.Rd | 1 + 8 files changed, 67 insertions(+), 9 deletions(-) create mode 100644 man/position_nudgestack.Rd diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index 75605bc356..1f6c4bc083 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -14,15 +14,15 @@ % R/geom-spoke.r, R/geom-text.r, R/geom-tile.r, R/geom-violin.r, % R/geom-vline.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-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-qq-line.R, -% R/stat-qq.r, R/stat-quantile.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/position-jitterdodge.R, R/position-nudge.R, R/position-nudgestack.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-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-qq-line.R, R/stat-qq.r, R/stat-quantile.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} @@ -90,6 +90,7 @@ \alias{PositionJitter} \alias{PositionJitterdodge} \alias{PositionNudge} +\alias{PositionNudgeStack} \alias{PositionStack} \alias{PositionFill} \alias{Scale} diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index a35191e4fa..cef3386d86 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -96,6 +96,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + Other position adjustments: \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 440e575682..994bd2952e 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -13,6 +13,7 @@ Don't adjust position Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index 16548f6496..37b6df322c 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -58,6 +58,7 @@ ggplot(mtcars, aes(am, vs)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index f543bb332a..ff6e5f05b9 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -40,6 +40,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index aaf735e236..9597692160 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -39,6 +39,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_stack}} } \concept{position adjustments} diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd new file mode 100644 index 0000000000..b2489b3153 --- /dev/null +++ b/man/position_nudgestack.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-nudgestack.R +\name{position_nudgestack} +\alias{position_nudgestack} +\title{Simultaneously nudge and stack} +\usage{ +position_nudgestack(x = 0, y = 0, vjust = 1, reverse = FALSE) +} +\arguments{ +\item{x, y}{Amount of vertical and horizontal distance to move.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} +} +\description{ +This is primarily used for set stacked columns between the ticks on the +x-axis. +} +\examples{ +library(dplyr) +library(ggplot2) +ESM <- data.frame( + as.matrix(EuStockMarkets), + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "\%d \%b \%Y" + ) +) + +ESM_prep <- ESM \%>\% + tidyr::gather(key = key, value = value, -date) \%>\% + group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% + filter(date >= "1995-01-01" & date <= "1997-12-01") + +ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) +} +\seealso{ +Other position adjustments: \code{\link{position_dodge}}, + \code{\link{position_identity}}, + \code{\link{position_jitterdodge}}, + \code{\link{position_jitter}}, + \code{\link{position_nudge}}, + \code{\link{position_stack}} +} +\concept{position adjustments} diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 39ea363603..991aed9c2c 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -144,6 +144,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}} } \concept{position adjustments} From b1c8b1a3a6786da393eb03321927623088ba24b6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 073/125] Add the zoo-package to Suggestions --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7d23fb894f..75ab77affe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Suggests: sf (>= 0.7-3), svglite (>= 1.2.0.9001), testthat (>= 2.1.0), - vdiffr (>= 0.3.0) + vdiffr (>= 0.3.0), + zoo Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From d967b8ed3ceee6123d3d2f21cc0042322c8c0aa6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 074/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a2837ba90e..fdfa395feb 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -26,7 +26,7 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From d443b80f829f6053668a2f92cb51b7e3cdea9acd Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:20 +0200 Subject: [PATCH 075/125] Delete packages from @examples --- R/position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fdfa395feb..a031937593 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,8 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' library(dplyr) -#' library(ggplot2) #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From e392ac820a5a10ac309cd64b8e84541d118caace Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 076/125] Add new examples --- man/position_nudgestack.Rd | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index b2489b3153..7efb57a035 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,8 +22,6 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -library(dplyr) -library(ggplot2) ESM <- data.frame( as.matrix(EuStockMarkets), date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), @@ -35,7 +33,7 @@ ESM_prep <- ESM \%>\% tidyr::gather(key = key, value = value, -date) \%>\% group_by(date, key) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date <= "1997-12-01") + filter(date >= "1995-01-01" & date < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + geom_col(position = position_nudgestack(x = 15)) From 37f1bd60ea7ee1c4df8459a938c4fbc1af4ff49f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 077/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/testthat/test-position-nudgestack.R diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R new file mode 100644 index 0000000000..cda3fd3e20 --- /dev/null +++ b/tests/testthat/test-position-nudgestack.R @@ -0,0 +1,27 @@ +context("position_nudgestack") + +test_that("position_nudgestack draws correctly", { + ESM <- data_frame( + DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], + SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], + CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], + FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "%d %b %Y" + ) + ) + + ESM_prep <- ESM %>% + tidyr::gather(key = key, value = value, -date) %>% + group_by(date, key) %>% + summarize(value = mean(value)) %>% + filter(date >= "1995-01-01" & date < "1998-01-01") + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) + + expect_doppelganger( + "nudgestack EuStockMarkets data", + stock_marked + ) +}) From 5b89b3258b4b2885d288c69e41666d20178bd337 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 078/125] Add validated svg for position_nudgestack --- .../nudgestack-eustockmarkets-data.svg | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg new file mode 100644 index 0000000000..fc0ed6d9a6 --- /dev/null +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -0,0 +1,203 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10000 +20000 + + + + + + + +1995 +1996 +1997 +1998 +date +value + +key + + + + + + + + +CAC +DAX +FTSE +SMI +nudgestack EuStockMarkets data + From a960ca886105a9d00ee23b4e242ff3e3deb1cf58 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 079/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 93 +++++++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index cda3fd3e20..6ac2277a09 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -25,3 +25,96 @@ test_that("position_nudgestack draws correctly", { stock_marked ) }) + + +test_that("nudging works in both dimensions simultaneously", { + # individual nudge value for continuous data + set.seed(111) + + df <- data_frame(x = 1:3) + + p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + + geom_col(position = position_nudgestack(x = 0.5, y = 2)) + + data <- layer_data(p) + + expect_equal(data$x, 1.5:3.5) + expect_equal(data$xmin, 1.05:3.05) + expect_equal(data$xmax, 1.95:3.95) + expect_equal(data$y, 3:5) + expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymax, 3:5) + +}) + +test_that("nudging works for discrete values correctly", { + set.seed(111) + + # x nudge value for discrete data + series <- data.frame( + time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c('a', 'b', 'c', 'd'), 4), + value = rpois(16, 10) + ) + + p <- ggplot(series, aes(time, value, group = type)) + + geom_line(aes(colour = type), position = position_nudgestack(x = 0.5)) + + geom_point(aes(colour = type), position = position_nudgestack(x = 0.5)) + + data <- layer_data(p) + + expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + +}) + + +test_that("data is sorted prior to stacking", { + df <- data_frame( + x = rep(c(1:10), 3), + var = rep(c("a", "b", "c"), 10), + y = round(runif(30, 1, 5)) + ) + p <- ggplot(df, aes(x = x, y = y, fill = var)) + + geom_col(position = position_nudgestack(x = 0.5)) + + dat <- layer_data(p) + expect_true(all(dat$group == 3:1)) +}) + +test_that("negative and positive values are handled separately", { + df <- data_frame( + x = c(1,1,1,2,2), + g = c(1,2,3,1,2), + y = c(1,-1,1,2,-3) + ) + p <- ggplot(df, aes(x, y, fill = factor(g))) + + geom_col(position = position_nudgestack(x = 0.5)) + dat <- layer_data(p) + + expect_equal(dat$ymin[dat$x == 1.5], c(0, -1, 1)) + expect_equal(dat$ymax[dat$x == 1.5], c(1, 0, 2)) + + expect_equal(dat$ymin[dat$x == 2.5], c(0, -3)) + expect_equal(dat$ymax[dat$x == 2.5], c(2, 0)) +}) + +test_that("can request reverse stacking", { + df <- data_frame( + y = c(-2, 2, -1, 1), + g = c("a", "a", "b", "b") + ) + p <- ggplot(df, aes(1, y, fill = g)) + + geom_col(position = position_nudgestack(x = 0.5, reverse = TRUE)) + dat <- layer_data(p) + expect_equal(dat$ymin, c(-2, 0, -3, 2)) +}) + +test_that("position_nudgestack() can stack correctly when ymax is NA", { + df <- data_frame(x = c(1, 1), y = c(1, 1)) + p <- ggplot(df, aes(x, y, ymax = NA_real_)) + + geom_point(position = position_nudgestack(x = 0.5)) + expect_equal(layer_data(p)$y, c(1, 2)) +}) + From f891dbc078050e82fea835b4c65634c114728d59 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Fri, 27 Sep 2019 15:58:51 +0200 Subject: [PATCH 080/125] Bugfix --- tests/testthat/test-position-nudgestack.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 6ac2277a09..f3532c9686 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -2,10 +2,10 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { ESM <- data_frame( - DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], - SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], - CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], - FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + DAX = EuStockMarkets[,"DAX"], + SMI = EuStockMarkets[,"SMI"], + CAC = EuStockMarkets[,"CAC"], + FTSE = EuStockMarkets[,"FTSE"], date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), format = "%d %b %Y" ) From 8642839345c8434e85627e48ee9e8eba963fd9de Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 30 Sep 2019 14:06:24 +0200 Subject: [PATCH 081/125] Use tsbox for converting ts object to tibble --- DESCRIPTION | 2 +- R/position-nudgestack.R | 15 +- man/position_nudgestack.Rd | 15 +- .../nudgestack-eustockmarkets-data.svg | 302 +++++++++--------- tests/testthat/test-position-nudgestack.R | 23 +- 5 files changed, 171 insertions(+), 186 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 75ab77affe..0b2fa2e53f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,7 +56,7 @@ Suggests: svglite (>= 1.2.0.9001), testthat (>= 2.1.0), vdiffr (>= 0.3.0), - zoo + tsbox Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a031937593..51a3de3587 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,20 +13,15 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' ESM <- data.frame( -#' as.matrix(EuStockMarkets), -#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), -#' format = "%d %b %Y" -#' ) -#' ) +#' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' tidyr::gather(key = key, value = value, -date) %>% -#' group_by(date, key) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' group_by(id, time) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date < "1998-01-01") +#' filter(time >= "1995-01-01" & time < "1998-01-01") #' -#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 7efb57a035..5d6a382bd3 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,20 +22,15 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -ESM <- data.frame( - as.matrix(EuStockMarkets), - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "\%d \%b \%Y" - ) -) +ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - tidyr::gather(key = key, value = value, -date) \%>\% - group_by(date, key) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date < "1998-01-01") + filter(time >= "1995-01-01" & time < "1998-01-01") -ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) } \seealso{ diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg index fc0ed6d9a6..326eed0610 100644 --- a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -19,150 +19,150 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -170,11 +170,13 @@ 0 -10000 -20000 +5000 +10000 +15000 - - + + + @@ -183,10 +185,10 @@ 1996 1997 1998 -date +time value -key +id diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index f3532c9686..29964c5dfb 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,23 +1,16 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- data_frame( - DAX = EuStockMarkets[,"DAX"], - SMI = EuStockMarkets[,"SMI"], - CAC = EuStockMarkets[,"CAC"], - FTSE = EuStockMarkets[,"FTSE"], - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "%d %b %Y" - ) - ) + + ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - tidyr::gather(key = key, value = value, -date) %>% - group_by(date, key) %>% - summarize(value = mean(value)) %>% - filter(date >= "1995-01-01" & date < "1998-01-01") + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::group_by(id, time) %>% + dplyr::summarize(value = mean(value)) %>% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -51,7 +44,7 @@ test_that("nudging works for discrete values correctly", { set.seed(111) # x nudge value for discrete data - series <- data.frame( + series <- data_frame( time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), type = rep(c('a', 'b', 'c', 'd'), 4), value = rpois(16, 10) From 5fa6969d8a5633fd6eeaf4f25af42786b068d078 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 082/125] Add the zoo-package to Suggestions --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 0b2fa2e53f..6914d3dc05 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,6 +57,7 @@ Suggests: testthat (>= 2.1.0), vdiffr (>= 0.3.0), tsbox + Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From 99eab522f41f3164ced5029e63c1fec636532179 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 083/125] Add new examples --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6914d3dc05..0b2fa2e53f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,7 +57,6 @@ Suggests: testthat (>= 2.1.0), vdiffr (>= 0.3.0), tsbox - Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From 7d23e8924564673b071d7978099796906849a336 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 08:51:55 +0200 Subject: [PATCH 084/125] Resolve conflict --- R/position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 51a3de3587..139374d410 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -39,6 +39,7 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, + type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 9cdcf6aae204c0150c05a3052326a253e9dca324 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 085/125] Style file --- R/position-nudgestack.R | 2 +- tests/testthat/test-position-nudgestack.R | 29 +++++++++++------------ 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 139374d410..85d9f0cbc9 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -16,7 +16,7 @@ #' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% #' group_by(id, time) %>% #' summarize(value = mean(value)) %>% #' filter(time >= "1995-01-01" & time < "1998-01-01") diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 29964c5dfb..85a11f197a 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,16 +1,18 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% dplyr::group_by(id, time) %>% dplyr::summarize(value = mean(value)) %>% dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + + stock_marked <- ggplot( + data = ESM_prep, + mapping = aes(x = time, y = value, fill = id) + ) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -35,9 +37,8 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$xmin, 1.05:3.05) expect_equal(data$xmax, 1.95:3.95) expect_equal(data$y, 3:5) - expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) - }) test_that("nudging works for discrete values correctly", { @@ -45,8 +46,8 @@ test_that("nudging works for discrete values correctly", { # x nudge value for discrete data series <- data_frame( - time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), - type = rep(c('a', 'b', 'c', 'd'), 4), + time = factor(c(rep(1, 4), rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c("a", "b", "c", "d"), 4), value = rpois(16, 10) ) @@ -56,10 +57,9 @@ test_that("nudging works for discrete values correctly", { data <- layer_data(p) - expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - + expect_equal(data$x, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) }) @@ -78,9 +78,9 @@ test_that("data is sorted prior to stacking", { test_that("negative and positive values are handled separately", { df <- data_frame( - x = c(1,1,1,2,2), - g = c(1,2,3,1,2), - y = c(1,-1,1,2,-3) + x = c(1, 1, 1, 2, 2), + g = c(1, 2, 3, 1, 2), + y = c(1, -1, 1, 2, -3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col(position = position_nudgestack(x = 0.5)) @@ -110,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From 083454ab6587696a52c9491472e5e17e66ac9d8d Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 086/125] Style file --- man/position_nudgestack.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 5d6a382bd3..3a77e318ec 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -25,7 +25,7 @@ x-axis. ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"), "-1"))) \%>\% group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% filter(time >= "1995-01-01" & time < "1998-01-01") From 0a890168a405fc3776b4163d24dcc632369b439f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:44:37 +0200 Subject: [PATCH 087/125] Add news --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index ac58e9c933..ac1c5fdb58 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Added `position_nudgestack()`, which allows to nudge stacked columns. (@ThomasKnecht ) + * A new scale type has been added, that allows binning of aesthetics at the scale level. It has versions for both position and non-position aesthetics and comes with two new guides (`guide_bins` and `guide_coloursteps`) (@thomasp85, #3096) From 831d569682ec19d194e1984a06ba8fcea749e7d8 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 7 Oct 2019 11:53:06 +0200 Subject: [PATCH 088/125] Add package spezifications --- R/position-nudgestack.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fecbd48253..ba05873b06 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -17,9 +17,9 @@ #' #' ESM_prep <- ESM %>% #' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% -#' group_by(id, time) %>% -#' summarize(value = mean(value)) %>% -#' filter(time >= "1995-01-01" & time < "1998-01-01") +#' dplyr::group_by(id, time) %>% +#' dplyr::summarize(value = mean(value)) %>% +#' dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) From ccf0ee58623ef9994a09acb75a98384c58f42518 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 7 Oct 2019 11:58:47 +0200 Subject: [PATCH 089/125] Add package spezifications --- man/position_nudgestack.Rd | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 3a77e318ec..076fb198de 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -26,9 +26,9 @@ ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"), "-1"))) \%>\% - group_by(id, time) \%>\% - summarize(value = mean(value)) \%>\% - filter(time >= "1995-01-01" & time < "1998-01-01") + dplyr::group_by(id, time) \%>\% + dplyr::summarize(value = mean(value)) \%>\% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) From 86dfea050aaee486559afd9391775c30f95be65c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:09:06 +0200 Subject: [PATCH 090/125] Add position_nudgestack --- R/position-nudgestack.R | 117 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 R/position-nudgestack.R diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R new file mode 100644 index 0000000000..f978593441 --- /dev/null +++ b/R/position-nudgestack.R @@ -0,0 +1,117 @@ +#' Simultaneously nudge and stack +#' +#' This is primarily used for set stacked columns between the ticks on the +#' x-axis. +#' +#' @family position adjustments +#' @param x,y Amount of vertical and horizontal distance to move. +#' @param vjust Vertical adjustment for geoms that have a position +#' (like points or lines), not a dimension (like bars or areas). Set to +#' `0` to align with the bottom, `0.5` for the middle, +#' and `1` (the default) for the top. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. +#' @export +#' @examples +#' data <- mtcars +#' ggplot() + +#' geom_col( +#' data, +#' aes(x = cyl, y = gear, fill = gear), +#' position = position_nudgestack(x = 1) +#' ) +position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { + ggproto(NULL, PositionNudgeStack, + x = x, + y = y, + vjust = vjust, + reverse = reverse + ) +} + + + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +PositionNudgeStack <- ggproto("PositionNudgeStack", Position, + x = 0, + y = 0, + type = NULL, + vjust = 1, + fill = FALSE, + reverse = FALSE, + + setup_params = function(self, data) { + list( + x = self$x, + y = self$y, + var = if (!is.null(self$var)) self$var else stack_var(data), + fill = self$fill, + vjust = self$vjust, + reverse = self$reverse + ) + }, + + setup_data = function(self, data, params) { + if (is.null(params$var)) { + return(data) + } + + data$ymax <- switch(params$var, + y = data$y, + ymax = ifelse(data$ymax == 0, data$ymin, data$ymax) + ) + + remove_missing( + data, + vars = c("x", "xmin", "xmax", "y"), + name = "position_stack" + ) + }, + + compute_layer = function(self, data, params, layout) { + if (is.null(params$var)) { + return(data) + } + + negative <- data$ymax < 0 + negative[is.na(negative)] <- FALSE + + neg <- data[negative, , drop = FALSE] + pos <- data[!negative, , drop = FALSE] + + if (any(negative)) { + neg <- collide(neg, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + if (any(!negative)) { + pos <- collide(pos, NULL, "position_stack", pos_stack, + vjust = params$vjust, + fill = params$fill, + reverse = params$reverse + ) + } + + data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] + + + + # transform only the dimensions for which non-zero nudging is requested + if (any(params$x != 0)) { + if (any(params$y != 0)) { + transform_position(data, function(x) x + params$x, function(y) y + params$y) + } else { + transform_position(data, function(x) x + params$x, NULL) + } + } else if (any(params$y != 0)) { + transform_position(data, NULL, function(y) y + params$y) + } else { + data # if both x and y are 0 we don't need to transform + } + } +) From ce942ac23d5ae1321bb3d1e625742fa3de1d23ca Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 3 Sep 2019 09:26:32 +0200 Subject: [PATCH 091/125] Delete emtpy rows --- R/position-nudgestack.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index f978593441..60e67169dd 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -29,8 +29,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ) } - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -99,8 +97,6 @@ PositionNudgeStack <- ggproto("PositionNudgeStack", Position, data <- rbind(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))), ] - - # transform only the dimensions for which non-zero nudging is requested if (any(params$x != 0)) { if (any(params$y != 0)) { From 0750e55113794633579429d2fc0790febdd5631f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 092/125] Add time series example --- R/position-nudgestack.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 60e67169dd..a2837ba90e 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,13 +13,23 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' data <- mtcars -#' ggplot() + -#' geom_col( -#' data, -#' aes(x = cyl, y = gear, fill = gear), -#' position = position_nudgestack(x = 1) +#' library(dplyr) +#' library(ggplot2) +#' ESM <- data.frame( +#' as.matrix(EuStockMarkets), +#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), +#' format = "%d %b %Y" #' ) +#' ) +#' +#' ESM_prep <- ESM %>% +#' tidyr::gather(key = key, value = value, -date) %>% +#' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' +#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, x = x, @@ -36,7 +46,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 621730d92be22580df92522b2c4c2e4f80e60d9e Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:56:35 +0200 Subject: [PATCH 093/125] Add new position to DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 7af9aac5ab..7d23fb894f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -182,6 +182,7 @@ Collate: 'position-jitter.r' 'position-jitterdodge.R' 'position-nudge.R' + 'position-nudgestack.R' 'position-stack.r' 'quick-plot.r' 'range.r' From d1c7ad8663c6247a2ba2ee5b7a3fa71b7867d099 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:58:38 +0200 Subject: [PATCH 094/125] Add new position_nudgestack into NAMESPACE --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 7a90dd5f5f..62e0efb2d1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -204,6 +204,7 @@ export(PositionIdentity) export(PositionJitter) export(PositionJitterdodge) export(PositionNudge) +export(PositionNudgeStack) export(PositionStack) export(Scale) export(ScaleBinned) @@ -432,6 +433,7 @@ export(position_identity) export(position_jitter) export(position_jitterdodge) export(position_nudge) +export(position_nudgestack) export(position_stack) export(qplot) export(quickplot) From b1bb9d10f4b2b4d6ac58ba8444b50f2c961c893f Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 095/125] Add position-nudgestack.R into man --- man/ggplot2-ggproto.Rd | 19 +++++++------- man/position_dodge.Rd | 1 + man/position_identity.Rd | 1 + man/position_jitter.Rd | 1 + man/position_jitterdodge.Rd | 1 + man/position_nudge.Rd | 1 + man/position_nudgestack.Rd | 51 +++++++++++++++++++++++++++++++++++++ man/position_stack.Rd | 1 + 8 files changed, 67 insertions(+), 9 deletions(-) create mode 100644 man/position_nudgestack.Rd diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index 75605bc356..1f6c4bc083 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -14,15 +14,15 @@ % R/geom-spoke.r, R/geom-text.r, R/geom-tile.r, R/geom-violin.r, % R/geom-vline.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-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-qq-line.R, -% R/stat-qq.r, R/stat-quantile.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/position-jitterdodge.R, R/position-nudge.R, R/position-nudgestack.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-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-qq-line.R, R/stat-qq.r, R/stat-quantile.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} @@ -90,6 +90,7 @@ \alias{PositionJitter} \alias{PositionJitterdodge} \alias{PositionNudge} +\alias{PositionNudgeStack} \alias{PositionStack} \alias{PositionFill} \alias{Scale} diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index a35191e4fa..cef3386d86 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -96,6 +96,7 @@ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + Other position adjustments: \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_identity.Rd b/man/position_identity.Rd index 440e575682..994bd2952e 100644 --- a/man/position_identity.Rd +++ b/man/position_identity.Rd @@ -13,6 +13,7 @@ Don't adjust position Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index 16548f6496..37b6df322c 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -58,6 +58,7 @@ ggplot(mtcars, aes(am, vs)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index f543bb332a..ff6e5f05b9 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -40,6 +40,7 @@ ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}}, \code{\link{position_stack}} } diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index aaf735e236..9597692160 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -39,6 +39,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_stack}} } \concept{position adjustments} diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd new file mode 100644 index 0000000000..b2489b3153 --- /dev/null +++ b/man/position_nudgestack.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/position-nudgestack.R +\name{position_nudgestack} +\alias{position_nudgestack} +\title{Simultaneously nudge and stack} +\usage{ +position_nudgestack(x = 0, y = 0, vjust = 1, reverse = FALSE) +} +\arguments{ +\item{x, y}{Amount of vertical and horizontal distance to move.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} +} +\description{ +This is primarily used for set stacked columns between the ticks on the +x-axis. +} +\examples{ +library(dplyr) +library(ggplot2) +ESM <- data.frame( + as.matrix(EuStockMarkets), + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "\%d \%b \%Y" + ) +) + +ESM_prep <- ESM \%>\% + tidyr::gather(key = key, value = value, -date) \%>\% + group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% + filter(date >= "1995-01-01" & date <= "1997-12-01") + +ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) +} +\seealso{ +Other position adjustments: \code{\link{position_dodge}}, + \code{\link{position_identity}}, + \code{\link{position_jitterdodge}}, + \code{\link{position_jitter}}, + \code{\link{position_nudge}}, + \code{\link{position_stack}} +} +\concept{position adjustments} diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 39ea363603..991aed9c2c 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -144,6 +144,7 @@ Other position adjustments: \code{\link{position_dodge}}, \code{\link{position_identity}}, \code{\link{position_jitterdodge}}, \code{\link{position_jitter}}, + \code{\link{position_nudgestack}}, \code{\link{position_nudge}} } \concept{position adjustments} From fc6ba5ab80bbbb6f8b3c775749091829b99ce29c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 096/125] Add the zoo-package to Suggestions --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7d23fb894f..75ab77affe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Suggests: sf (>= 0.7-3), svglite (>= 1.2.0.9001), testthat (>= 2.1.0), - vdiffr (>= 0.3.0) + vdiffr (>= 0.3.0), + zoo Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From 32d220302edc48032e11d69be3a519d7e1741fec Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 097/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a2837ba90e..fdfa395feb 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -26,7 +26,7 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date <= "1997-12-01") +#' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From 5270a9df4ed4a1326aec4c6e2a5069efdbb9cfd4 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:20 +0200 Subject: [PATCH 098/125] Delete packages from @examples --- R/position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fdfa395feb..a031937593 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,8 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' library(dplyr) -#' library(ggplot2) #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), From fbf28dc6e70e02dd8bd67312035a4fb2f2ae522a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 099/125] Add new examples --- man/position_nudgestack.Rd | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index b2489b3153..7efb57a035 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,8 +22,6 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -library(dplyr) -library(ggplot2) ESM <- data.frame( as.matrix(EuStockMarkets), date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), @@ -35,7 +33,7 @@ ESM_prep <- ESM \%>\% tidyr::gather(key = key, value = value, -date) \%>\% group_by(date, key) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date <= "1997-12-01") + filter(date >= "1995-01-01" & date < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + geom_col(position = position_nudgestack(x = 15)) From 3ba06abc5a02d85c1fde9172ef9823481b515efd Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 100/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/testthat/test-position-nudgestack.R diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R new file mode 100644 index 0000000000..cda3fd3e20 --- /dev/null +++ b/tests/testthat/test-position-nudgestack.R @@ -0,0 +1,27 @@ +context("position_nudgestack") + +test_that("position_nudgestack draws correctly", { + ESM <- data_frame( + DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], + SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], + CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], + FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), + format = "%d %b %Y" + ) + ) + + ESM_prep <- ESM %>% + tidyr::gather(key = key, value = value, -date) %>% + group_by(date, key) %>% + summarize(value = mean(value)) %>% + filter(date >= "1995-01-01" & date < "1998-01-01") + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + geom_col(position = position_nudgestack(x = 15)) + + expect_doppelganger( + "nudgestack EuStockMarkets data", + stock_marked + ) +}) From f26bb9075b23e7b3a8c9e80bfd708c64d89e9823 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 101/125] Add validated svg for position_nudgestack --- .../nudgestack-eustockmarkets-data.svg | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg new file mode 100644 index 0000000000..fc0ed6d9a6 --- /dev/null +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -0,0 +1,203 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10000 +20000 + + + + + + + +1995 +1996 +1997 +1998 +date +value + +key + + + + + + + + +CAC +DAX +FTSE +SMI +nudgestack EuStockMarkets data + From 3a1c71f90228eb3571ecd8b6f1724ea19ca8ffa6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 102/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 93 +++++++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index cda3fd3e20..6ac2277a09 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -25,3 +25,96 @@ test_that("position_nudgestack draws correctly", { stock_marked ) }) + + +test_that("nudging works in both dimensions simultaneously", { + # individual nudge value for continuous data + set.seed(111) + + df <- data_frame(x = 1:3) + + p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + + geom_col(position = position_nudgestack(x = 0.5, y = 2)) + + data <- layer_data(p) + + expect_equal(data$x, 1.5:3.5) + expect_equal(data$xmin, 1.05:3.05) + expect_equal(data$xmax, 1.95:3.95) + expect_equal(data$y, 3:5) + expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymax, 3:5) + +}) + +test_that("nudging works for discrete values correctly", { + set.seed(111) + + # x nudge value for discrete data + series <- data.frame( + time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c('a', 'b', 'c', 'd'), 4), + value = rpois(16, 10) + ) + + p <- ggplot(series, aes(time, value, group = type)) + + geom_line(aes(colour = type), position = position_nudgestack(x = 0.5)) + + geom_point(aes(colour = type), position = position_nudgestack(x = 0.5)) + + data <- layer_data(p) + + expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + +}) + + +test_that("data is sorted prior to stacking", { + df <- data_frame( + x = rep(c(1:10), 3), + var = rep(c("a", "b", "c"), 10), + y = round(runif(30, 1, 5)) + ) + p <- ggplot(df, aes(x = x, y = y, fill = var)) + + geom_col(position = position_nudgestack(x = 0.5)) + + dat <- layer_data(p) + expect_true(all(dat$group == 3:1)) +}) + +test_that("negative and positive values are handled separately", { + df <- data_frame( + x = c(1,1,1,2,2), + g = c(1,2,3,1,2), + y = c(1,-1,1,2,-3) + ) + p <- ggplot(df, aes(x, y, fill = factor(g))) + + geom_col(position = position_nudgestack(x = 0.5)) + dat <- layer_data(p) + + expect_equal(dat$ymin[dat$x == 1.5], c(0, -1, 1)) + expect_equal(dat$ymax[dat$x == 1.5], c(1, 0, 2)) + + expect_equal(dat$ymin[dat$x == 2.5], c(0, -3)) + expect_equal(dat$ymax[dat$x == 2.5], c(2, 0)) +}) + +test_that("can request reverse stacking", { + df <- data_frame( + y = c(-2, 2, -1, 1), + g = c("a", "a", "b", "b") + ) + p <- ggplot(df, aes(1, y, fill = g)) + + geom_col(position = position_nudgestack(x = 0.5, reverse = TRUE)) + dat <- layer_data(p) + expect_equal(dat$ymin, c(-2, 0, -3, 2)) +}) + +test_that("position_nudgestack() can stack correctly when ymax is NA", { + df <- data_frame(x = c(1, 1), y = c(1, 1)) + p <- ggplot(df, aes(x, y, ymax = NA_real_)) + + geom_point(position = position_nudgestack(x = 0.5)) + expect_equal(layer_data(p)$y, c(1, 2)) +}) + From 71d567bcadca14f9a45d4aa049cf482565d7956b Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 103/125] Add time series example --- R/position-nudgestack.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index a031937593..c26523f1c0 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,6 +13,11 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples +<<<<<<< HEAD +======= +#' library(dplyr) +#' library(ggplot2) +>>>>>>> Add time series example #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), @@ -24,7 +29,11 @@ #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' summarize(value = mean(value)) %>% +<<<<<<< HEAD #' filter(date >= "1995-01-01" & date < "1998-01-01") +======= +#' filter(date >= "1995-01-01" & date <= "1997-12-01") +>>>>>>> Add time series example #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) From 59bc2a0be67924a0d274c8998918f32c3cd83bc6 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 14:00:28 +0200 Subject: [PATCH 104/125] Add position-nudgestack.R into man --- R/position-nudgestack.R | 10 ---------- man/position_nudgestack.Rd | 1 - 2 files changed, 11 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index c26523f1c0..dda90a316c 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,11 +13,6 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -<<<<<<< HEAD -======= -#' library(dplyr) -#' library(ggplot2) ->>>>>>> Add time series example #' ESM <- data.frame( #' as.matrix(EuStockMarkets), #' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), @@ -28,12 +23,7 @@ #' ESM_prep <- ESM %>% #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% -#' summarize(value = mean(value)) %>% -<<<<<<< HEAD #' filter(date >= "1995-01-01" & date < "1998-01-01") -======= -#' filter(date >= "1995-01-01" & date <= "1997-12-01") ->>>>>>> Add time series example #' #' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + #' geom_col(position = position_nudgestack(x = 15)) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 7efb57a035..f2f842e547 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -32,7 +32,6 @@ ESM <- data.frame( ESM_prep <- ESM \%>\% tidyr::gather(key = key, value = value, -date) \%>\% group_by(date, key) \%>\% - summarize(value = mean(value)) \%>\% filter(date >= "1995-01-01" & date < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + From 28640d573ae5eba73fa4853f05af487168c1ee3b Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Fri, 27 Sep 2019 15:58:51 +0200 Subject: [PATCH 105/125] Bugfix --- tests/testthat/test-position-nudgestack.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 6ac2277a09..f3532c9686 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -2,10 +2,10 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { ESM <- data_frame( - DAX = EuStockMarkets[colnames(EuStockMarkets) == "DAX"], - SMI = EuStockMarkets[colnames(EuStockMarkets) == "SMI"], - CAC = EuStockMarkets[colnames(EuStockMarkets) == "CAC"], - FTSE = EuStockMarkets[colnames(EuStockMarkets) == "FTSE"], + DAX = EuStockMarkets[,"DAX"], + SMI = EuStockMarkets[,"SMI"], + CAC = EuStockMarkets[,"CAC"], + FTSE = EuStockMarkets[,"FTSE"], date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), format = "%d %b %Y" ) From 8848fd99eee7c515dbd264d58f756bab588b0b58 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 30 Sep 2019 14:06:24 +0200 Subject: [PATCH 106/125] Use tsbox for converting ts object to tibble --- DESCRIPTION | 2 +- R/position-nudgestack.R | 9 +- man/position_nudgestack.Rd | 9 +- .../nudgestack-eustockmarkets-data.svg | 302 +++++++++--------- tests/testthat/test-position-nudgestack.R | 23 +- 5 files changed, 165 insertions(+), 180 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 75ab77affe..0b2fa2e53f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,7 +56,7 @@ Suggests: svglite (>= 1.2.0.9001), testthat (>= 2.1.0), vdiffr (>= 0.3.0), - zoo + tsbox Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index dda90a316c..0df18b91b8 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -13,19 +13,14 @@ #' This is useful if you're rotating both the plot and legend. #' @export #' @examples -#' ESM <- data.frame( -#' as.matrix(EuStockMarkets), -#' date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), -#' format = "%d %b %Y" -#' ) -#' ) +#' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% #' filter(date >= "1995-01-01" & date < "1998-01-01") #' -#' ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +#' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { ggproto(NULL, PositionNudgeStack, diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index f2f842e547..3fb5664540 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -22,19 +22,14 @@ This is primarily used for set stacked columns between the ticks on the x-axis. } \examples{ -ESM <- data.frame( - as.matrix(EuStockMarkets), - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "\%d \%b \%Y" - ) -) +ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% tidyr::gather(key = key, value = value, -date) \%>\% group_by(date, key) \%>\% filter(date >= "1995-01-01" & date < "1998-01-01") -ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + +ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) } \seealso{ diff --git a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg index fc0ed6d9a6..326eed0610 100644 --- a/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg +++ b/tests/figs/position-nudgestack/nudgestack-eustockmarkets-data.svg @@ -19,150 +19,150 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -170,11 +170,13 @@ 0 -10000 -20000 +5000 +10000 +15000 - - + + + @@ -183,10 +185,10 @@ 1996 1997 1998 -date +time value -key +id diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index f3532c9686..29964c5dfb 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,23 +1,16 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- data_frame( - DAX = EuStockMarkets[,"DAX"], - SMI = EuStockMarkets[,"SMI"], - CAC = EuStockMarkets[,"CAC"], - FTSE = EuStockMarkets[,"FTSE"], - date = as.Date(paste(1, zoo::as.yearmon(time(EuStockMarkets))), - format = "%d %b %Y" - ) - ) + + ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - tidyr::gather(key = key, value = value, -date) %>% - group_by(date, key) %>% - summarize(value = mean(value)) %>% - filter(date >= "1995-01-01" & date < "1998-01-01") + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::group_by(id, time) %>% + dplyr::summarize(value = mean(value)) %>% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = date, y = value, fill = key)) + + stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -51,7 +44,7 @@ test_that("nudging works for discrete values correctly", { set.seed(111) # x nudge value for discrete data - series <- data.frame( + series <- data_frame( time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), type = rep(c('a', 'b', 'c', 'd'), 4), value = rpois(16, 10) From e5d61b5d7ce51a72d3974b56b1eabe602af7fc13 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:06:00 +0200 Subject: [PATCH 107/125] Adjust filter criterion in examples --- R/position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 0df18b91b8..e7bf2f4138 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -18,6 +18,7 @@ #' ESM_prep <- ESM %>% #' tidyr::gather(key = key, value = value, -date) %>% #' group_by(date, key) %>% +#' summarize(value = mean(value)) %>% #' filter(date >= "1995-01-01" & date < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + From 65e72fbba684806b240d2b73d37040a87b71bfa9 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 108/125] Add new examples --- man/position_nudgestack.Rd | 1 + 1 file changed, 1 insertion(+) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 3fb5664540..1ee1477c55 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -27,6 +27,7 @@ ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% tidyr::gather(key = key, value = value, -date) \%>\% group_by(date, key) \%>\% + summarize(value = mean(value)) \%>\% filter(date >= "1995-01-01" & date < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + From 1b617506d2aa6d77f3dbef5a56b74dd47afa0416 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 109/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 29964c5dfb..c64d4ac0ec 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -110,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From 4d66dade22305d582fcd4d491a87b6df180d3121 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 110/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index c64d4ac0ec..29964c5dfb 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -110,3 +110,4 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) + From e4e7ee0bb528f0f71c9a52dc28d14675e81f1309 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 08:51:55 +0200 Subject: [PATCH 111/125] Resolve conflict --- R/position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index e7bf2f4138..ef52bdd691 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -39,6 +39,7 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, + type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 369a34bca7f76f53638590802f6079b872709f6c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 30 Sep 2019 14:06:24 +0200 Subject: [PATCH 112/125] Use tsbox for converting ts object to tibble --- R/position-nudgestack.R | 6 +++--- man/position_nudgestack.Rd | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index ef52bdd691..139374d410 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -16,10 +16,10 @@ #' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' tidyr::gather(key = key, value = value, -date) %>% -#' group_by(date, key) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' group_by(id, time) %>% #' summarize(value = mean(value)) %>% -#' filter(date >= "1995-01-01" & date < "1998-01-01") +#' filter(time >= "1995-01-01" & time < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 1ee1477c55..5d6a382bd3 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -25,10 +25,10 @@ x-axis. ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - tidyr::gather(key = key, value = value, -date) \%>\% - group_by(date, key) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% - filter(date >= "1995-01-01" & date < "1998-01-01") + filter(time >= "1995-01-01" & time < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15)) From b61211d4a8b6466540a124ed80cf3307b65e0ed8 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 113/125] Style file --- R/position-nudgestack.R | 2 +- tests/testthat/test-position-nudgestack.R | 29 +++++++++++------------ 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 139374d410..85d9f0cbc9 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -16,7 +16,7 @@ #' ESM <- tsbox::ts_tbl(EuStockMarkets) #' #' ESM_prep <- ESM %>% -#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% +#' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% #' group_by(id, time) %>% #' summarize(value = mean(value)) %>% #' filter(time >= "1995-01-01" & time < "1998-01-01") diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 29964c5dfb..85a11f197a 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,16 +1,18 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { - ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% - dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"),"-1"))) %>% + dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% dplyr::group_by(id, time) %>% dplyr::summarize(value = mean(value)) %>% dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") - stock_marked <- ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + + stock_marked <- ggplot( + data = ESM_prep, + mapping = aes(x = time, y = value, fill = id) + ) + geom_col(position = position_nudgestack(x = 15)) expect_doppelganger( @@ -35,9 +37,8 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$xmin, 1.05:3.05) expect_equal(data$xmax, 1.95:3.95) expect_equal(data$y, 3:5) - expect_equal(data$ymin, c(2,2,2)) + expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) - }) test_that("nudging works for discrete values correctly", { @@ -45,8 +46,8 @@ test_that("nudging works for discrete values correctly", { # x nudge value for discrete data series <- data_frame( - time = factor(c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4))), - type = rep(c('a', 'b', 'c', 'd'), 4), + time = factor(c(rep(1, 4), rep(2, 4), rep(3, 4), rep(4, 4))), + type = rep(c("a", "b", "c", "d"), 4), value = rpois(16, 10) ) @@ -56,10 +57,9 @@ test_that("nudging works for discrete values correctly", { data <- layer_data(p) - expect_equal(data$x, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmin, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - expect_equal(data$xmax, c(rep(1.5, 4),rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) - + expect_equal(data$x, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmin, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) + expect_equal(data$xmax, c(rep(1.5, 4), rep(2.5, 4), rep(3.5, 4), rep(4.5, 4))) }) @@ -78,9 +78,9 @@ test_that("data is sorted prior to stacking", { test_that("negative and positive values are handled separately", { df <- data_frame( - x = c(1,1,1,2,2), - g = c(1,2,3,1,2), - y = c(1,-1,1,2,-3) + x = c(1, 1, 1, 2, 2), + g = c(1, 2, 3, 1, 2), + y = c(1, -1, 1, 2, -3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col(position = position_nudgestack(x = 0.5)) @@ -110,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From 6e4398c0c2d48d0dc7f602cbdeab6ae9bde0d67e Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 114/125] Style file --- man/position_nudgestack.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 5d6a382bd3..3a77e318ec 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -25,7 +25,7 @@ x-axis. ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% - dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"),"-1"))) \%>\% + dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"), "-1"))) \%>\% group_by(id, time) \%>\% summarize(value = mean(value)) \%>\% filter(time >= "1995-01-01" & time < "1998-01-01") From 415811ce7fc7e65f3e1b5da529752fbd1661162c Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:44:37 +0200 Subject: [PATCH 115/125] Add news --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index ac58e9c933..ac1c5fdb58 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Added `position_nudgestack()`, which allows to nudge stacked columns. (@ThomasKnecht ) + * A new scale type has been added, that allows binning of aesthetics at the scale level. It has versions for both position and non-position aesthetics and comes with two new guides (`guide_bins` and `guide_coloursteps`) (@thomasp85, #3096) From 90d1257f6567ca1735bb27d9560e82d90faa3348 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 16 Sep 2019 13:47:58 +0200 Subject: [PATCH 116/125] Add time series example --- R/position-nudgestack.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 85d9f0cbc9..fecbd48253 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -39,7 +39,6 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, - type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From 598b7869f18adc0c351660f059db02e369a89670 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:02:29 +0200 Subject: [PATCH 117/125] Add test file with a doppelganger-test --- tests/testthat/test-position-nudgestack.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 85a11f197a..5e78ef3956 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,6 +1,7 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { +<<<<<<< HEAD ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% @@ -110,3 +111,4 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) + From 662a5da67cd933948f9d99f0cee49ed1cb31bcbe Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 18:03:12 +0200 Subject: [PATCH 118/125] Add validated svg for position_nudgestack --- tests/testthat/test-position-nudgestack.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 5e78ef3956..a1bf22af4b 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -1,7 +1,6 @@ context("position_nudgestack") test_that("position_nudgestack draws correctly", { -<<<<<<< HEAD ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM %>% From 739ac7c6877749c0f8f37b722168fe54a45b37e0 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Wed, 18 Sep 2019 15:55:02 +0200 Subject: [PATCH 119/125] Add tests for correct nudging and stacking --- tests/testthat/test-position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index a1bf22af4b..3144396cbc 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -39,6 +39,7 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$y, 3:5) expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) + }) test_that("nudging works for discrete values correctly", { From 32100612bcd99d73da5fbdb51ae49f1b8c543fdd Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 15:39:56 +0200 Subject: [PATCH 120/125] Add the zoo-package to Suggestions --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 0b2fa2e53f..6914d3dc05 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,6 +57,7 @@ Suggests: testthat (>= 2.1.0), vdiffr (>= 0.3.0), tsbox + Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From 325456a63e694dc14602411bcb82b01f25173629 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 17 Sep 2019 16:09:49 +0200 Subject: [PATCH 121/125] Add new examples --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6914d3dc05..0b2fa2e53f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,7 +57,6 @@ Suggests: testthat (>= 2.1.0), vdiffr (>= 0.3.0), tsbox - Enhances: sp License: GPL-2 | file LICENSE URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 From e0368b017c86b3b7ef957e93ab0f314520dcf851 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 08:51:55 +0200 Subject: [PATCH 122/125] Resolve conflict --- R/position-nudgestack.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index fecbd48253..85d9f0cbc9 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -39,6 +39,7 @@ position_nudgestack <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) { PositionNudgeStack <- ggproto("PositionNudgeStack", Position, x = 0, y = 0, + type = NULL, vjust = 1, fill = FALSE, reverse = FALSE, From d9ec75285b1fc471b9152bc5e9fc19697935889a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Tue, 1 Oct 2019 09:20:41 +0200 Subject: [PATCH 123/125] Style file --- tests/testthat/test-position-nudgestack.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/tests/testthat/test-position-nudgestack.R b/tests/testthat/test-position-nudgestack.R index 3144396cbc..85a11f197a 100644 --- a/tests/testthat/test-position-nudgestack.R +++ b/tests/testthat/test-position-nudgestack.R @@ -39,7 +39,6 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$y, 3:5) expect_equal(data$ymin, c(2, 2, 2)) expect_equal(data$ymax, 3:5) - }) test_that("nudging works for discrete values correctly", { @@ -111,4 +110,3 @@ test_that("position_nudgestack() can stack correctly when ymax is NA", { geom_point(position = position_nudgestack(x = 0.5)) expect_equal(layer_data(p)$y, c(1, 2)) }) - From 5de0449dc5be236c242f3559fbd8ea9935b887d8 Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 7 Oct 2019 11:53:06 +0200 Subject: [PATCH 124/125] Add package spezifications --- R/position-nudgestack.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/position-nudgestack.R b/R/position-nudgestack.R index 85d9f0cbc9..84d110970d 100644 --- a/R/position-nudgestack.R +++ b/R/position-nudgestack.R @@ -17,9 +17,9 @@ #' #' ESM_prep <- ESM %>% #' dplyr::mutate(time = as.Date(paste0(format(time, "%Y-%m"), "-1"))) %>% -#' group_by(id, time) %>% -#' summarize(value = mean(value)) %>% -#' filter(time >= "1995-01-01" & time < "1998-01-01") +#' dplyr::group_by(id, time) %>% +#' dplyr::summarize(value = mean(value)) %>% +#' dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") #' #' ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + #' geom_col(position = position_nudgestack(x = 15)) From e1846bcdff46665aa4f5134d3196975a1679a09a Mon Sep 17 00:00:00 2001 From: Thomas Knecht Date: Mon, 7 Oct 2019 11:58:47 +0200 Subject: [PATCH 125/125] Add package spezifications --- man/position_nudgestack.Rd | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/man/position_nudgestack.Rd b/man/position_nudgestack.Rd index 3a77e318ec..076fb198de 100644 --- a/man/position_nudgestack.Rd +++ b/man/position_nudgestack.Rd @@ -26,9 +26,9 @@ ESM <- tsbox::ts_tbl(EuStockMarkets) ESM_prep <- ESM \%>\% dplyr::mutate(time = as.Date(paste0(format(time, "\%Y-\%m"), "-1"))) \%>\% - group_by(id, time) \%>\% - summarize(value = mean(value)) \%>\% - filter(time >= "1995-01-01" & time < "1998-01-01") + dplyr::group_by(id, time) \%>\% + dplyr::summarize(value = mean(value)) \%>\% + dplyr::filter(time >= "1995-01-01" & time < "1998-01-01") ggplot(data = ESM_prep, mapping = aes(x = time, y = value, fill = id)) + geom_col(position = position_nudgestack(x = 15))