From 5f067c156ed2f0c5cfda6d0df2baea0f0d89a49e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Oct 2024 09:57:18 +0200 Subject: [PATCH 01/22] write boilerplate function --- DESCRIPTION | 5 ++-- R/boilerplates.R | 64 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 2 deletions(-) create mode 100644 R/boilerplates.R diff --git a/DESCRIPTION b/DESCRIPTION index ff587e4b88..4c5b6a706a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -108,6 +108,9 @@ Collate: 'backports.R' 'bench.R' 'bin.R' + 'scale-type.R' + 'layer.R' + 'boilerplates.R' 'coord-.R' 'coord-cartesian-.R' 'coord-fixed.R' @@ -186,7 +189,6 @@ Collate: 'guide-colorbar.R' 'guide-colorsteps.R' 'guide-custom.R' - 'layer.R' 'guide-none.R' 'guide-old.R' 'guides-.R' @@ -236,7 +238,6 @@ Collate: 'scale-shape.R' 'scale-size.R' 'scale-steps.R' - 'scale-type.R' 'scale-view.R' 'scale-viridis.R' 'scales-.R' diff --git a/R/boilerplates.R b/R/boilerplates.R new file mode 100644 index 0000000000..26d8030aeb --- /dev/null +++ b/R/boilerplates.R @@ -0,0 +1,64 @@ +#' @include layer.R +#' @include scale-type.R +NULL + +#' @export +boilerplate <- function(x, ...) { + UseMethod("boilerplate") +} + +#' @export +boilerplate.Geom <- function(x, ..., env = caller_env()) { + + # Check that we can independently find the geom + geom <- gsub("^geom_", "", snake_class(x)) + check_subclass(geom, "Geom", env = env) + + # Split additional arguments into required and extra ones + args <- enexprs(...) + fixed_fmls_names <- c("mapping", "data", "stat", "position", "...", + "na.rm", "show.legend", "inherit.aes") + extra_args <- setdiff(names(args), fixed_fmls_names) + if ("geom" %in% extra_args) { + cli::cli_abort("{.arg geom} is a reserved argument.") + } + + # Build function formals + fmls <- list2( + mapping = args$mapping, + data = args$data, + stat = args$stat %||% "identity", + position = args$position %||% "identity", + `...` = quote(expr = ), + !!!args[extra_args], + na.rm = args$na.rm %||% FALSE, + show.legend = args$show.legend %||% NA, + inherit.aes = args$inherit.aes %||% TRUE + ) + + if (length(extra_args) > 0) { + extra_args <- paste0( + "\n ", extra_args, " = ", extra_args, ",", collapse = "" + ) + } + + body <- paste0(" + layer( + data = data, + mapping = mapping, + stat = stat, + geom = \"", geom, "\", + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm,", + extra_args, " + ... + ) + ) + ") + body <- as.call(parse(text = body))[[1]] + + new_function(fmls, body) +} From 32a4a763ef6d0d8859896a76e3c0be7ff01a39e6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Oct 2024 11:20:26 +0200 Subject: [PATCH 02/22] adopt boilerplate where possible --- DESCRIPTION | 10 +- NAMESPACE | 2 + R/geom-bar.R | 110 ++++++-------- R/geom-bin2d.R | 25 +--- R/geom-col.R | 24 +-- R/geom-contour.R | 111 ++++---------- R/geom-count.R | 24 +-- R/geom-crossbar.R | 31 +--- R/geom-curve.R | 110 ++++++-------- R/geom-density.R | 25 ++-- R/geom-errorbar.R | 29 +--- R/geom-errorbarh.R | 76 ++++------ R/geom-hex.R | 86 ++++------- R/geom-histogram.R | 32 +--- R/geom-linerange.R | 110 ++++++-------- R/geom-path.R | 332 +++++++++++++++++------------------------ R/geom-point.R | 93 +++++------- R/geom-pointrange.R | 31 +--- R/geom-polygon.R | 187 +++++++++++------------ R/geom-quantile.R | 54 ++----- R/geom-rect.R | 29 +--- R/geom-rug.R | 142 ++++++++---------- R/geom-segment.R | 151 ++++++++----------- R/geom-smooth.R | 123 +++++++-------- R/geom-spoke.R | 56 +++---- R/geom-tile.R | 101 +++++-------- R/geom-violin.R | 216 ++++++++++++--------------- man/geom_bar.Rd | 9 +- man/geom_histogram.Rd | 2 +- man/geom_linerange.Rd | 14 +- man/geom_path.Rd | 12 +- man/geom_polygon.Rd | 13 +- man/geom_rug.Rd | 1 - man/geom_violin.Rd | 11 +- man/ggplot2-ggproto.Rd | 43 +++--- man/is_tests.Rd | 10 +- 36 files changed, 942 insertions(+), 1493 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4c5b6a706a..fad521e72d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -96,6 +96,9 @@ Collate: 'geom-.R' 'annotation-custom.R' 'annotation-logticks.R' + 'scale-type.R' + 'layer.R' + 'boilerplates.R' 'geom-polygon.R' 'geom-map.R' 'annotation-map.R' @@ -108,9 +111,6 @@ Collate: 'backports.R' 'bench.R' 'bin.R' - 'scale-type.R' - 'layer.R' - 'boilerplates.R' 'coord-.R' 'coord-cartesian-.R' 'coord-fixed.R' @@ -137,12 +137,14 @@ Collate: 'geom-abline.R' 'geom-rect.R' 'geom-bar.R' + 'geom-tile.R' 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' 'geom-col.R' 'geom-path.R' 'geom-contour.R' + 'geom-point.R' 'geom-count.R' 'geom-crossbar.R' 'geom-segment.R' @@ -162,7 +164,6 @@ Collate: 'geom-jitter.R' 'geom-label.R' 'geom-linerange.R' - 'geom-point.R' 'geom-pointrange.R' 'geom-quantile.R' 'geom-rug.R' @@ -170,7 +171,6 @@ Collate: 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' - 'geom-tile.R' 'geom-violin.R' 'geom-vline.R' 'ggplot2-package.R' diff --git a/NAMESPACE b/NAMESPACE index 5737492a00..3b0b353c06 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ S3method(as.data.frame,mapped_discrete) S3method(as.list,ggproto) S3method(autolayer,default) S3method(autoplot,default) +S3method(boilerplate,Geom) S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(element_grob,element_blank) @@ -297,6 +298,7 @@ export(autolayer) export(autoplot) export(benchplot) export(binned_scale) +export(boilerplate) export(borders) export(calc_element) export(check_device) diff --git a/R/geom-bar.R b/R/geom-bar.R index de7490bfc4..3027d02f53 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -1,3 +1,45 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-rect.R +GeomBar <- ggproto("GeomBar", GeomRect, + required_aes = c("x", "y"), + + # These aes columns are created by setup_data(). They need to be listed here so + # that GeomRect$handle_na() properly removes any bars that fall outside the defined + # limits, not just those for which x and y are outside the limits + non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), + + default_aes = aes(!!!GeomRect$default_aes, width = NULL), + + setup_params = function(data, params) { + params$flipped_aes <- has_flipped_aes(data, params) + params + }, + + extra_params = c("just", "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 %||% (min(vapply( + split(data$x, data$PANEL, drop = TRUE), + resolution, numeric(1), zero = FALSE + )) * 0.9) + data$just <- params$just %||% 0.5 + data <- transform(data, + ymin = pmin(y, 0), ymax = pmax(y, 0), + xmin = x - width * just, xmax = x + width * (1 - just), + width = NULL, just = NULL + ) + flip_data(data, params$flipped_aes) + }, + + rename_size = TRUE +) + #' Bar charts #' #' There are two types of bar charts: `geom_bar()` and `geom_col()`. @@ -92,69 +134,7 @@ #' ggplot(df, aes(x, y)) + geom_col(just = 0.5) #' # Columns begin on the first day of the month #' ggplot(df, aes(x, y)) + geom_col(just = 1) -geom_bar <- function(mapping = NULL, data = NULL, - stat = "count", position = "stack", - ..., - just = 0.5, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomBar, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - just = just, - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-rect.R -GeomBar <- ggproto("GeomBar", GeomRect, - required_aes = c("x", "y"), - - # These aes columns are created by setup_data(). They need to be listed here so - # that GeomRect$handle_na() properly removes any bars that fall outside the defined - # limits, not just those for which x and y are outside the limits - non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), - - default_aes = aes(!!!GeomRect$default_aes, width = NULL), - - setup_params = function(data, params) { - params$flipped_aes <- has_flipped_aes(data, params) - params - }, - - extra_params = c("just", "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 %||% (min(vapply( - split(data$x, data$PANEL, drop = TRUE), - resolution, numeric(1), zero = FALSE - )) * 0.9) - data$just <- params$just %||% 0.5 - data <- transform(data, - ymin = pmin(y, 0), ymax = pmax(y, 0), - xmin = x - width * just, xmax = x + width * (1 - just), - width = NULL, just = NULL - ) - flip_data(data, params$flipped_aes) - }, - - rename_size = TRUE +geom_bar <- boilerplate( + GeomBar, stat = "count", position = "stack", + just = 0.5, orientation = NA ) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 2fe756dc96..1534b9a7ae 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -1,3 +1,6 @@ +#' @include geom-tile.R +NULL + #' Heatmap of 2d bin counts #' #' Divides the plane into rectangles, counts the number of cases in @@ -26,27 +29,7 @@ #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) -geom_bin_2d <- function(mapping = NULL, data = NULL, - stat = "bin2d", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomTile, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} +geom_bin_2d <- boilerplate(GeomTile, stat = "bin2d") #' @export #' @rdname geom_bin_2d diff --git a/R/geom-col.R b/R/geom-col.R index 77c756f573..f779fb6e3a 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,28 +1,6 @@ #' @export #' @rdname geom_bar -geom_col <- function(mapping = NULL, data = NULL, - position = "stack", - ..., - just = 0.5, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = "identity", - geom = GeomCol, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - just = just, - na.rm = na.rm, - ... - ) - ) -} +geom_col <- boilerplate(GeomBar, position = "stack", just = 0.5) #' @rdname ggplot2-ggproto #' @format NULL diff --git a/R/geom-contour.R b/R/geom-contour.R index a73bc3a135..7bd4c17e39 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -1,3 +1,26 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-path.R +GeomContour <- ggproto( + "GeomContour", GeomPath, + default_aes = aes( + weight = 1, + colour = from_theme(accent), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ) +) + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-polygon.R +GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) + #' 2D contours of a 3D surface #' #' @description @@ -56,87 +79,15 @@ #' v + geom_raster(aes(fill = density)) + #' geom_contour(colour = "white") #' } -geom_contour <- function(mapping = NULL, data = NULL, - stat = "contour", position = "identity", - ..., - bins = NULL, - binwidth = NULL, - breaks = NULL, - lineend = "butt", - linejoin = "round", - linemitre = 10, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomContour, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - breaks = breaks, - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre, - na.rm = na.rm, - ... - ) - ) -} +geom_contour <- boilerplate( + GeomContour, stat = "contour", + bins = NULL, binwidth = NULL, breaks = NULL, + lineend = "butt", linejoin = "round", linemitre = 10 +) #' @rdname geom_contour #' @export -geom_contour_filled <- function(mapping = NULL, data = NULL, - stat = "contour_filled", position = "identity", - ..., - bins = NULL, - binwidth = NULL, - breaks = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomContourFilled, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - breaks = breaks, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-path.R -GeomContour <- ggproto("GeomContour", GeomPath, - default_aes = aes( - weight = 1, - colour = from_theme(accent), - linewidth = from_theme(linewidth), - linetype = from_theme(linetype), - alpha = NA - ) +geom_contour_filled <- boilerplate( + GeomContourFilled, stat = "contour_filled", + bins = NULL, binwidth = NULL, breaks = NULL ) - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-polygon.R -GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) - diff --git a/R/geom-count.R b/R/geom-count.R index 37b2e2922e..a3c6de4cc2 100644 --- a/R/geom-count.R +++ b/R/geom-count.R @@ -1,3 +1,6 @@ +#' @include geom-point.R +NULL + #' Count overlapping points #' #' This is a variant [geom_point()] that counts the number of @@ -43,23 +46,4 @@ #' scale_size_area(max_size = 10) #' d + geom_count(aes(size = after_stat(prop), group = clarity)) + #' scale_size_area(max_size = 10) -geom_count <- function(mapping = NULL, data = NULL, - stat = "sum", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomPoint, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} +geom_count <- boilerplate(GeomPoint, stat = "sum") diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 1f7c66f832..2946f703c5 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -1,30 +1,3 @@ -#' @export -#' @rdname geom_linerange -geom_crossbar <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - fatten = 2.5, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomCrossbar, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - fatten = fatten, - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -117,3 +90,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, rename_size = TRUE ) + +#' @export +#' @rdname geom_linerange +geom_crossbar <- boilerplate(GeomCrossbar, fatten = 2.5, orientation = NA) diff --git a/R/geom-curve.R b/R/geom-curve.R index e1c38d1cd4..dd95a1deab 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -1,39 +1,3 @@ -#' @inheritParams grid::curveGrob -#' @export -#' @rdname geom_segment -geom_curve <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - curvature = 0.5, - angle = 90, - ncp = 5, - arrow = NULL, - arrow.fill = NULL, - lineend = "butt", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomCurve, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - arrow = arrow, - arrow.fill = arrow.fill, - curvature = curvature, - angle = angle, - ncp = ncp, - lineend = lineend, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @include geom-segment.R #' @format NULL @@ -41,41 +5,51 @@ geom_curve <- function(mapping = NULL, data = NULL, #' @export GeomCurve <- ggproto("GeomCurve", GeomSegment, - default_aes = aes( - colour = from_theme(ink), - linewidth = from_theme(linewidth), - linetype = from_theme(linetype), - alpha = NA - ), + default_aes = aes( + colour = from_theme(ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), - draw_panel = function(data, panel_params, coord, curvature = 0.5, angle = 90, - ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) { + draw_panel = function(data, panel_params, coord, curvature = 0.5, angle = 90, + ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) { - if (!coord$is_linear()) { - cli::cli_warn("{.fn geom_curve} is not implemented for non-linear coordinates") - } - data <- remove_missing( - data, na.rm = na.rm, - c("x", "y", "xend", "yend", "linetype", "linewidth"), - name = "geom_curve" - ) + if (!coord$is_linear()) { + cli::cli_warn("{.fn geom_curve} is not implemented for non-linear coordinates") + } + data <- remove_missing( + data, na.rm = na.rm, + c("x", "y", "xend", "yend", "linetype", "linewidth"), + name = "geom_curve" + ) - trans <- coord$transform(data, panel_params) + trans <- coord$transform(data, panel_params) - arrow.fill <- arrow.fill %||% trans$colour + arrow.fill <- arrow.fill %||% trans$colour - curveGrob( - trans$x, trans$y, trans$xend, trans$yend, - default.units = "native", - curvature = curvature, angle = angle, ncp = ncp, - square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE, - gp = gg_par( - col = alpha(trans$colour, trans$alpha), - fill = alpha(arrow.fill, trans$alpha), - lwd = trans$linewidth, - lty = trans$linetype, - lineend = lineend), - arrow = arrow - ) - } + curveGrob( + trans$x, trans$y, trans$xend, trans$yend, + default.units = "native", + curvature = curvature, angle = angle, ncp = ncp, + square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE, + gp = gg_par( + col = alpha(trans$colour, trans$alpha), + fill = alpha(arrow.fill, trans$alpha), + lwd = trans$linewidth, + lty = trans$linetype, + lineend = lineend), + arrow = arrow + ) + } +) + +#' @inheritParams grid::curveGrob +#' @export +#' @rdname geom_segment +geom_curve <- boilerplate( + GeomCurve, + curvature = 0.5, angle = 90, ncp = 5, + arrow = NULL, arrow.fill = NULL, + lineend = "butt" ) diff --git a/R/geom-density.R b/R/geom-density.R index a4a7754f2e..e94c5157ce 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -1,3 +1,16 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-ribbon.R +GeomDensity <- ggproto( + "GeomDensity", GeomArea, + default_aes = defaults( + aes(fill = NA, weight = 1, colour = from_theme(ink), alpha = NA), + GeomArea$default_aes + ) +) + #' Smoothed density estimates #' #' Computes and draws kernel density estimate, which is a smoothed version of @@ -86,14 +99,4 @@ geom_density <- function(mapping = NULL, data = NULL, ) } -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-ribbon.R -GeomDensity <- ggproto("GeomDensity", GeomArea, - default_aes = defaults( - aes(fill = NA, weight = 1, colour = from_theme(ink), alpha = NA), - GeomArea$default_aes - ) -) + diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index 3e40b20318..05deae5886 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -1,28 +1,3 @@ -#' @export -#' @rdname geom_linerange -geom_errorbar <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomErrorbar, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -80,3 +55,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, rename_size = TRUE ) + +#' @export +#' @rdname geom_linerange +geom_errorbar <- boilerplate(GeomErrorbar, orientation = NA) diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R index c38b9b7cd6..013bcf0b19 100644 --- a/R/geom-errorbarh.R +++ b/R/geom-errorbarh.R @@ -1,51 +1,3 @@ -#' Horizontal error bars -#' -#' A rotated version of [geom_errorbar()]. -#' -#' @eval rd_aesthetics("geom", "errorbarh") -#' @inheritParams layer -#' @inheritParams geom_point -#' @export -#' @examples -#' df <- data.frame( -#' trt = factor(c(1, 1, 2, 2)), -#' resp = c(1, 5, 3, 4), -#' group = factor(c(1, 2, 1, 2)), -#' se = c(0.1, 0.3, 0.3, 0.2) -#' ) -#' -#' # Define the top and bottom of the errorbars -#' -#' p <- ggplot(df, aes(resp, trt, colour = group)) -#' p + -#' geom_point() + -#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se)) -#' -#' p + -#' geom_point() + -#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) -geom_errorbarh <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomErrorbarh, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -89,3 +41,31 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, rename_size = TRUE ) + +#' Horizontal error bars +#' +#' A rotated version of [geom_errorbar()]. +#' +#' @eval rd_aesthetics("geom", "errorbarh") +#' @inheritParams layer +#' @inheritParams geom_point +#' @export +#' @examples +#' df <- data.frame( +#' trt = factor(c(1, 1, 2, 2)), +#' resp = c(1, 5, 3, 4), +#' group = factor(c(1, 2, 1, 2)), +#' se = c(0.1, 0.3, 0.3, 0.2) +#' ) +#' +#' # Define the top and bottom of the errorbars +#' +#' p <- ggplot(df, aes(resp, trt, colour = group)) +#' p + +#' geom_point() + +#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se)) +#' +#' p + +#' geom_point() + +#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) +geom_errorbarh <- boilerplate(GeomErrorbarh) diff --git a/R/geom-hex.R b/R/geom-hex.R index 152227a40b..96d5433561 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -1,56 +1,3 @@ -#' Hexagonal heatmap of 2d bin counts -#' -#' Divides the plane into regular hexagons, counts the number of cases in -#' each hexagon, and then (by default) maps the number of cases to the hexagon -#' fill. Hexagon bins avoid the visual artefacts sometimes generated by -#' the very regular alignment of [geom_bin_2d()]. -#' -#' @eval rd_aesthetics("geom", "hex") -#' @eval rd_aesthetics("stat", "binhex") -#' @seealso [stat_bin_2d()] for rectangular binning -#' @param geom,stat Override the default connection between `geom_hex()` and -#' `stat_bin_hex()`. For more information about overriding these connections, -#' see how the [stat][layer_stats] and [geom][layer_geoms] arguments work. -#' @export -#' @inheritParams layer -#' @inheritParams geom_point -#' @export -#' @examples -#' d <- ggplot(diamonds, aes(carat, price)) -#' d + geom_hex() -#' -#' \donttest{ -#' # You can control the size of the bins by specifying the number of -#' # bins in each direction: -#' d + geom_hex(bins = 10) -#' d + geom_hex(bins = 30) -#' -#' # Or by specifying the width of the bins -#' d + geom_hex(binwidth = c(1, 1000)) -#' d + geom_hex(binwidth = c(.1, 500)) -#' } -geom_hex <- function(mapping = NULL, data = NULL, - stat = "binhex", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomHex, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -118,3 +65,36 @@ GeomHex <- ggproto("GeomHex", Geom, rename_size = TRUE ) + +#' Hexagonal heatmap of 2d bin counts +#' +#' Divides the plane into regular hexagons, counts the number of cases in +#' each hexagon, and then (by default) maps the number of cases to the hexagon +#' fill. Hexagon bins avoid the visual artefacts sometimes generated by +#' the very regular alignment of [geom_bin_2d()]. +#' +#' @eval rd_aesthetics("geom", "hex") +#' @eval rd_aesthetics("stat", "binhex") +#' @seealso [stat_bin_2d()] for rectangular binning +#' @param geom,stat Override the default connection between `geom_hex()` and +#' `stat_bin_hex()`. For more information about overriding these connections, +#' see how the [stat][layer_stats] and [geom][layer_geoms] arguments work. +#' @export +#' @inheritParams layer +#' @inheritParams geom_point +#' @export +#' @examples +#' d <- ggplot(diamonds, aes(carat, price)) +#' d + geom_hex() +#' +#' \donttest{ +#' # You can control the size of the bins by specifying the number of +#' # bins in each direction: +#' d + geom_hex(bins = 10) +#' d + geom_hex(bins = 30) +#' +#' # Or by specifying the width of the bins +#' d + geom_hex(binwidth = c(1, 1000)) +#' d + geom_hex(binwidth = c(.1, 500)) +#' } +geom_hex <- boilerplate(GeomHex, stat = 'binhex') diff --git a/R/geom-histogram.R b/R/geom-histogram.R index dafc181f15..8fcd572548 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -115,31 +115,7 @@ #' ggplot(economics_long, aes(value)) + #' facet_wrap(~variable, scales = 'free_x') + #' geom_histogram(binwidth = function(x) 2 * IQR(x) / (length(x)^(1/3))) -geom_histogram <- function(mapping = NULL, data = NULL, - stat = "bin", position = "stack", - ..., - binwidth = NULL, - bins = NULL, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomBar, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - binwidth = binwidth, - bins = bins, - na.rm = na.rm, - orientation = orientation, - pad = FALSE, - ... - ) - ) -} +geom_histogram <- boilerplate( + GeomBar, stat = "bin", position = "stack", + binwidth = NULL, bins = NULL, orientation = NA +) diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 83360800e2..de61ac2456 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -1,3 +1,47 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomLinerange <- ggproto( + "GeomLinerange", Geom, + + default_aes = aes( + colour = from_theme(ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), + + draw_key = draw_key_linerange, + + 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 flipped_aes == TRUE then y, xmin, xmax is present + if (!(params$flipped_aes || all(c("x", "ymin", "ymax") %in% c(names(data), names(params))))) { + cli::cli_abort("Either, {.field x}, {.field ymin}, and {.field ymax} {.emph or} {.field y}, {.field xmin}, and {.field xmax} must be supplied.") + } + 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, lineend = "butt", flipped_aes = FALSE, na.rm = 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, lineend = lineend, na.rm = na.rm)) + }, + + rename_size = TRUE +) + #' Vertical intervals: lines, crossbars & errorbars #' #' Various ways of representing a vertical interval defined by `x`, @@ -63,68 +107,4 @@ #' aes(ymin = lower, ymax = upper), #' position = position_dodge2(width = 0.5, padding = 0.5) #' ) -geom_linerange <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomLinerange, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -GeomLinerange <- ggproto("GeomLinerange", Geom, - - default_aes = aes( - colour = from_theme(ink), - linewidth = from_theme(linewidth), - linetype = from_theme(linetype), - alpha = NA - ), - - draw_key = draw_key_linerange, - - 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 flipped_aes == TRUE then y, xmin, xmax is present - if (!(params$flipped_aes || all(c("x", "ymin", "ymax") %in% c(names(data), names(params))))) { - cli::cli_abort("Either, {.field x}, {.field ymin}, and {.field ymax} {.emph or} {.field y}, {.field xmin}, and {.field xmax} must be supplied.") - } - 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, lineend = "butt", flipped_aes = FALSE, na.rm = 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, lineend = lineend, na.rm = na.rm)) - }, - - rename_size = TRUE -) +geom_linerange <- boilerplate(GeomLinerange, orientation = NA) diff --git a/R/geom-path.R b/R/geom-path.R index 72c4f7154e..d012283419 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -1,133 +1,3 @@ -#' Connect observations -#' -#' `geom_path()` connects the observations in the order in which they appear -#' in the data. `geom_line()` connects them in order of the variable on the -#' x axis. `geom_step()` creates a stairstep plot, highlighting exactly -#' when changes occur. The `group` aesthetic determines which cases are -#' connected together. -#' -#' 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_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). -#' @param arrow Arrow specification, as created by [grid::arrow()]. -#' @param arrow.fill fill colour to use for the arrow head (if closed). `NULL` -#' means use `colour` aesthetic. -#' @seealso -#' [geom_polygon()]: Filled paths (polygons); -#' [geom_segment()]: Line segments -#' @section Missing value handling: -#' `geom_path()`, `geom_line()`, and `geom_step()` handle `NA` as follows: -#' -#' * If an `NA` occurs in the middle of a line, it breaks the line. No warning -#' is shown, regardless of whether `na.rm` is `TRUE` or `FALSE`. -#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `FALSE` -#' (default), the `NA` is removed with a warning. -#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `TRUE`, -#' the `NA` is removed silently, without warning. -#' @export -#' @examples -#' # geom_line() is suitable for time series -#' ggplot(economics, aes(date, unemploy)) + geom_line() -#' # separate by colour and use "timeseries" legend key glyph -#' ggplot(economics_long, aes(date, value01, colour = variable)) + -#' geom_line(key_glyph = "timeseries") -#' -#' # 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"), ] -#' ggplot(recent, aes(date, unemploy)) + geom_line() -#' ggplot(recent, aes(date, unemploy)) + geom_step() -#' -#' # geom_path lets you explore how two variables are related over time, -#' # e.g. unemployment and personal savings rate -#' m <- ggplot(economics, aes(unemploy/pop, psavert)) -#' m + geom_path() -#' m + geom_path(aes(colour = as.numeric(date))) -#' -#' # Changing parameters ---------------------------------------------- -#' ggplot(economics, aes(date, unemploy)) + -#' geom_line(colour = "red") -#' -#' # Use the arrow parameter to add an arrow to the line -#' # See ?arrow for more details -#' c <- ggplot(economics, aes(x = date, y = pop)) -#' c + geom_line(arrow = arrow()) -#' c + geom_line( -#' arrow = arrow(angle = 15, ends = "both", type = "closed") -#' ) -#' -#' # Control line join parameters -#' df <- data.frame(x = 1:3, y = c(4, 1, 9)) -#' base <- ggplot(df, aes(x, y)) -#' base + geom_path(linewidth = 10) -#' base + geom_path(linewidth = 10, lineend = "round") -#' base + geom_path(linewidth = 10, linejoin = "mitre", lineend = "butt") -#' -#' # You can use NAs to break the line. -#' df <- data.frame(x = 1:5, y = c(1, 2, NA, 4, 5)) -#' ggplot(df, aes(x, y)) + geom_point() + geom_line() -#' -#' \donttest{ -#' # Setting line type vs colour/size -#' # Line type needs to be applied to a line as a whole, so it can -#' # not be used with colour or size that vary across a line -#' x <- seq(0.01, .99, length.out = 100) -#' df <- data.frame( -#' x = rep(x, 2), -#' y = c(qlogis(x), 2 * qlogis(x)), -#' group = rep(c("a","b"), -#' each = 100) -#' ) -#' p <- ggplot(df, aes(x=x, y=y, group=group)) -#' # These work -#' p + geom_line(linetype = 2) -#' p + geom_line(aes(colour = group), linetype = 2) -#' p + geom_line(aes(colour = x)) -#' # But this doesn't -#' should_stop(p + geom_line(aes(colour = x), linetype=2)) -#' } -geom_path <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - lineend = "butt", - linejoin = "round", - linemitre = 10, - arrow = NULL, - arrow.fill = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomPath, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre, - arrow = arrow, - arrow.fill = arrow.fill, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -245,50 +115,13 @@ GeomPath <- ggproto("GeomPath", Geom, rename_size = TRUE ) -# Trim false values from left and right: keep all values from -# first TRUE to last TRUE -keep_mid_true <- function(x) { - first <- match(TRUE, x) - 1 - if (is.na(first)) { - return(rep(FALSE, length(x))) - } - - last <- length(x) - match(TRUE, rev(x)) + 1 - c( - rep(FALSE, first), - rep(TRUE, last - first), - rep(FALSE, length(x) - last) - ) -} - - -#' @export -#' @rdname geom_path -geom_line <- function(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, orientation = NA, - show.legend = NA, inherit.aes = TRUE, ...) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomLine, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export #' @include geom-path.R -GeomLine <- ggproto("GeomLine", GeomPath, +GeomLine <- ggproto( + "GeomLine", GeomPath, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) params @@ -304,38 +137,13 @@ GeomLine <- ggproto("GeomLine", GeomPath, } ) -#' @param direction direction of stairs: 'vh' for vertical then horizontal, -#' 'hv' for horizontal then vertical, or 'mid' for step half-way between -#' adjacent x-values. -#' @export -#' @rdname geom_path -geom_step <- function(mapping = NULL, data = NULL, stat = "identity", - position = "identity", direction = "hv", - na.rm = FALSE, orientation = NA, show.legend = NA, - inherit.aes = TRUE, ...) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomStep, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - direction = direction, - orientation = orientation, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export #' @include geom-path.R -GeomStep <- ggproto("GeomStep", GeomPath, +GeomStep <- ggproto( + "GeomStep", GeomPath, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) params @@ -359,6 +167,138 @@ GeomStep <- ggproto("GeomStep", GeomPath, } ) +#' Connect observations +#' +#' `geom_path()` connects the observations in the order in which they appear +#' in the data. `geom_line()` connects them in order of the variable on the +#' x axis. `geom_step()` creates a stairstep plot, highlighting exactly +#' when changes occur. The `group` aesthetic determines which cases are +#' connected together. +#' +#' 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_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). +#' @param arrow Arrow specification, as created by [grid::arrow()]. +#' @param arrow.fill fill colour to use for the arrow head (if closed). `NULL` +#' means use `colour` aesthetic. +#' @seealso +#' [geom_polygon()]: Filled paths (polygons); +#' [geom_segment()]: Line segments +#' @section Missing value handling: +#' `geom_path()`, `geom_line()`, and `geom_step()` handle `NA` as follows: +#' +#' * If an `NA` occurs in the middle of a line, it breaks the line. No warning +#' is shown, regardless of whether `na.rm` is `TRUE` or `FALSE`. +#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `FALSE` +#' (default), the `NA` is removed with a warning. +#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `TRUE`, +#' the `NA` is removed silently, without warning. +#' @export +#' @examples +#' # geom_line() is suitable for time series +#' ggplot(economics, aes(date, unemploy)) + geom_line() +#' # separate by colour and use "timeseries" legend key glyph +#' ggplot(economics_long, aes(date, value01, colour = variable)) + +#' geom_line(key_glyph = "timeseries") +#' +#' # 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"), ] +#' ggplot(recent, aes(date, unemploy)) + geom_line() +#' ggplot(recent, aes(date, unemploy)) + geom_step() +#' +#' # geom_path lets you explore how two variables are related over time, +#' # e.g. unemployment and personal savings rate +#' m <- ggplot(economics, aes(unemploy/pop, psavert)) +#' m + geom_path() +#' m + geom_path(aes(colour = as.numeric(date))) +#' +#' # Changing parameters ---------------------------------------------- +#' ggplot(economics, aes(date, unemploy)) + +#' geom_line(colour = "red") +#' +#' # Use the arrow parameter to add an arrow to the line +#' # See ?arrow for more details +#' c <- ggplot(economics, aes(x = date, y = pop)) +#' c + geom_line(arrow = arrow()) +#' c + geom_line( +#' arrow = arrow(angle = 15, ends = "both", type = "closed") +#' ) +#' +#' # Control line join parameters +#' df <- data.frame(x = 1:3, y = c(4, 1, 9)) +#' base <- ggplot(df, aes(x, y)) +#' base + geom_path(linewidth = 10) +#' base + geom_path(linewidth = 10, lineend = "round") +#' base + geom_path(linewidth = 10, linejoin = "mitre", lineend = "butt") +#' +#' # You can use NAs to break the line. +#' df <- data.frame(x = 1:5, y = c(1, 2, NA, 4, 5)) +#' ggplot(df, aes(x, y)) + geom_point() + geom_line() +#' +#' \donttest{ +#' # Setting line type vs colour/size +#' # Line type needs to be applied to a line as a whole, so it can +#' # not be used with colour or size that vary across a line +#' x <- seq(0.01, .99, length.out = 100) +#' df <- data.frame( +#' x = rep(x, 2), +#' y = c(qlogis(x), 2 * qlogis(x)), +#' group = rep(c("a","b"), +#' each = 100) +#' ) +#' p <- ggplot(df, aes(x=x, y=y, group=group)) +#' # These work +#' p + geom_line(linetype = 2) +#' p + geom_line(aes(colour = group), linetype = 2) +#' p + geom_line(aes(colour = x)) +#' # But this doesn't +#' should_stop(p + geom_line(aes(colour = x), linetype=2)) +#' } +geom_path <- boilerplate( + GeomPath, + lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, arrow.fill = NULL +) + +#' @export +#' @rdname geom_path +geom_line <- boilerplate(GeomLine, orientation = NA) + +#' @param direction direction of stairs: 'vh' for vertical then horizontal, +#' 'hv' for horizontal then vertical, or 'mid' for step half-way between +#' adjacent x-values. +#' @export +#' @rdname geom_path +geom_step <- boilerplate(GeomStep, direction = "hv", orientation = NA) + +# Trim false values from left and right: keep all values from +# first TRUE to last TRUE +keep_mid_true <- function(x) { + first <- match(TRUE, x) - 1 + if (is.na(first)) { + return(rep(FALSE, length(x))) + } + + last <- length(x) - match(TRUE, rev(x)) + 1 + c( + rep(FALSE, first), + rep(TRUE, last - first), + rep(FALSE, length(x) - last) + ) +} + #' Calculate stairsteps for `geom_step()` #' Used by `GeomStep()` #' diff --git a/R/geom-point.R b/R/geom-point.R index 3efa394c31..d63bd0fede 100644 --- a/R/geom-point.R +++ b/R/geom-point.R @@ -1,3 +1,39 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomPoint <- ggproto("GeomPoint", Geom, + required_aes = c("x", "y"), + non_missing_aes = c("size", "shape", "colour"), + default_aes = aes( + shape = from_theme(pointshape), + colour = from_theme(ink), size = from_theme(pointsize), fill = NA, + alpha = NA, stroke = from_theme(borderwidth) + ), + + draw_panel = function(self, data, panel_params, coord, na.rm = FALSE) { + if (is.character(data$shape)) { + data$shape <- translate_shape_string(data$shape) + } + + coords <- coord$transform(data, panel_params) + ggname("geom_point", + pointsGrob( + coords$x, coords$y, + pch = coords$shape, + gp = gg_par( + col = alpha(coords$colour, coords$alpha), + fill = fill_alpha(coords$fill, coords$alpha), + pointsize = coords$size, + stroke = coords$stroke + ) + ) + ) + }, + + draw_key = draw_key_point +) + #' Points #' #' The point geom is used to create scatterplots. The scatterplot is most @@ -106,62 +142,7 @@ #' ggplot(mtcars2, aes(wt, mpg)) + #' geom_point(na.rm = TRUE) #' } -geom_point <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomPoint, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -GeomPoint <- ggproto("GeomPoint", Geom, - required_aes = c("x", "y"), - non_missing_aes = c("size", "shape", "colour"), - default_aes = aes( - shape = from_theme(pointshape), - colour = from_theme(ink), size = from_theme(pointsize), fill = NA, - alpha = NA, stroke = from_theme(borderwidth) - ), - - draw_panel = function(self, data, panel_params, coord, na.rm = FALSE) { - if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } - - coords <- coord$transform(data, panel_params) - ggname("geom_point", - pointsGrob( - coords$x, coords$y, - pch = coords$shape, - gp = gg_par( - col = alpha(coords$colour, coords$alpha), - fill = fill_alpha(coords$fill, coords$alpha), - pointsize = coords$size, - stroke = coords$stroke - ) - ) - ) - }, - - draw_key = draw_key_point -) +geom_point <- boilerplate(GeomPoint) #' Translating shape strings #' diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index d0e5194311..4c709be77c 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -1,30 +1,3 @@ -#' @export -#' @rdname geom_linerange -geom_pointrange <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - fatten = 4, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomPointrange, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - fatten = fatten, - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -71,3 +44,7 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, ) } ) + +#' @export +#' @rdname geom_linerange +geom_pointrange <- boilerplate(GeomPointrange, fatten = 4, orientation = NA) diff --git a/R/geom-polygon.R b/R/geom-polygon.R index a271ef5011..b9c6836cb0 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -1,106 +1,5 @@ -#' Polygons -#' -#' Polygons are very similar to paths (as drawn by [geom_path()]) -#' except that the start and end points are connected and the inside is -#' coloured by `fill`. The `group` aesthetic determines which cases -#' are connected together into a polygon. From R 3.6 and onwards it is possible -#' to draw polygons with holes by providing a subgroup aesthetic that -#' differentiates the outer ring points from those describing holes in the -#' polygon. -#' -#' @eval rd_aesthetics("geom", "polygon") -#' @seealso -#' [geom_path()] for an unfilled polygon, -#' [geom_ribbon()] for a polygon anchored on the x-axis -#' @export -#' @inheritParams layer -#' @inheritParams geom_point -#' @param rule Either `"evenodd"` or `"winding"`. If polygons with holes are -#' being drawn (using the `subgroup` aesthetic) this argument defines how the -#' hole coordinates are interpreted. See the examples in [grid::pathGrob()] for -#' an explanation. -#' @examples -#' # When using geom_polygon, you will typically need two data frames: -#' # one contains the coordinates of each polygon (positions), and the -#' # other the values associated with each polygon (values). An id -#' # variable links the two together -#' -#' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3")) -#' -#' values <- data.frame( -#' id = ids, -#' value = c(3, 3.1, 3.1, 3.2, 3.15, 3.5) -#' ) -#' -#' positions <- data.frame( -#' id = rep(ids, each = 4), -#' x = c(2, 1, 1.1, 2.2, 1, 0, 0.3, 1.1, 2.2, 1.1, 1.2, 2.5, 1.1, 0.3, -#' 0.5, 1.2, 2.5, 1.2, 1.3, 2.7, 1.2, 0.5, 0.6, 1.3), -#' y = c(-0.5, 0, 1, 0.5, 0, 0.5, 1.5, 1, 0.5, 1, 2.1, 1.7, 1, 1.5, -#' 2.2, 2.1, 1.7, 2.1, 3.2, 2.8, 2.1, 2.2, 3.3, 3.2) -#' ) -#' -#' # Currently we need to manually merge the two together -#' datapoly <- merge(values, positions, by = c("id")) -#' -#' p <- ggplot(datapoly, aes(x = x, y = y)) + -#' geom_polygon(aes(fill = value, group = id)) -#' p -#' -#' # Which seems like a lot of work, but then it's easy to add on -#' # other features in this coordinate system, e.g.: -#' -#' set.seed(1) -#' stream <- data.frame( -#' x = cumsum(runif(50, max = 0.1)), -#' y = cumsum(runif(50,max = 0.1)) -#' ) -#' -#' p + geom_line(data = stream, colour = "grey30", linewidth = 5) -#' -#' # And if the positions are in longitude and latitude, you can use -#' # coord_map to produce different map projections. -#' -#' if (packageVersion("grid") >= "3.6") { -#' # As of R version 3.6 geom_polygon() supports polygons with holes -#' # Use the subgroup aesthetic to differentiate holes from the main polygon -#' -#' holes <- do.call(rbind, lapply(split(datapoly, datapoly$id), function(df) { -#' df$x <- df$x + 0.5 * (mean(df$x) - df$x) -#' df$y <- df$y + 0.5 * (mean(df$y) - df$y) -#' df -#' })) -#' datapoly$subid <- 1L -#' holes$subid <- 2L -#' datapoly <- rbind(datapoly, holes) -#' -#' p <- ggplot(datapoly, aes(x = x, y = y)) + -#' geom_polygon(aes(fill = value, group = id, subgroup = subid)) -#' p -#' } -#' -geom_polygon <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - rule = "evenodd", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomPolygon, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - rule = rule, - ... - ) - ) -} +#' @include boilerplates.R +NULL #' @rdname ggplot2-ggproto #' @format NULL @@ -194,6 +93,88 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, rename_size = TRUE ) +#' Polygons +#' +#' Polygons are very similar to paths (as drawn by [geom_path()]) +#' except that the start and end points are connected and the inside is +#' coloured by `fill`. The `group` aesthetic determines which cases +#' are connected together into a polygon. From R 3.6 and onwards it is possible +#' to draw polygons with holes by providing a subgroup aesthetic that +#' differentiates the outer ring points from those describing holes in the +#' polygon. +#' +#' @eval rd_aesthetics("geom", "polygon") +#' @seealso +#' [geom_path()] for an unfilled polygon, +#' [geom_ribbon()] for a polygon anchored on the x-axis +#' @export +#' @inheritParams layer +#' @inheritParams geom_point +#' @param rule Either `"evenodd"` or `"winding"`. If polygons with holes are +#' being drawn (using the `subgroup` aesthetic) this argument defines how the +#' hole coordinates are interpreted. See the examples in [grid::pathGrob()] for +#' an explanation. +#' @examples +#' # When using geom_polygon, you will typically need two data frames: +#' # one contains the coordinates of each polygon (positions), and the +#' # other the values associated with each polygon (values). An id +#' # variable links the two together +#' +#' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3")) +#' +#' values <- data.frame( +#' id = ids, +#' value = c(3, 3.1, 3.1, 3.2, 3.15, 3.5) +#' ) +#' +#' positions <- data.frame( +#' id = rep(ids, each = 4), +#' x = c(2, 1, 1.1, 2.2, 1, 0, 0.3, 1.1, 2.2, 1.1, 1.2, 2.5, 1.1, 0.3, +#' 0.5, 1.2, 2.5, 1.2, 1.3, 2.7, 1.2, 0.5, 0.6, 1.3), +#' y = c(-0.5, 0, 1, 0.5, 0, 0.5, 1.5, 1, 0.5, 1, 2.1, 1.7, 1, 1.5, +#' 2.2, 2.1, 1.7, 2.1, 3.2, 2.8, 2.1, 2.2, 3.3, 3.2) +#' ) +#' +#' # Currently we need to manually merge the two together +#' datapoly <- merge(values, positions, by = c("id")) +#' +#' p <- ggplot(datapoly, aes(x = x, y = y)) + +#' geom_polygon(aes(fill = value, group = id)) +#' p +#' +#' # Which seems like a lot of work, but then it's easy to add on +#' # other features in this coordinate system, e.g.: +#' +#' set.seed(1) +#' stream <- data.frame( +#' x = cumsum(runif(50, max = 0.1)), +#' y = cumsum(runif(50,max = 0.1)) +#' ) +#' +#' p + geom_line(data = stream, colour = "grey30", linewidth = 5) +#' +#' # And if the positions are in longitude and latitude, you can use +#' # coord_map to produce different map projections. +#' +#' if (packageVersion("grid") >= "3.6") { +#' # As of R version 3.6 geom_polygon() supports polygons with holes +#' # Use the subgroup aesthetic to differentiate holes from the main polygon +#' +#' holes <- do.call(rbind, lapply(split(datapoly, datapoly$id), function(df) { +#' df$x <- df$x + 0.5 * (mean(df$x) - df$x) +#' df$y <- df$y + 0.5 * (mean(df$y) - df$y) +#' df +#' })) +#' datapoly$subid <- 1L +#' holes$subid <- 2L +#' datapoly <- rbind(datapoly, holes) +#' +#' p <- ggplot(datapoly, aes(x = x, y = y)) + +#' geom_polygon(aes(fill = value, group = id, subgroup = subid)) +#' p +#' } +geom_polygon <- boilerplate(GeomPolygon, rule = "evenodd") + # Assigning pathGrob in .onLoad ensures that packages that subclass GeomPolygon # do not install with error `possible error in 'pathGrob(munched$x, munched$y, ': # unused argument (pathId = munched$group)` despite the fact that this is correct diff --git a/R/geom-quantile.R b/R/geom-quantile.R index 732ab62f8a..9a3a64fa20 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -1,3 +1,16 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-path.R +GeomQuantile <- ggproto( + "GeomQuantile", GeomPath, + default_aes = defaults( + aes(weight = 1, colour = from_theme(accent)), + GeomPath$default_aes + ) +) + #' Quantile regression #' #' This fits a quantile regression to the data and draws the fitted quantiles @@ -31,42 +44,7 @@ #' #' # Set aesthetics to fixed value #' m + geom_quantile(colour = "red", linewidth = 2, alpha = 0.5) -geom_quantile <- function(mapping = NULL, data = NULL, - stat = "quantile", position = "identity", - ..., - lineend = "butt", - linejoin = "round", - linemitre = 10, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomQuantile, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-path.R -GeomQuantile <- ggproto("GeomQuantile", GeomPath, - default_aes = defaults( - aes(weight = 1, colour = from_theme(accent)), - GeomPath$default_aes - ) +geom_quantile <- boilerplate( + GeomQuantile, stat = "quantile", + lineend = "butt", linejoin = "round", linemitre = 10 ) diff --git a/R/geom-rect.R b/R/geom-rect.R index 8473474525..60f23a584c 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -1,28 +1,3 @@ -#' @export -#' @rdname geom_tile -geom_rect <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - linejoin = "mitre", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomRect, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - linejoin = linejoin, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -109,6 +84,10 @@ GeomRect <- ggproto("GeomRect", Geom, rename_size = TRUE ) +#' @export +#' @rdname geom_tile +geom_rect <- boilerplate(GeomRect, linejoin = "mitre") + resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL, fun, type) { absent <- c(is.null(min), is.null(max), is.null(center), is.null(length)) diff --git a/R/geom-rug.R b/R/geom-rug.R index d675474f43..f157922b40 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -1,86 +1,3 @@ -#' Rug plots in the margins -#' -#' A rug plot is a compact visualisation designed to supplement a 2d display -#' with the two 1d marginal distributions. Rug plots display individual -#' cases so are best used with smaller datasets. -#' -#' By default, the rug lines are drawn with a length that corresponds to 3% -#' of the total plot size. Since the default scale expansion of for continuous -#' variables is 5% at both ends of the scale, the rug will not overlap with -#' any data points under the default settings. -#' -#' @eval rd_aesthetics("geom", "rug") -#' @inheritParams layer -#' @inheritParams geom_point -#' @param sides A string that controls which sides of the plot the rugs appear on. -#' It can be set to a string containing any of `"trbl"`, for top, right, -#' bottom, and left. -#' @param outside logical that controls whether to move the rug tassels outside of the plot area. Default is off (FALSE). You will also need to use `coord_cartesian(clip = "off")`. When set to TRUE, also consider changing the sides argument to "tr". See examples. -#' @param length A [grid::unit()] object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data. -#' @export -#' @examples -#' p <- ggplot(mtcars, aes(wt, mpg)) + -#' geom_point() -#' p -#' p + geom_rug() -#' p + geom_rug(sides="b") # Rug on bottom only -#' p + geom_rug(sides="trbl") # All four sides -#' -#' # Use jittering to avoid overplotting for smaller datasets -#' ggplot(mpg, aes(displ, cty)) + -#' geom_point() + -#' geom_rug() -#' -#' ggplot(mpg, aes(displ, cty)) + -#' geom_jitter() + -#' geom_rug(alpha = 1/2, position = "jitter") -#' -#' # move the rug tassels to outside the plot -#' # remember to set clip = "off". -#' p + -#' geom_rug(outside = TRUE) + -#' coord_cartesian(clip = "off") -#' -#' # set sides to top right, and then move the margins -#' p + -#' geom_rug(outside = TRUE, sides = "tr") + -#' coord_cartesian(clip = "off") + -#' theme(plot.margin = margin(1, 1, 1, 1, "cm")) -#' -#' # increase the line length and -#' # expand axis to avoid overplotting -#' p + -#' geom_rug(length = unit(0.05, "npc")) + -#' scale_y_continuous(expand = c(0.1, 0.1)) -#' -geom_rug <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - outside = FALSE, - sides = "bl", - length = unit(0.03, "npc"), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomRug, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - outside = outside, - sides = sides, - length = length, - na.rm = na.rm, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -208,3 +125,62 @@ GeomRug <- ggproto("GeomRug", Geom, data } ) + +#' Rug plots in the margins +#' +#' A rug plot is a compact visualisation designed to supplement a 2d display +#' with the two 1d marginal distributions. Rug plots display individual +#' cases so are best used with smaller datasets. +#' +#' By default, the rug lines are drawn with a length that corresponds to 3% +#' of the total plot size. Since the default scale expansion of for continuous +#' variables is 5% at both ends of the scale, the rug will not overlap with +#' any data points under the default settings. +#' +#' @eval rd_aesthetics("geom", "rug") +#' @inheritParams layer +#' @inheritParams geom_point +#' @param sides A string that controls which sides of the plot the rugs appear on. +#' It can be set to a string containing any of `"trbl"`, for top, right, +#' bottom, and left. +#' @param outside logical that controls whether to move the rug tassels outside of the plot area. Default is off (FALSE). You will also need to use `coord_cartesian(clip = "off")`. When set to TRUE, also consider changing the sides argument to "tr". See examples. +#' @param length A [grid::unit()] object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data. +#' @export +#' @examples +#' p <- ggplot(mtcars, aes(wt, mpg)) + +#' geom_point() +#' p +#' p + geom_rug() +#' p + geom_rug(sides="b") # Rug on bottom only +#' p + geom_rug(sides="trbl") # All four sides +#' +#' # Use jittering to avoid overplotting for smaller datasets +#' ggplot(mpg, aes(displ, cty)) + +#' geom_point() + +#' geom_rug() +#' +#' ggplot(mpg, aes(displ, cty)) + +#' geom_jitter() + +#' geom_rug(alpha = 1/2, position = "jitter") +#' +#' # move the rug tassels to outside the plot +#' # remember to set clip = "off". +#' p + +#' geom_rug(outside = TRUE) + +#' coord_cartesian(clip = "off") +#' +#' # set sides to top right, and then move the margins +#' p + +#' geom_rug(outside = TRUE, sides = "tr") + +#' coord_cartesian(clip = "off") + +#' theme(plot.margin = margin(1, 1, 1, 1, "cm")) +#' +#' # increase the line length and +#' # expand axis to avoid overplotting +#' p + +#' geom_rug(length = unit(0.05, "npc")) + +#' scale_y_continuous(expand = c(0.1, 0.1)) +geom_rug <- boilerplate( + GeomRug, + outside = FALSE, sides = "bl", length = unit(0.03, "npc") +) diff --git a/R/geom-segment.R b/R/geom-segment.R index 00d9eff87a..8884c68a39 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -1,3 +1,63 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomSegment <- ggproto("GeomSegment", Geom, + required_aes = c("x", "y", "xend|yend"), + non_missing_aes = c("linetype", "linewidth"), + + default_aes = aes( + colour = from_theme(ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), + + draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, + lineend = "butt", linejoin = "round", na.rm = FALSE) { + data$xend <- data$xend %||% data$x + data$yend <- data$yend %||% data$y + data <- check_linewidth(data, snake_class(self)) + data <- remove_missing(data, na.rm = na.rm, + c("x", "y", "xend", "yend", "linetype", "linewidth"), + name = "geom_segment" + ) + + if (empty(data)) return(zeroGrob()) + + if (coord$is_linear()) { + coord <- coord$transform(data, panel_params) + arrow.fill <- arrow.fill %||% coord$colour + return(segmentsGrob(coord$x, coord$y, coord$xend, coord$yend, + default.units = "native", + gp = gg_par( + col = alpha(coord$colour, coord$alpha), + fill = alpha(arrow.fill, coord$alpha), + lwd = coord$linewidth, + lty = coord$linetype, + lineend = lineend, + linejoin = linejoin + ), + arrow = arrow + )) + } + + data$group <- seq_len(nrow(data)) + starts <- subset(data, select = c(-xend, -yend)) + ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y")) + + pieces <- vec_rbind0(starts, ends) + pieces <- pieces[order(pieces$group),] + + GeomPath$draw_panel(pieces, panel_params, coord, arrow = arrow, + lineend = lineend) + }, + + draw_key = draw_key_path, + + rename_size = TRUE +) + #' Line segments and curves #' #' `geom_segment()` draws a straight line between points (x, y) and @@ -68,91 +128,8 @@ #' #' ggplot(counts, aes(x, Freq)) + #' geom_segment(aes(xend = x, yend = 0), linewidth = 10, lineend = "butt") -geom_segment <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - arrow = NULL, - arrow.fill = NULL, - lineend = "butt", - linejoin = "round", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomSegment, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - arrow = arrow, - arrow.fill = arrow.fill, - lineend = lineend, - linejoin = linejoin, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -GeomSegment <- ggproto("GeomSegment", Geom, - required_aes = c("x", "y", "xend|yend"), - non_missing_aes = c("linetype", "linewidth"), - - default_aes = aes( - colour = from_theme(ink), - linewidth = from_theme(linewidth), - linetype = from_theme(linetype), - alpha = NA - ), - - draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", na.rm = FALSE) { - data$xend <- data$xend %||% data$x - data$yend <- data$yend %||% data$y - data <- check_linewidth(data, snake_class(self)) - data <- remove_missing(data, na.rm = na.rm, - c("x", "y", "xend", "yend", "linetype", "linewidth"), - name = "geom_segment" - ) - - if (empty(data)) return(zeroGrob()) - - if (coord$is_linear()) { - coord <- coord$transform(data, panel_params) - arrow.fill <- arrow.fill %||% coord$colour - return(segmentsGrob(coord$x, coord$y, coord$xend, coord$yend, - default.units = "native", - gp = gg_par( - col = alpha(coord$colour, coord$alpha), - fill = alpha(arrow.fill, coord$alpha), - lwd = coord$linewidth, - lty = coord$linetype, - lineend = lineend, - linejoin = linejoin - ), - arrow = arrow - )) - } - - data$group <- seq_len(nrow(data)) - starts <- subset(data, select = c(-xend, -yend)) - ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y")) - - pieces <- vec_rbind0(starts, ends) - pieces <- pieces[order(pieces$group),] - - GeomPath$draw_panel(pieces, panel_params, coord, arrow = arrow, - lineend = lineend) - }, - - draw_key = draw_key_path, - - rename_size = TRUE +geom_segment <- boilerplate( + GeomSegment, + arrow = NULL, arrow.fill = NULL, + lineend = "butt", linejoin = "round" ) diff --git a/R/geom-smooth.R b/R/geom-smooth.R index 08e1099df0..33ed5c5d80 100644 --- a/R/geom-smooth.R +++ b/R/geom-smooth.R @@ -1,3 +1,65 @@ +#' @rdname ggplot2-ggproto +#' @format 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$se <- params$se %||% + if (params$flipped_aes) { + all(c("xmin", "xmax") %in% names(data)) + } else { + all(c("ymin", "ymax") %in% names(data)) + } + + params + }, + + extra_params = c("na.rm", "orientation"), + + setup_data = function(data, params) { + GeomLine$setup_data(data, params) + }, + + # The `se` argument is set to false here to make sure drawing the + # geom and drawing the legend is in synch. If the geom is used by a + # stat that doesn't set the `se` argument then `se` will be missing + # and the legend key won't be drawn. With `se = FALSE` here the + # 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, lineend = "butt", linejoin = "round", + linemitre = 10, se = FALSE, flipped_aes = FALSE) { + ribbon <- transform(data, colour = NA) + path <- transform(data, alpha = NA) + + 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, flipped_aes = flipped_aes), + GeomLine$draw_panel(path, panel_params, coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre) + ) + }, + + draw_key = draw_key_smooth, + + required_aes = c("x", "y"), + optional_aes = c("ymin", "ymax"), + + default_aes = aes( + colour = from_theme(accent), + fill = from_theme(col_mix(ink, paper, 0.6)), + linewidth = from_theme(2 * linewidth), + linetype = from_theme(linetype), + weight = 1, alpha = 0.4 + ), + + rename_size = TRUE +) + #' Smoothed conditional means #' #' Aids the eye in seeing patterns in the presence of overplotting. @@ -117,64 +179,3 @@ geom_smooth <- function(mapping = NULL, data = NULL, params = params ) } - -#' @rdname ggplot2-ggproto -#' @format 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$se <- params$se %||% - if (params$flipped_aes) { - all(c("xmin", "xmax") %in% names(data)) - } else { - all(c("ymin", "ymax") %in% names(data)) - } - - params - }, - - extra_params = c("na.rm", "orientation"), - - setup_data = function(data, params) { - GeomLine$setup_data(data, params) - }, - - # The `se` argument is set to false here to make sure drawing the - # geom and drawing the legend is in synch. If the geom is used by a - # stat that doesn't set the `se` argument then `se` will be missing - # and the legend key won't be drawn. With `se = FALSE` here the - # 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, lineend = "butt", linejoin = "round", - linemitre = 10, se = FALSE, flipped_aes = FALSE) { - ribbon <- transform(data, colour = NA) - path <- transform(data, alpha = NA) - - 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, flipped_aes = flipped_aes), - GeomLine$draw_panel(path, panel_params, coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre) - ) - }, - - draw_key = draw_key_smooth, - - required_aes = c("x", "y"), - optional_aes = c("ymin", "ymax"), - - default_aes = aes( - colour = from_theme(accent), - fill = from_theme(col_mix(ink, paper, 0.6)), - linewidth = from_theme(2 * linewidth), - linetype = from_theme(linetype), - weight = 1, alpha = 0.4 - ), - - rename_size = TRUE -) diff --git a/R/geom-spoke.R b/R/geom-spoke.R index 032267b765..6ed4e89880 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -1,3 +1,21 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomSpoke <- ggproto( + "GeomSpoke", GeomSegment, + setup_data = function(data, params) { + data$radius <- data$radius %||% params$radius + data$angle <- data$angle %||% params$angle + + transform(data, + xend = x + cos(angle) * radius, + yend = y + sin(angle) * radius + ) + }, + required_aes = c("x", "y", "angle", "radius") +) + #' Line segments parameterised by location, direction and distance #' #' This is a polar parameterisation of [geom_segment()]. It is @@ -22,26 +40,7 @@ #' ggplot(df, aes(x, y)) + #' geom_point() + #' geom_spoke(aes(angle = angle, radius = speed)) -geom_spoke <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - geom = GeomSpoke, - stat = stat, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} +geom_spoke <- boilerplate(GeomSpoke) #' @export #' @rdname geom_spoke @@ -50,20 +49,3 @@ stat_spoke <- function(...) { deprecate_warn0("2.0.0", "stat_spoke()", "geom_spoke()") geom_spoke(...) } - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -GeomSpoke <- ggproto("GeomSpoke", GeomSegment, - setup_data = function(data, params) { - data$radius <- data$radius %||% params$radius - data$angle <- data$angle %||% params$angle - - transform(data, - xend = x + cos(angle) * radius, - yend = y + sin(angle) * radius - ) - }, - required_aes = c("x", "y", "angle", "radius") -) diff --git a/R/geom-tile.R b/R/geom-tile.R index e7bb6bc9e3..6e37908f4e 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -1,3 +1,42 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-rect.R +GeomTile <- ggproto("GeomTile", GeomRect, + extra_params = c("na.rm"), + + setup_data = function(data, params) { + + data$width <- data$width %||% params$width %||% + stats::ave(data$x, data$PANEL, FUN = function(x) resolution(x, FALSE, TRUE)) + data$height <- data$height %||% params$height %||% + stats::ave(data$y, data$PANEL, FUN = function(y) resolution(y, FALSE, TRUE)) + + transform(data, + xmin = x - width / 2, xmax = x + width / 2, width = NULL, + ymin = y - height / 2, ymax = y + height / 2, height = NULL + ) + }, + + default_aes = aes( + fill = from_theme(col_mix(ink, paper, 0.2)), + colour = NA, + linewidth = from_theme(0.4 * borderwidth), + linetype = from_theme(bordertype), + alpha = NA, width = NA, height = NA + ), + + required_aes = c("x", "y"), + + # These aes columns are created by setup_data(). They need to be listed here so + # that GeomRect$handle_na() properly removes any bars that fall outside the defined + # limits, not just those for which x and y are outside the limits + non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), + + draw_key = draw_key_polygon +) + #' Rectangles #' #' `geom_rect()` and `geom_tile()` do the same thing, but are @@ -78,64 +117,4 @@ #' position = "identity" #' ) #' } -geom_tile <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - linejoin = "mitre", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomTile, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - linejoin = linejoin, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-rect.R -GeomTile <- ggproto("GeomTile", GeomRect, - extra_params = c("na.rm"), - - setup_data = function(data, params) { - - data$width <- data$width %||% params$width %||% - stats::ave(data$x, data$PANEL, FUN = function(x) resolution(x, FALSE, TRUE)) - data$height <- data$height %||% params$height %||% - stats::ave(data$y, data$PANEL, FUN = function(y) resolution(y, FALSE, TRUE)) - - transform(data, - xmin = x - width / 2, xmax = x + width / 2, width = NULL, - ymin = y - height / 2, ymax = y + height / 2, height = NULL - ) - }, - - default_aes = aes( - fill = from_theme(col_mix(ink, paper, 0.2)), - colour = NA, - linewidth = from_theme(0.4 * borderwidth), - linetype = from_theme(bordertype), - alpha = NA, width = NA, height = NA - ), - - required_aes = c("x", "y"), - - # These aes columns are created by setup_data(). They need to be listed here so - # that GeomRect$handle_na() properly removes any bars that fall outside the defined - # limits, not just those for which x and y are outside the limits - non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), - - draw_key = draw_key_polygon -) +geom_tile <- boilerplate(GeomTile, linejoin = "mitre") diff --git a/R/geom-violin.R b/R/geom-violin.R index 9976e5b8a4..915e927727 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -1,124 +1,3 @@ -#' Violin plot -#' -#' A violin plot is a compact display of a continuous distribution. It is a -#' blend of [geom_boxplot()] and [geom_density()]: a -#' 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_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 -#' to the range of the data. If `FALSE`, don't trim the tails. -#' @param geom,stat Use to override the default connection between -#' `geom_violin()` and `stat_ydensity()`. For more information about -#' overriding these connections, see how the [stat][layer_stats] and -#' [geom][layer_geoms] arguments work. -#' @param bounds Known lower and upper bounds for estimated data. Default -#' `c(-Inf, Inf)` means that there are no (finite) bounds. If any bound is -#' finite, boundary effect of default density estimation will be corrected by -#' reflecting tails outside `bounds` around their closest edge. Data points -#' outside of bounds are removed with a warning. -#' @export -#' @references Hintze, J. L., Nelson, R. D. (1998) Violin Plots: A Box -#' Plot-Density Trace Synergism. The American Statistician 52, 181-184. -#' @examples -#' 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) -#' -#' # Scale maximum width proportional to sample size: -#' p + geom_violin(scale = "count") -#' -#' # Scale maximum width to 1 for all violins: -#' p + geom_violin(scale = "width") -#' -#' # Default is to trim violins to the range of the data. To disable: -#' p + geom_violin(trim = FALSE) -#' -#' # Use a smaller bandwidth for closer density fit (default is 1). -#' p + geom_violin(adjust = .5) -#' -#' # Add aesthetic mappings -#' # Note that violins are automatically dodged when any aesthetic is -#' # a factor -#' p + geom_violin(aes(fill = cyl)) -#' p + geom_violin(aes(fill = factor(cyl))) -#' p + geom_violin(aes(fill = factor(vs))) -#' p + geom_violin(aes(fill = factor(am))) -#' -#' # Set aesthetics to fixed value -#' p + geom_violin(fill = "grey80", colour = "#3366FF") -#' -#' # Show quartiles -#' p + geom_violin(draw_quantiles = c(0.25, 0.5, 0.75)) -#' -#' # Scales vs. coordinate transforms ------- -#' if (require("ggplot2movies")) { -#' # Scale transformations occur before the density statistics are computed. -#' # Coordinate transformations occur afterwards. Observe the effect on the -#' # number of outliers. -#' m <- ggplot(movies, aes(y = votes, x = rating, group = cut_width(rating, 0.5))) -#' m + geom_violin() -#' m + -#' geom_violin() + -#' scale_y_log10() -#' m + -#' geom_violin() + -#' coord_trans(y = "log10") -#' m + -#' geom_violin() + -#' scale_y_log10() + coord_trans(y = "log10") -#' -#' # Violin plots with continuous x: -#' # Use the group aesthetic to group observations in violins -#' ggplot(movies, aes(year, budget)) + -#' geom_violin() -#' ggplot(movies, aes(year, budget)) + -#' geom_violin(aes(group = cut_width(year, 10)), scale = "width") -#' } -#' } -geom_violin <- function(mapping = NULL, data = NULL, - stat = "ydensity", position = "dodge", - ..., - draw_quantiles = NULL, - trim = TRUE, - bounds = c(-Inf, Inf), - scale = "area", - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomViolin, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - trim = trim, - scale = scale, - draw_quantiles = draw_quantiles, - na.rm = na.rm, - orientation = orientation, - bounds = bounds, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -211,6 +90,101 @@ GeomViolin <- ggproto("GeomViolin", Geom, rename_size = TRUE ) +#' Violin plot +#' +#' A violin plot is a compact display of a continuous distribution. It is a +#' blend of [geom_boxplot()] and [geom_density()]: a +#' 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_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 +#' to the range of the data. If `FALSE`, don't trim the tails. +#' @param geom,stat Use to override the default connection between +#' `geom_violin()` and `stat_ydensity()`. For more information about +#' overriding these connections, see how the [stat][layer_stats] and +#' [geom][layer_geoms] arguments work. +#' @param bounds Known lower and upper bounds for estimated data. Default +#' `c(-Inf, Inf)` means that there are no (finite) bounds. If any bound is +#' finite, boundary effect of default density estimation will be corrected by +#' reflecting tails outside `bounds` around their closest edge. Data points +#' outside of bounds are removed with a warning. +#' @export +#' @references Hintze, J. L., Nelson, R. D. (1998) Violin Plots: A Box +#' Plot-Density Trace Synergism. The American Statistician 52, 181-184. +#' @examples +#' 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) +#' +#' # Scale maximum width proportional to sample size: +#' p + geom_violin(scale = "count") +#' +#' # Scale maximum width to 1 for all violins: +#' p + geom_violin(scale = "width") +#' +#' # Default is to trim violins to the range of the data. To disable: +#' p + geom_violin(trim = FALSE) +#' +#' # Use a smaller bandwidth for closer density fit (default is 1). +#' p + geom_violin(adjust = .5) +#' +#' # Add aesthetic mappings +#' # Note that violins are automatically dodged when any aesthetic is +#' # a factor +#' p + geom_violin(aes(fill = cyl)) +#' p + geom_violin(aes(fill = factor(cyl))) +#' p + geom_violin(aes(fill = factor(vs))) +#' p + geom_violin(aes(fill = factor(am))) +#' +#' # Set aesthetics to fixed value +#' p + geom_violin(fill = "grey80", colour = "#3366FF") +#' +#' # Show quartiles +#' p + geom_violin(draw_quantiles = c(0.25, 0.5, 0.75)) +#' +#' # Scales vs. coordinate transforms ------- +#' if (require("ggplot2movies")) { +#' # Scale transformations occur before the density statistics are computed. +#' # Coordinate transformations occur afterwards. Observe the effect on the +#' # number of outliers. +#' m <- ggplot(movies, aes(y = votes, x = rating, group = cut_width(rating, 0.5))) +#' m + geom_violin() +#' m + +#' geom_violin() + +#' scale_y_log10() +#' m + +#' geom_violin() + +#' coord_trans(y = "log10") +#' m + +#' geom_violin() + +#' scale_y_log10() + coord_trans(y = "log10") +#' +#' # Violin plots with continuous x: +#' # Use the group aesthetic to group observations in violins +#' ggplot(movies, aes(year, budget)) + +#' geom_violin() +#' ggplot(movies, aes(year, budget)) + +#' geom_violin(aes(group = cut_width(year, 10)), scale = "width") +#' } +#' } +geom_violin <- boilerplate( + GeomViolin, stat = "ydensity", position = "dodge", + draw_quantiles = NULL, trim = TRUE, bounds = c(-Inf, Inf), scale = "area" +) + # Returns a data.frame with info needed to draw quantile segments. create_quantile_segment_frame <- function(data, draw_quantiles) { dens <- cumsum(data$density) / sum(data$density) diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index 6c8c67cc19..ab29957798 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -13,8 +13,8 @@ geom_bar( position = "stack", ..., just = 0.5, - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -22,6 +22,7 @@ geom_bar( geom_col( mapping = NULL, data = NULL, + stat = "identity", position = "stack", ..., just = 0.5, @@ -110,14 +111,14 @@ columns to the left/right of axis breaks. Note that this argument may have unintended behaviour when used with alternative positions, e.g. \code{position_dodge()}.} -\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{na.rm}{If \code{FALSE}, the default, missing values are removed with +a warning. If \code{TRUE}, missing values are silently removed.} + \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. diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index 1f290dbcdc..eda1362109 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -26,8 +26,8 @@ geom_histogram( ..., binwidth = NULL, bins = NULL, - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 87bc5c8e75..4d8b09866f 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -15,8 +15,8 @@ geom_crossbar( position = "identity", ..., fatten = 2.5, - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -27,8 +27,8 @@ geom_errorbar( stat = "identity", position = "identity", ..., - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -39,8 +39,8 @@ geom_linerange( stat = "identity", position = "identity", ..., - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -52,8 +52,8 @@ geom_pointrange( position = "identity", ..., fatten = 4, - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -137,14 +137,14 @@ lists which parameters it can accept. middle bar in \code{geom_crossbar()} and the middle point in \code{geom_pointrange()}.} -\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{na.rm}{If \code{FALSE}, the default, missing values are removed with +a warning. If \code{TRUE}, missing values are silently removed.} + \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. diff --git a/man/geom_path.Rd b/man/geom_path.Rd index 88913a5a7b..527a6ecd68 100644 --- a/man/geom_path.Rd +++ b/man/geom_path.Rd @@ -27,11 +27,11 @@ geom_line( data = NULL, stat = "identity", position = "identity", - na.rm = FALSE, + ..., orientation = NA, + na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, - ... + inherit.aes = TRUE ) geom_step( @@ -39,12 +39,12 @@ geom_step( data = NULL, stat = "identity", position = "identity", + ..., direction = "hv", - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, - ... + inherit.aes = TRUE ) } \arguments{ diff --git a/man/geom_polygon.Rd b/man/geom_polygon.Rd index 241490284a..deb1289d07 100644 --- a/man/geom_polygon.Rd +++ b/man/geom_polygon.Rd @@ -9,8 +9,8 @@ geom_polygon( data = NULL, stat = "identity", position = "identity", - rule = "evenodd", ..., + rule = "evenodd", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -63,11 +63,6 @@ to use \code{position_jitter()}, give the position as \code{"jitter"}. \link[=layer_positions]{layer position} documentation. }} -\item{rule}{Either \code{"evenodd"} or \code{"winding"}. If polygons with holes are -being drawn (using the \code{subgroup} aesthetic) this argument defines how the -hole coordinates are interpreted. See the examples in \code{\link[grid:grid.path]{grid::pathGrob()}} for -an explanation.} - \item{...}{Other arguments passed on to \code{\link[=layer]{layer()}}'s \code{params} argument. These arguments broadly fall into one of 4 categories below. Notably, further arguments to the \code{position} argument, or aesthetics that are required @@ -96,6 +91,11 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{rule}{Either \code{"evenodd"} or \code{"winding"}. If polygons with holes are +being drawn (using the \code{subgroup} aesthetic) this argument defines how the +hole coordinates are interpreted. See the examples in \code{\link[grid:grid.path]{grid::pathGrob()}} for +an explanation.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -197,7 +197,6 @@ if (packageVersion("grid") >= "3.6") { geom_polygon(aes(fill = value, group = id, subgroup = subid)) p } - } \seealso{ \code{\link[=geom_path]{geom_path()}} for an unfilled polygon, diff --git a/man/geom_rug.Rd b/man/geom_rug.Rd index 1cc10e785a..94b6ee3032 100644 --- a/man/geom_rug.Rd +++ b/man/geom_rug.Rd @@ -177,5 +177,4 @@ p + p + geom_rug(length = unit(0.05, "npc")) + scale_y_continuous(expand = c(0.1, 0.1)) - } diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 974d1c5bdc..97290c0cda 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -16,7 +16,6 @@ geom_violin( bounds = c(-Inf, Inf), scale = "area", na.rm = FALSE, - orientation = NA, show.legend = NA, inherit.aes = TRUE ) @@ -121,11 +120,6 @@ 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. @@ -159,6 +153,11 @@ For example, \code{adjust = 1/2} means use half of the default bandwidth.} \item{drop}{Whether to discard groups with less than 2 observations (\code{TRUE}, default) or keep such groups for position adjustment purposes (\code{FALSE}).} + +\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.} } \description{ A violin plot is a compact display of a continuous distribution. It is a diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index c3384f1e45..46c62bbb2d 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -5,28 +5,27 @@ % R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, R/coord-map.R, % R/coord-polar.R, R/coord-quickmap.R, R/coord-radial.R, R/coord-transform.R, % R/facet-.R, R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, -% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-blank.R, +% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, R/geom-blank.R, % R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.R, -% R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, R/geom-ribbon.R, -% R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, R/geom-errorbar.R, -% R/geom-errorbarh.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, -% R/geom-label.R, R/geom-linerange.R, R/geom-point.R, R/geom-pointrange.R, +% R/geom-point.R, R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, +% R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, +% R/geom-errorbar.R, R/geom-errorbarh.R, R/geom-function.R, R/geom-hex.R, +% R/geom-hline.R, R/geom-label.R, R/geom-linerange.R, R/geom-pointrange.R, % R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, R/geom-spoke.R, -% R/geom-text.R, R/geom-tile.R, R/geom-violin.R, R/geom-vline.R, -% R/guide-.R, R/guide-axis.R, R/guide-axis-logticks.R, R/guide-axis-stack.R, -% R/guide-axis-theta.R, R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, -% R/guide-colorsteps.R, R/guide-custom.R, R/guide-none.R, R/guide-old.R, -% R/layout.R, R/position-.R, R/position-dodge.R, R/position-dodge2.R, -% R/position-identity.R, R/position-jitter.R, R/position-jitterdodge.R, -% R/position-nudge.R, R/position-stack.R, R/scale-.R, R/scale-binned.R, -% R/scale-continuous.R, R/scale-date.R, R/scale-discrete-.R, -% R/scale-identity.R, R/stat-align.R, R/stat-bin.R, R/stat-bin2d.R, -% R/stat-bindot.R, R/stat-binhex.R, R/stat-boxplot.R, R/stat-contour.R, -% R/stat-count.R, R/stat-density-2d.R, R/stat-density.R, R/stat-ecdf.R, -% R/stat-ellipse.R, R/stat-function.R, R/stat-identity.R, R/stat-qq-line.R, -% R/stat-qq.R, R/stat-quantilemethods.R, R/stat-smooth.R, R/stat-sum.R, -% R/stat-summary-2d.R, R/stat-summary-bin.R, R/stat-summary-hex.R, -% R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R +% R/geom-text.R, R/geom-violin.R, R/geom-vline.R, R/guide-.R, R/guide-axis.R, +% R/guide-axis-logticks.R, R/guide-axis-stack.R, R/guide-axis-theta.R, +% R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, R/guide-colorsteps.R, +% R/guide-custom.R, R/guide-none.R, R/guide-old.R, R/layout.R, R/position-.R, +% R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, +% R/position-jitter.R, R/position-jitterdodge.R, R/position-nudge.R, +% R/position-stack.R, R/scale-.R, R/scale-binned.R, R/scale-continuous.R, +% R/scale-date.R, R/scale-discrete-.R, R/scale-identity.R, R/stat-align.R, +% R/stat-bin.R, R/stat-bin2d.R, R/stat-bindot.R, R/stat-binhex.R, +% R/stat-boxplot.R, R/stat-contour.R, R/stat-count.R, R/stat-density-2d.R, +% R/stat-density.R, R/stat-ecdf.R, R/stat-ellipse.R, R/stat-function.R, +% R/stat-identity.R, R/stat-qq-line.R, R/stat-qq.R, R/stat-quantilemethods.R, +% R/stat-smooth.R, R/stat-sum.R, R/stat-summary-2d.R, R/stat-summary-bin.R, +% R/stat-summary-hex.R, R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R \docType{data} \name{ggplot2-ggproto} \alias{ggplot2-ggproto} @@ -56,6 +55,7 @@ \alias{GeomAbline} \alias{GeomRect} \alias{GeomBar} +\alias{GeomTile} \alias{GeomBlank} \alias{GeomBoxplot} \alias{GeomCol} @@ -64,6 +64,7 @@ \alias{GeomStep} \alias{GeomContour} \alias{GeomContourFilled} +\alias{GeomPoint} \alias{GeomCrossbar} \alias{GeomSegment} \alias{GeomCurve} @@ -80,14 +81,12 @@ \alias{GeomHline} \alias{GeomLabel} \alias{GeomLinerange} -\alias{GeomPoint} \alias{GeomPointrange} \alias{GeomQuantile} \alias{GeomRug} \alias{GeomSmooth} \alias{GeomSpoke} \alias{GeomText} -\alias{GeomTile} \alias{GeomViolin} \alias{GeomVline} \alias{Guide} diff --git a/man/is_tests.Rd b/man/is_tests.Rd index 62ded3db09..3274dc5b06 100644 --- a/man/is_tests.Rd +++ b/man/is_tests.Rd @@ -1,18 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ggproto.R, R/aes.R, R/geom-.R, R/coord-.R, -% R/facet-.R, R/stat-.R, R/theme-elements.R, R/guide-.R, R/layer.R, +% Please edit documentation in R/ggproto.R, R/aes.R, R/geom-.R, R/layer.R, +% R/coord-.R, R/facet-.R, R/stat-.R, R/theme-elements.R, R/guide-.R, % R/guides-.R, R/margins.R, R/plot.R, R/position-.R, R/scale-.R, R/theme.R \name{is.ggproto} \alias{is.ggproto} \alias{is.mapping} \alias{is.geom} +\alias{is.layer} \alias{is.coord} \alias{is.Coord} \alias{is.facet} \alias{is.stat} \alias{is.element} \alias{is.guide} -\alias{is.layer} \alias{is.guides} \alias{is.margin} \alias{is_tests} @@ -28,6 +28,8 @@ is.mapping(x) is.geom(x) +is.layer(x) + is.coord(x) is.Coord(x) # Deprecated @@ -40,8 +42,6 @@ is.element(x) is.guide(x) -is.layer(x) - is.guides(x) is.margin(x) From 3eee99f11e8101b5b71d53e00255b314c373648d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 17 Oct 2024 11:33:05 +0200 Subject: [PATCH 03/22] write out all non-standard arguments --- R/geom-bar.R | 5 ++++- R/geom-bin2d.R | 7 ++++++- R/geom-col.R | 5 ++++- R/geom-contour.R | 11 +++++++++-- R/geom-crossbar.R | 6 +++++- R/geom-errorbar.R | 5 ++++- R/geom-errorbarh.R | 3 ++- R/geom-hex.R | 8 +++++++- R/geom-histogram.R | 3 ++- R/geom-linerange.R | 4 +++- R/geom-path.R | 14 ++++++++++++-- R/geom-pointrange.R | 2 +- R/geom-polygon.R | 8 +++++++- R/geom-quantile.R | 3 ++- R/geom-rect.R | 2 +- R/geom-rug.R | 3 ++- R/geom-spoke.R | 6 +++++- R/geom-tile.R | 2 +- man/borders.Rd | 3 +++ man/geom_bar.Rd | 8 ++++++++ man/geom_bin_2d.Rd | 6 ++++++ man/geom_contour.Rd | 16 ++++++++++++++++ man/geom_errorbarh.Rd | 3 +++ man/geom_hex.Rd | 9 +++++++++ man/geom_histogram.Rd | 6 ++++++ man/geom_linerange.Rd | 13 +++++++++++++ man/geom_path.Rd | 10 ++++++++++ man/geom_polygon.Rd | 9 +++++++++ man/geom_quantile.Rd | 7 +++++++ man/geom_rug.Rd | 3 +++ man/geom_spoke.Rd | 13 +++++++++++++ man/geom_tile.Rd | 4 ++++ 32 files changed, 187 insertions(+), 20 deletions(-) diff --git a/R/geom-bar.R b/R/geom-bar.R index 3027d02f53..97fb689ced 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -90,6 +90,8 @@ GeomBar <- ggproto("GeomBar", GeomRect, #' @param geom,stat Override the default connection between `geom_bar()` and #' `stat_count()`. For more information about overriding these connections, #' see how the [stat][layer_stats] and [geom][layer_geoms] arguments work. +#' @param lineend Line end style (round, butt, square). +#' @param linejoin Line join style (round, mitre, bevel). #' @examples #' # geom_bar is designed to make it easy to create bar charts that show #' # counts (or sums of weights) @@ -136,5 +138,6 @@ GeomBar <- ggproto("GeomBar", GeomRect, #' ggplot(df, aes(x, y)) + geom_col(just = 1) geom_bar <- boilerplate( GeomBar, stat = "count", position = "stack", - just = 0.5, orientation = NA + just = 0.5, orientation = NA, + lineend = "butt", linejoin = "mitre" ) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 1534b9a7ae..4e401655f6 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -17,6 +17,8 @@ NULL #' `geom_bin_2d()` and `stat_bin_2d()`. For more information about overriding #' these connections, see how the [stat][layer_stats] and [geom][layer_geoms] #' arguments work. +#' @param lineend Line end style (round, butt, square). +#' @param linejoin Line join style (round, mitre, bevel). #' @seealso [stat_bin_hex()] for hexagonal binning #' @examples #' d <- ggplot(diamonds, aes(x, y)) + xlim(4, 10) + ylim(4, 10) @@ -29,7 +31,10 @@ NULL #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) -geom_bin_2d <- boilerplate(GeomTile, stat = "bin2d") +geom_bin_2d <- boilerplate( + GeomTile, stat = "bin2d", + lineend = "butt", linejoin = "mitre" +) #' @export #' @rdname geom_bin_2d diff --git a/R/geom-col.R b/R/geom-col.R index f779fb6e3a..3ce9ad55fd 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,6 +1,9 @@ #' @export #' @rdname geom_bar -geom_col <- boilerplate(GeomBar, position = "stack", just = 0.5) +geom_col <- boilerplate( + GeomBar, position = "stack", + just = 0.5, lineend = "butt", linejoin = "mitre" +) #' @rdname ggplot2-ggproto #' @format NULL diff --git a/R/geom-contour.R b/R/geom-contour.R index 7bd4c17e39..51f9316d13 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -49,6 +49,10 @@ GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) #' #' Overrides `binwidth` and `bins`. By default, this is a vector of length #' ten with [pretty()] breaks. +#' @param rule Either `"evenodd"` or `"winding"`. If polygons with holes are +#' being drawn (using the `subgroup` aesthetic) this argument defines how the +#' hole coordinates are interpreted. See the examples in [grid::pathGrob()] for +#' an explanation. #' @seealso [geom_density_2d()]: 2d density contours #' @export #' @examples @@ -82,12 +86,15 @@ GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) geom_contour <- boilerplate( GeomContour, stat = "contour", bins = NULL, binwidth = NULL, breaks = NULL, - lineend = "butt", linejoin = "round", linemitre = 10 + lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, arrow.fill = NULL ) #' @rdname geom_contour #' @export geom_contour_filled <- boilerplate( GeomContourFilled, stat = "contour_filled", - bins = NULL, binwidth = NULL, breaks = NULL + bins = NULL, binwidth = NULL, breaks = NULL, + rule = "evenodd", + lineend = "butt", linejoin = "round", linemitre = 10 ) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 2946f703c5..bd32f7b9c6 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -93,4 +93,8 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, #' @export #' @rdname geom_linerange -geom_crossbar <- boilerplate(GeomCrossbar, fatten = 2.5, orientation = NA) +geom_crossbar <- boilerplate( + GeomCrossbar, + fatten = 2.5, orientation = NA, width = NULL, + lineend = "butt", linejoin = "mitre" +) diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index 05deae5886..1d57ac5c83 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -58,4 +58,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, #' @export #' @rdname geom_linerange -geom_errorbar <- boilerplate(GeomErrorbar, orientation = NA) +geom_errorbar <- boilerplate( + GeomErrorbar, + orientation = NA, lineend = "butt" +) diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R index 013bcf0b19..9695ce1428 100644 --- a/R/geom-errorbarh.R +++ b/R/geom-errorbarh.R @@ -49,6 +49,7 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, #' @eval rd_aesthetics("geom", "errorbarh") #' @inheritParams layer #' @inheritParams geom_point +#' @param lineend Line end style (round, butt, square). #' @export #' @examples #' df <- data.frame( @@ -68,4 +69,4 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, #' p + #' geom_point() + #' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) -geom_errorbarh <- boilerplate(GeomErrorbarh) +geom_errorbarh <- boilerplate(GeomErrorbarh, lineend = "butt") diff --git a/R/geom-hex.R b/R/geom-hex.R index 96d5433561..f0ccd557f0 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -82,6 +82,9 @@ GeomHex <- ggproto("GeomHex", Geom, #' @export #' @inheritParams layer #' @inheritParams geom_point +#' @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). #' @export #' @examples #' d <- ggplot(diamonds, aes(carat, price)) @@ -97,4 +100,7 @@ GeomHex <- ggproto("GeomHex", Geom, #' d + geom_hex(binwidth = c(1, 1000)) #' d + geom_hex(binwidth = c(.1, 500)) #' } -geom_hex <- boilerplate(GeomHex, stat = 'binhex') +geom_hex <- boilerplate( + GeomHex, stat = 'binhex', + lineend = "butt", linejoin = "mitre", linemitre = 10 +) diff --git a/R/geom-histogram.R b/R/geom-histogram.R index 8fcd572548..07ec01de2d 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -117,5 +117,6 @@ #' geom_histogram(binwidth = function(x) 2 * IQR(x) / (length(x)^(1/3))) geom_histogram <- boilerplate( GeomBar, stat = "bin", position = "stack", - binwidth = NULL, bins = NULL, orientation = NA + binwidth = NULL, bins = NULL, orientation = NA, + lineend = "butt", linejoin = "mitre" ) diff --git a/R/geom-linerange.R b/R/geom-linerange.R index de61ac2456..c404db4121 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -60,6 +60,8 @@ GeomLinerange <- ggproto( #' @export #' @inheritParams layer #' @inheritParams geom_bar +#' @param width Bar width. By default, set to 90% of the [`resolution()`] of +#' the data. #' @examples #' # Create a simple example dataset #' df <- data.frame( @@ -107,4 +109,4 @@ GeomLinerange <- ggproto( #' aes(ymin = lower, ymax = upper), #' position = position_dodge2(width = 0.5, padding = 0.5) #' ) -geom_linerange <- boilerplate(GeomLinerange, orientation = NA) +geom_linerange <- boilerplate(GeomLinerange, orientation = NA, lineend = "butt") diff --git a/R/geom-path.R b/R/geom-path.R index d012283419..6bcde42109 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -274,14 +274,24 @@ geom_path <- boilerplate( #' @export #' @rdname geom_path -geom_line <- boilerplate(GeomLine, orientation = NA) +geom_line <- boilerplate( + GeomLine, + orientation = NA, + arrow = NULL, arrow.fill = NULL, + lineend = "butt", linejoin = "round", linemitre = 10 +) #' @param direction direction of stairs: 'vh' for vertical then horizontal, #' 'hv' for horizontal then vertical, or 'mid' for step half-way between #' adjacent x-values. #' @export #' @rdname geom_path -geom_step <- boilerplate(GeomStep, direction = "hv", orientation = NA) +geom_step <- boilerplate( + GeomStep, + direction = "hv", orientation = NA, + arrow = NULL, arrow.fill = NULL, + lineend = "butt", linejoin = "round", linemitre = 10 +) # Trim false values from left and right: keep all values from # first TRUE to last TRUE diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index 4c709be77c..84d557e430 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -47,4 +47,4 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, #' @export #' @rdname geom_linerange -geom_pointrange <- boilerplate(GeomPointrange, fatten = 4, orientation = NA) +geom_pointrange <- boilerplate(GeomPointrange, fatten = 4, orientation = NA, lineend = "butt") diff --git a/R/geom-polygon.R b/R/geom-polygon.R index b9c6836cb0..344db19fba 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -110,6 +110,9 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, #' @export #' @inheritParams layer #' @inheritParams geom_point +#' @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). #' @param rule Either `"evenodd"` or `"winding"`. If polygons with holes are #' being drawn (using the `subgroup` aesthetic) this argument defines how the #' hole coordinates are interpreted. See the examples in [grid::pathGrob()] for @@ -173,7 +176,10 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, #' geom_polygon(aes(fill = value, group = id, subgroup = subid)) #' p #' } -geom_polygon <- boilerplate(GeomPolygon, rule = "evenodd") +geom_polygon <- boilerplate( + GeomPolygon, rule = "evenodd", + lineend = "butt", linejoin = "round", linemitre = 10 +) # Assigning pathGrob in .onLoad ensures that packages that subclass GeomPolygon # do not install with error `possible error in 'pathGrob(munched$x, munched$y, ': diff --git a/R/geom-quantile.R b/R/geom-quantile.R index 9a3a64fa20..975181174f 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -46,5 +46,6 @@ GeomQuantile <- ggproto( #' m + geom_quantile(colour = "red", linewidth = 2, alpha = 0.5) geom_quantile <- boilerplate( GeomQuantile, stat = "quantile", - lineend = "butt", linejoin = "round", linemitre = 10 + lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, arrow.fill = NULL ) diff --git a/R/geom-rect.R b/R/geom-rect.R index 60f23a584c..4eba984433 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -86,7 +86,7 @@ GeomRect <- ggproto("GeomRect", Geom, #' @export #' @rdname geom_tile -geom_rect <- boilerplate(GeomRect, linejoin = "mitre") +geom_rect <- boilerplate(GeomRect, linejoin = "mitre", lineend = "butt") resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL, fun, type) { diff --git a/R/geom-rug.R b/R/geom-rug.R index f157922b40..4ec9645c82 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -145,6 +145,7 @@ GeomRug <- ggproto("GeomRug", Geom, #' bottom, and left. #' @param outside logical that controls whether to move the rug tassels outside of the plot area. Default is off (FALSE). You will also need to use `coord_cartesian(clip = "off")`. When set to TRUE, also consider changing the sides argument to "tr". See examples. #' @param length A [grid::unit()] object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data. +#' @param lineend Line end style (round, butt, square). #' @export #' @examples #' p <- ggplot(mtcars, aes(wt, mpg)) + @@ -182,5 +183,5 @@ GeomRug <- ggproto("GeomRug", Geom, #' scale_y_continuous(expand = c(0.1, 0.1)) geom_rug <- boilerplate( GeomRug, - outside = FALSE, sides = "bl", length = unit(0.03, "npc") + outside = FALSE, sides = "bl", length = unit(0.03, "npc"), lineend = "butt" ) diff --git a/R/geom-spoke.R b/R/geom-spoke.R index 6ed4e89880..f20aebf66e 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -40,7 +40,11 @@ GeomSpoke <- ggproto( #' ggplot(df, aes(x, y)) + #' geom_point() + #' geom_spoke(aes(angle = angle, radius = speed)) -geom_spoke <- boilerplate(GeomSpoke) +geom_spoke <- boilerplate( + GeomSpoke, + lineend = "butt", linejoin = "round", + arrow = NULL, arrow.fill = NULL +) #' @export #' @rdname geom_spoke diff --git a/R/geom-tile.R b/R/geom-tile.R index 6e37908f4e..b68637d396 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -117,4 +117,4 @@ GeomTile <- ggproto("GeomTile", GeomRect, #' position = "identity" #' ) #' } -geom_tile <- boilerplate(GeomTile, linejoin = "mitre") +geom_tile <- boilerplate(GeomTile, lineend = "butt", linejoin = "mitre") diff --git a/man/borders.Rd b/man/borders.Rd index 2f5e9f6841..76a709345e 100644 --- a/man/borders.Rd +++ b/man/borders.Rd @@ -29,6 +29,9 @@ polygons, see \code{\link[maps:map]{maps::map()}} for details.} \item{...}{ Arguments passed on to \code{\link[=geom_polygon]{geom_polygon}} \describe{ + \item{\code{lineend}}{Line end style (round, butt, square).} + \item{\code{linejoin}}{Line join style (round, mitre, bevel).} + \item{\code{linemitre}}{Line mitre limit (number greater than 1).} \item{\code{rule}}{Either \code{"evenodd"} or \code{"winding"}. If polygons with holes are being drawn (using the \code{subgroup} aesthetic) this argument defines how the hole coordinates are interpreted. See the examples in \code{\link[grid:grid.path]{grid::pathGrob()}} for diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index ab29957798..a136df19cf 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -14,6 +14,8 @@ geom_bar( ..., just = 0.5, orientation = NA, + lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -26,6 +28,8 @@ geom_col( position = "stack", ..., just = 0.5, + lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -116,6 +120,10 @@ 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{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_bin_2d.Rd b/man/geom_bin_2d.Rd index fa3b32b4ce..121cf0765c 100644 --- a/man/geom_bin_2d.Rd +++ b/man/geom_bin_2d.Rd @@ -13,6 +13,8 @@ geom_bin_2d( stat = "bin2d", position = "identity", ..., + lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -94,6 +96,10 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_contour.Rd b/man/geom_contour.Rd index c42aec41c9..1758dfe88e 100644 --- a/man/geom_contour.Rd +++ b/man/geom_contour.Rd @@ -19,6 +19,8 @@ geom_contour( lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, + arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -33,6 +35,10 @@ geom_contour_filled( bins = NULL, binwidth = NULL, breaks = NULL, + rule = "evenodd", + lineend = "butt", + linejoin = "round", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -162,6 +168,11 @@ ten with \code{\link[=pretty]{pretty()}} breaks.} \item{linemitre}{Line mitre limit (number greater than 1).} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -178,6 +189,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{rule}{Either \code{"evenodd"} or \code{"winding"}. If polygons with holes are +being drawn (using the \code{subgroup} aesthetic) this argument defines how the +hole coordinates are interpreted. See the examples in \code{\link[grid:grid.path]{grid::pathGrob()}} for +an explanation.} + \item{geom}{The geometric object to use to display the data for this layer. When using a \verb{stat_*()} function to construct a layer, the \code{geom} argument can be used to override the default coupling between stats and geoms. The diff --git a/man/geom_errorbarh.Rd b/man/geom_errorbarh.Rd index 4e6fb3aae9..810a18042d 100644 --- a/man/geom_errorbarh.Rd +++ b/man/geom_errorbarh.Rd @@ -10,6 +10,7 @@ geom_errorbarh( stat = "identity", position = "identity", ..., + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -90,6 +91,8 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_hex.Rd b/man/geom_hex.Rd index 553787761b..0079b1e89c 100644 --- a/man/geom_hex.Rd +++ b/man/geom_hex.Rd @@ -12,6 +12,9 @@ geom_hex( stat = "binhex", position = "identity", ..., + lineend = "butt", + linejoin = "mitre", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -92,6 +95,12 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{linemitre}{Line mitre limit (number greater than 1).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index eda1362109..fbf7b29184 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -27,6 +27,8 @@ geom_histogram( binwidth = NULL, bins = NULL, orientation = NA, + lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -148,6 +150,10 @@ 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{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{geom, stat}{Use to override the default connection between \code{geom_histogram()}/\code{geom_freqpoly()} and \code{stat_bin()}. For more information at overriding these connections, see how the \link[=layer_stats]{stat} and diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 4d8b09866f..471caba518 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -16,6 +16,9 @@ geom_crossbar( ..., fatten = 2.5, orientation = NA, + width = NULL, + lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -28,6 +31,7 @@ geom_errorbar( position = "identity", ..., orientation = NA, + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -40,6 +44,7 @@ geom_linerange( position = "identity", ..., orientation = NA, + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -53,6 +58,7 @@ geom_pointrange( ..., fatten = 4, orientation = NA, + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -142,6 +148,13 @@ 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{width}{Bar width. By default, set to 90\% of the \code{\link[=resolution]{resolution()}} of +the data.} + +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_path.Rd b/man/geom_path.Rd index 527a6ecd68..a5416ac27c 100644 --- a/man/geom_path.Rd +++ b/man/geom_path.Rd @@ -29,6 +29,11 @@ geom_line( position = "identity", ..., orientation = NA, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -42,6 +47,11 @@ geom_step( ..., direction = "hv", orientation = NA, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE diff --git a/man/geom_polygon.Rd b/man/geom_polygon.Rd index deb1289d07..e1f40f6c1a 100644 --- a/man/geom_polygon.Rd +++ b/man/geom_polygon.Rd @@ -11,6 +11,9 @@ geom_polygon( position = "identity", ..., rule = "evenodd", + lineend = "butt", + linejoin = "round", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -96,6 +99,12 @@ being drawn (using the \code{subgroup} aesthetic) this argument defines how the hole coordinates are interpreted. See the examples in \code{\link[grid:grid.path]{grid::pathGrob()}} for an explanation.} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{linemitre}{Line mitre limit (number greater than 1).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_quantile.Rd b/man/geom_quantile.Rd index 568c33e970..8a80b86db9 100644 --- a/man/geom_quantile.Rd +++ b/man/geom_quantile.Rd @@ -14,6 +14,8 @@ geom_quantile( lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, + arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -102,6 +104,11 @@ lists which parameters it can accept. \item{linemitre}{Line mitre limit (number greater than 1).} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_rug.Rd b/man/geom_rug.Rd index 94b6ee3032..4f9a4f9250 100644 --- a/man/geom_rug.Rd +++ b/man/geom_rug.Rd @@ -13,6 +13,7 @@ geom_rug( outside = FALSE, sides = "bl", length = unit(0.03, "npc"), + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -101,6 +102,8 @@ bottom, and left.} \item{length}{A \code{\link[grid:unit]{grid::unit()}} object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data.} +\item{lineend}{Line end style (round, butt, square).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_spoke.Rd b/man/geom_spoke.Rd index ea28f601c1..3ce8370834 100644 --- a/man/geom_spoke.Rd +++ b/man/geom_spoke.Rd @@ -11,6 +11,10 @@ geom_spoke( stat = "identity", position = "identity", ..., + lineend = "butt", + linejoin = "round", + arrow = NULL, + arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -91,6 +95,15 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{arrow}{specification for arrow heads, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index 34b9bb30bc..7e39508bda 100644 --- a/man/geom_tile.Rd +++ b/man/geom_tile.Rd @@ -27,6 +27,7 @@ geom_rect( position = "identity", ..., linejoin = "mitre", + lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -38,6 +39,7 @@ geom_tile( stat = "identity", position = "identity", ..., + lineend = "butt", linejoin = "mitre", na.rm = FALSE, show.legend = NA, @@ -143,6 +145,8 @@ that define both data and aesthetics and shouldn't inherit behaviour from the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \item{linejoin}{Line join style (round, mitre, bevel).} + +\item{lineend}{Line end style (round, butt, square).} } \description{ \code{geom_rect()} and \code{geom_tile()} do the same thing, but are From 26f9f8f0cc213a57d1c9980069c769d6c99c20db Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 17 Oct 2024 13:09:24 +0200 Subject: [PATCH 04/22] automatically fill in parameters --- R/boilerplates.R | 25 +++++++++++++++++++++++++ R/geom-bar.R | 6 +----- R/geom-bin2d.R | 5 +---- R/geom-col.R | 5 +---- R/geom-contour.R | 10 ++++------ R/geom-crossbar.R | 6 +----- R/geom-curve.R | 7 +------ R/geom-errorbar.R | 5 +---- R/geom-errorbarh.R | 2 +- R/geom-hex.R | 5 +---- R/geom-histogram.R | 4 ++-- R/geom-linerange.R | 2 +- R/geom-path.R | 20 +++----------------- R/geom-pointrange.R | 2 +- R/geom-polygon.R | 5 +---- R/geom-quantile.R | 6 +----- R/geom-rect.R | 2 +- R/geom-rug.R | 5 +---- R/geom-segment.R | 6 +----- R/geom-spoke.R | 6 +----- R/geom-tile.R | 2 +- R/geom-violin.R | 3 ++- man/geom_bar.Rd | 11 +++++------ man/geom_contour.Rd | 14 +++++++------- man/geom_linerange.Rd | 25 ++++++++++++------------- man/geom_path.Rd | 20 ++++++++++---------- man/geom_quantile.Rd | 14 +++++++------- man/geom_rug.Rd | 10 +++++----- man/geom_spoke.Rd | 12 ++++++------ man/geom_tile.Rd | 6 +++--- man/geom_violin.Rd | 8 ++++---- 31 files changed, 112 insertions(+), 147 deletions(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index 26d8030aeb..8987e9e451 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -23,6 +23,31 @@ boilerplate.Geom <- function(x, ..., env = caller_env()) { cli::cli_abort("{.arg geom} is a reserved argument.") } + # Fill in values for parameters from draw functions + known_params <- + unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics())) + missing_params <- setdiff(x$parameters(), known_params) + if (length(missing_params) > 0) { + draw_args <- ggproto_formals(x$draw_panel) + if ("..." %in% names(draw_args)) { + draw_args <- ggproto_formals(x$draw_group) + } + params <- intersect(missing_params, names(draw_args)) + extra_args <- c(extra_args, params) + for (param in params) { + if (!identical(draw_args[[param]], quote(expr = ))) { + args[param] <- draw_args[param] + } + } + missing_params <- setdiff(missing_params, names(args)) + if (length(missing_params) > 0) { + cli::cli_warn( + "In {.fn geom_{geom}}: please consider providing default values for: \\ + {missing_params}." + ) + } + } + # Build function formals fmls <- list2( mapping = args$mapping, diff --git a/R/geom-bar.R b/R/geom-bar.R index 97fb689ced..2d877ce8a3 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -136,8 +136,4 @@ GeomBar <- ggproto("GeomBar", GeomRect, #' ggplot(df, aes(x, y)) + geom_col(just = 0.5) #' # Columns begin on the first day of the month #' ggplot(df, aes(x, y)) + geom_col(just = 1) -geom_bar <- boilerplate( - GeomBar, stat = "count", position = "stack", - just = 0.5, orientation = NA, - lineend = "butt", linejoin = "mitre" -) +geom_bar <- boilerplate(GeomBar, stat = "count", position = "stack", just = 0.5) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 4e401655f6..4313b28471 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -31,10 +31,7 @@ NULL #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) -geom_bin_2d <- boilerplate( - GeomTile, stat = "bin2d", - lineend = "butt", linejoin = "mitre" -) +geom_bin_2d <- boilerplate(GeomTile, stat = "bin2d") #' @export #' @rdname geom_bin_2d diff --git a/R/geom-col.R b/R/geom-col.R index 3ce9ad55fd..f779fb6e3a 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,9 +1,6 @@ #' @export #' @rdname geom_bar -geom_col <- boilerplate( - GeomBar, position = "stack", - just = 0.5, lineend = "butt", linejoin = "mitre" -) +geom_col <- boilerplate(GeomBar, position = "stack", just = 0.5) #' @rdname ggplot2-ggproto #' @format NULL diff --git a/R/geom-contour.R b/R/geom-contour.R index 51f9316d13..5913d558bf 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -85,16 +85,14 @@ GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) #' } geom_contour <- boilerplate( GeomContour, stat = "contour", - bins = NULL, binwidth = NULL, breaks = NULL, - lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL + # Passed to contour stat: + bins = NULL, binwidth = NULL, breaks = NULL ) #' @rdname geom_contour #' @export geom_contour_filled <- boilerplate( GeomContourFilled, stat = "contour_filled", - bins = NULL, binwidth = NULL, breaks = NULL, - rule = "evenodd", - lineend = "butt", linejoin = "round", linemitre = 10 + # Passed to contour_filled stat: + bins = NULL, binwidth = NULL, breaks = NULL ) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index bd32f7b9c6..288f5396c5 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -93,8 +93,4 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, #' @export #' @rdname geom_linerange -geom_crossbar <- boilerplate( - GeomCrossbar, - fatten = 2.5, orientation = NA, width = NULL, - lineend = "butt", linejoin = "mitre" -) +geom_crossbar <- boilerplate(GeomCrossbar) diff --git a/R/geom-curve.R b/R/geom-curve.R index dd95a1deab..2ddac968fc 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -47,9 +47,4 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, #' @inheritParams grid::curveGrob #' @export #' @rdname geom_segment -geom_curve <- boilerplate( - GeomCurve, - curvature = 0.5, angle = 90, ncp = 5, - arrow = NULL, arrow.fill = NULL, - lineend = "butt" -) +geom_curve <- boilerplate(GeomCurve) diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index 1d57ac5c83..05deae5886 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -58,7 +58,4 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, #' @export #' @rdname geom_linerange -geom_errorbar <- boilerplate( - GeomErrorbar, - orientation = NA, lineend = "butt" -) +geom_errorbar <- boilerplate(GeomErrorbar, orientation = NA) diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R index 9695ce1428..96e5cdc412 100644 --- a/R/geom-errorbarh.R +++ b/R/geom-errorbarh.R @@ -69,4 +69,4 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, #' p + #' geom_point() + #' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) -geom_errorbarh <- boilerplate(GeomErrorbarh, lineend = "butt") +geom_errorbarh <- boilerplate(GeomErrorbarh) diff --git a/R/geom-hex.R b/R/geom-hex.R index f0ccd557f0..0f43a90ac7 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -100,7 +100,4 @@ GeomHex <- ggproto("GeomHex", Geom, #' d + geom_hex(binwidth = c(1, 1000)) #' d + geom_hex(binwidth = c(.1, 500)) #' } -geom_hex <- boilerplate( - GeomHex, stat = 'binhex', - lineend = "butt", linejoin = "mitre", linemitre = 10 -) +geom_hex <- boilerplate(GeomHex, stat = 'binhex') diff --git a/R/geom-histogram.R b/R/geom-histogram.R index 07ec01de2d..15c8064264 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -117,6 +117,6 @@ #' geom_histogram(binwidth = function(x) 2 * IQR(x) / (length(x)^(1/3))) geom_histogram <- boilerplate( GeomBar, stat = "bin", position = "stack", - binwidth = NULL, bins = NULL, orientation = NA, - lineend = "butt", linejoin = "mitre" + # Passed to bin stat: + binwidth = NULL, bins = NULL, orientation = NA ) diff --git a/R/geom-linerange.R b/R/geom-linerange.R index c404db4121..434078bda0 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -109,4 +109,4 @@ GeomLinerange <- ggproto( #' aes(ymin = lower, ymax = upper), #' position = position_dodge2(width = 0.5, padding = 0.5) #' ) -geom_linerange <- boilerplate(GeomLinerange, orientation = NA, lineend = "butt") +geom_linerange <- boilerplate(GeomLinerange, orientation = NA) diff --git a/R/geom-path.R b/R/geom-path.R index 6bcde42109..ad1bbaa890 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -266,32 +266,18 @@ GeomStep <- ggproto( #' # But this doesn't #' should_stop(p + geom_line(aes(colour = x), linetype=2)) #' } -geom_path <- boilerplate( - GeomPath, - lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL -) +geom_path <- boilerplate(GeomPath) #' @export #' @rdname geom_path -geom_line <- boilerplate( - GeomLine, - orientation = NA, - arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", linemitre = 10 -) +geom_line <- boilerplate(GeomLine, orientation = NA) #' @param direction direction of stairs: 'vh' for vertical then horizontal, #' 'hv' for horizontal then vertical, or 'mid' for step half-way between #' adjacent x-values. #' @export #' @rdname geom_path -geom_step <- boilerplate( - GeomStep, - direction = "hv", orientation = NA, - arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", linemitre = 10 -) +geom_step <- boilerplate(GeomStep, orientation = NA) # Trim false values from left and right: keep all values from # first TRUE to last TRUE diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index 84d557e430..17a319b65c 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -47,4 +47,4 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, #' @export #' @rdname geom_linerange -geom_pointrange <- boilerplate(GeomPointrange, fatten = 4, orientation = NA, lineend = "butt") +geom_pointrange <- boilerplate(GeomPointrange, orientation = NA) diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 344db19fba..9ee85a1c7b 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -176,10 +176,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, #' geom_polygon(aes(fill = value, group = id, subgroup = subid)) #' p #' } -geom_polygon <- boilerplate( - GeomPolygon, rule = "evenodd", - lineend = "butt", linejoin = "round", linemitre = 10 -) +geom_polygon <- boilerplate(GeomPolygon) # Assigning pathGrob in .onLoad ensures that packages that subclass GeomPolygon # do not install with error `possible error in 'pathGrob(munched$x, munched$y, ': diff --git a/R/geom-quantile.R b/R/geom-quantile.R index 975181174f..2e12248ee5 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -44,8 +44,4 @@ GeomQuantile <- ggproto( #' #' # Set aesthetics to fixed value #' m + geom_quantile(colour = "red", linewidth = 2, alpha = 0.5) -geom_quantile <- boilerplate( - GeomQuantile, stat = "quantile", - lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL -) +geom_quantile <- boilerplate(GeomQuantile, stat = "quantile") diff --git a/R/geom-rect.R b/R/geom-rect.R index 4eba984433..5157597017 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -86,7 +86,7 @@ GeomRect <- ggproto("GeomRect", Geom, #' @export #' @rdname geom_tile -geom_rect <- boilerplate(GeomRect, linejoin = "mitre", lineend = "butt") +geom_rect <- boilerplate(GeomRect) resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL, fun, type) { diff --git a/R/geom-rug.R b/R/geom-rug.R index 4ec9645c82..3f4331d4c8 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -181,7 +181,4 @@ GeomRug <- ggproto("GeomRug", Geom, #' p + #' geom_rug(length = unit(0.05, "npc")) + #' scale_y_continuous(expand = c(0.1, 0.1)) -geom_rug <- boilerplate( - GeomRug, - outside = FALSE, sides = "bl", length = unit(0.03, "npc"), lineend = "butt" -) +geom_rug <- boilerplate(GeomRug) diff --git a/R/geom-segment.R b/R/geom-segment.R index 8884c68a39..026ac157a3 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -128,8 +128,4 @@ GeomSegment <- ggproto("GeomSegment", Geom, #' #' ggplot(counts, aes(x, Freq)) + #' geom_segment(aes(xend = x, yend = 0), linewidth = 10, lineend = "butt") -geom_segment <- boilerplate( - GeomSegment, - arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round" -) +geom_segment <- boilerplate(GeomSegment) diff --git a/R/geom-spoke.R b/R/geom-spoke.R index f20aebf66e..6ed4e89880 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -40,11 +40,7 @@ GeomSpoke <- ggproto( #' ggplot(df, aes(x, y)) + #' geom_point() + #' geom_spoke(aes(angle = angle, radius = speed)) -geom_spoke <- boilerplate( - GeomSpoke, - lineend = "butt", linejoin = "round", - arrow = NULL, arrow.fill = NULL -) +geom_spoke <- boilerplate(GeomSpoke) #' @export #' @rdname geom_spoke diff --git a/R/geom-tile.R b/R/geom-tile.R index b68637d396..c441e5bd52 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -117,4 +117,4 @@ GeomTile <- ggproto("GeomTile", GeomRect, #' position = "identity" #' ) #' } -geom_tile <- boilerplate(GeomTile, lineend = "butt", linejoin = "mitre") +geom_tile <- boilerplate(GeomTile) diff --git a/R/geom-violin.R b/R/geom-violin.R index 915e927727..16bdfaef1b 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -182,7 +182,8 @@ GeomViolin <- ggproto("GeomViolin", Geom, #' } geom_violin <- boilerplate( GeomViolin, stat = "ydensity", position = "dodge", - draw_quantiles = NULL, trim = TRUE, bounds = c(-Inf, Inf), scale = "area" + # arguments passed to ydensity stat: + trim = TRUE, bounds = c(-Inf, Inf), scale = "area" ) # Returns a data.frame with info needed to draw quantile segments. diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index a136df19cf..eb8855f587 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -13,7 +13,6 @@ geom_bar( position = "stack", ..., just = 0.5, - orientation = NA, lineend = "butt", linejoin = "mitre", na.rm = FALSE, @@ -115,11 +114,6 @@ columns to the left/right of axis breaks. Note that this argument may have unintended behaviour when used with alternative positions, e.g. \code{position_dodge()}.} -\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{lineend}{Line end style (round, butt, square).} \item{linejoin}{Line join style (round, mitre, bevel).} @@ -143,6 +137,11 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \item{geom, stat}{Override the default connection between \code{geom_bar()} and \code{stat_count()}. For more information about overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} + +\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.} } \description{ There are two types of bar charts: \code{geom_bar()} and \code{geom_col()}. diff --git a/man/geom_contour.Rd b/man/geom_contour.Rd index 1758dfe88e..97d03e3a04 100644 --- a/man/geom_contour.Rd +++ b/man/geom_contour.Rd @@ -16,11 +16,11 @@ geom_contour( bins = NULL, binwidth = NULL, breaks = NULL, + arrow = NULL, + arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, - arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -162,17 +162,17 @@ and returns breaks as output. A function can be created from a formula Overrides \code{binwidth} and \code{bins}. By default, this is a vector of length ten with \code{\link[=pretty]{pretty()}} breaks.} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{lineend}{Line end style (round, butt, square).} \item{linejoin}{Line join style (round, mitre, bevel).} \item{linemitre}{Line mitre limit (number greater than 1).} -\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} - -\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} -means use \code{colour} aesthetic.} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 471caba518..b8171ab4ac 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -14,11 +14,10 @@ geom_crossbar( stat = "identity", position = "identity", ..., - fatten = 2.5, - orientation = NA, - width = NULL, lineend = "butt", linejoin = "mitre", + fatten = 2.5, + width = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -56,9 +55,9 @@ geom_pointrange( stat = "identity", position = "identity", ..., - fatten = 4, orientation = NA, lineend = "butt", + fatten = 4, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -139,22 +138,17 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{fatten}{A multiplicative factor used to increase the size of the middle bar in \code{geom_crossbar()} and the middle point in \code{geom_pointrange()}.} -\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{width}{Bar width. By default, set to 90\% of the \code{\link[=resolution]{resolution()}} of the data.} -\item{lineend}{Line end style (round, butt, square).} - -\item{linejoin}{Line join style (round, mitre, bevel).} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -170,6 +164,11 @@ but unobserved levels are omitted.} 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.} } \description{ Various ways of representing a vertical interval defined by \code{x}, diff --git a/man/geom_path.Rd b/man/geom_path.Rd index a5416ac27c..b5b4def14c 100644 --- a/man/geom_path.Rd +++ b/man/geom_path.Rd @@ -12,11 +12,11 @@ geom_path( stat = "identity", position = "identity", ..., + arrow = NULL, + arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, - arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -45,13 +45,13 @@ geom_step( stat = "identity", position = "identity", ..., - direction = "hv", orientation = NA, - arrow = NULL, - arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, + arrow.fill = NULL, + direction = "hv", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -132,17 +132,17 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{lineend}{Line end style (round, butt, square).} \item{linejoin}{Line join style (round, mitre, bevel).} \item{linemitre}{Line mitre limit (number greater than 1).} -\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} - -\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} -means use \code{colour} aesthetic.} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_quantile.Rd b/man/geom_quantile.Rd index 8a80b86db9..3109da63b1 100644 --- a/man/geom_quantile.Rd +++ b/man/geom_quantile.Rd @@ -11,11 +11,11 @@ geom_quantile( stat = "quantile", position = "identity", ..., + arrow = NULL, + arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, - arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -98,17 +98,17 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{lineend}{Line end style (round, butt, square).} \item{linejoin}{Line join style (round, mitre, bevel).} \item{linemitre}{Line mitre limit (number greater than 1).} -\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} - -\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} -means use \code{colour} aesthetic.} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_rug.Rd b/man/geom_rug.Rd index 4f9a4f9250..963d1736af 100644 --- a/man/geom_rug.Rd +++ b/man/geom_rug.Rd @@ -10,10 +10,10 @@ geom_rug( stat = "identity", position = "identity", ..., - outside = FALSE, + lineend = "butt", sides = "bl", + outside = FALSE, length = unit(0.03, "npc"), - lineend = "butt", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -94,15 +94,15 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{outside}{logical that controls whether to move the rug tassels outside of the plot area. Default is off (FALSE). You will also need to use \code{coord_cartesian(clip = "off")}. When set to TRUE, also consider changing the sides argument to "tr". See examples.} +\item{lineend}{Line end style (round, butt, square).} \item{sides}{A string that controls which sides of the plot the rugs appear on. It can be set to a string containing any of \code{"trbl"}, for top, right, bottom, and left.} -\item{length}{A \code{\link[grid:unit]{grid::unit()}} object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data.} +\item{outside}{logical that controls whether to move the rug tassels outside of the plot area. Default is off (FALSE). You will also need to use \code{coord_cartesian(clip = "off")}. When set to TRUE, also consider changing the sides argument to "tr". See examples.} -\item{lineend}{Line end style (round, butt, square).} +\item{length}{A \code{\link[grid:unit]{grid::unit()}} object that sets the length of the rug lines. Use scale expansion to avoid overplotting of data.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_spoke.Rd b/man/geom_spoke.Rd index 3ce8370834..657333ac75 100644 --- a/man/geom_spoke.Rd +++ b/man/geom_spoke.Rd @@ -11,10 +11,10 @@ geom_spoke( stat = "identity", position = "identity", ..., - lineend = "butt", - linejoin = "round", arrow = NULL, arrow.fill = NULL, + lineend = "butt", + linejoin = "round", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -95,15 +95,15 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{lineend}{Line end style (round, butt, square).} - -\item{linejoin}{Line join style (round, mitre, bevel).} - \item{arrow}{specification for arrow heads, as created by \code{\link[grid:arrow]{grid::arrow()}}.} \item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} means use \code{colour} aesthetic.} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index 7e39508bda..312357f40c 100644 --- a/man/geom_tile.Rd +++ b/man/geom_tile.Rd @@ -26,8 +26,8 @@ geom_rect( stat = "identity", position = "identity", ..., - linejoin = "mitre", lineend = "butt", + linejoin = "mitre", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -144,9 +144,9 @@ 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{linejoin}{Line join style (round, mitre, bevel).} - \item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} } \description{ \code{geom_rect()} and \code{geom_tile()} do the same thing, but are diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 97290c0cda..c3df4b9cbc 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -11,10 +11,10 @@ geom_violin( stat = "ydensity", position = "dodge", ..., - draw_quantiles = NULL, trim = TRUE, bounds = c(-Inf, Inf), scale = "area", + draw_quantiles = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -101,9 +101,6 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{draw_quantiles}{If \code{not(NULL)} (default), draw horizontal lines -at the given quantiles of the density estimate.} - \item{trim}{If \code{TRUE} (default), trim the tails of the violins to the range of the data. If \code{FALSE}, don't trim the tails.} @@ -117,6 +114,9 @@ outside of bounds are removed with a warning.} the tails). If "count", areas are scaled proportionally to the number of observations. If "width", all violins have the same maximum width.} +\item{draw_quantiles}{If \code{not(NULL)} (default), draw horizontal lines +at the given quantiles of the density estimate.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} From 8c8f79588c0f4ba44033ed0bc3dec9d9c86ca949 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 17 Oct 2024 14:58:13 +0200 Subject: [PATCH 05/22] incorporate small checks --- R/boilerplates.R | 12 ++- R/geom-density.R | 34 ++------ R/geom-function.R | 69 ++++++--------- R/geom-raster.R | 53 ++++------- R/geom-ribbon.R | 203 ++++++++++++++++++------------------------- man/geom_density.Rd | 32 ++++--- man/geom_function.Rd | 16 ++++ man/geom_ribbon.Rd | 41 ++++++--- man/geom_tile.Rd | 8 +- 9 files changed, 209 insertions(+), 259 deletions(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index 8987e9e451..499144b53f 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -8,7 +8,7 @@ boilerplate <- function(x, ...) { } #' @export -boilerplate.Geom <- function(x, ..., env = caller_env()) { +boilerplate.Geom <- function(x, ..., checks, env = caller_env()) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) @@ -83,7 +83,15 @@ boilerplate.Geom <- function(x, ..., env = caller_env()) { ) ) ") - body <- as.call(parse(text = body))[[1]] + body <- str2lang(body) + + checks <- substitute(checks) + if (!missing(checks)) { + if (is_call(checks, "{")) { + checks[[1]] <- NULL + } + body <- inject(quote(`{`(!!!c(checks, body)))) + } new_function(fmls, body) } diff --git a/R/geom-density.R b/R/geom-density.R index e94c5157ce..3b8ee8a317 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -72,31 +72,9 @@ GeomDensity <- ggproto( #' ggplot(diamonds, aes(carat, after_stat(count), fill = cut)) + #' geom_density(position = "fill") #' } -geom_density <- function(mapping = NULL, data = NULL, - stat = "density", position = "identity", - ..., - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE, - outline.type = "upper") { - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomDensity, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - outline.type = outline.type, - ... - ) - ) -} - - +geom_density <- boilerplate( + GeomDensity, stat = "density", + checks = { + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + } +) diff --git a/R/geom-function.R b/R/geom-function.R index c566731996..b2ba6df095 100644 --- a/R/geom-function.R +++ b/R/geom-function.R @@ -1,3 +1,26 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-path.R +GeomFunction <- ggproto("GeomFunction", GeomPath, + draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, + lineend = "butt", linejoin = "round", linemitre = 10, + na.rm = FALSE) { + groups <- unique0(data$group) + if (length(groups) > 1) { + cli::cli_warn(c( + "Multiple drawing groups in {.fn {snake_class(self)}}", + "i" = "Did you use the correct {.field group}, {.field colour}, or {.field fill} aesthetics?" + )) + } + + ggproto_parent(GeomPath, self)$draw_panel( + data, panel_params, coord, arrow, arrow.fill, lineend, linejoin, linemitre, na.rm + ) + } +) + #' Draw a function as a continuous curve #' #' Computes and draws a function as a continuous curve. This makes it easy to @@ -62,47 +85,7 @@ #' geom_function(fun = dnorm, colour = "red", xlim=c(-7, 7)) #' #' @export -geom_function <- function(mapping = NULL, data = NULL, stat = "function", - position = "identity", ..., na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE) { - if (is.null(data)) { - data <- ensure_nonempty_data - } - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomFunction, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-path.R -GeomFunction <- ggproto("GeomFunction", GeomPath, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", linemitre = 10, - na.rm = FALSE) { - groups <- unique0(data$group) - if (length(groups) > 1) { - cli::cli_warn(c( - "Multiple drawing groups in {.fn {snake_class(self)}}", - "i" = "Did you use the correct {.field group}, {.field colour}, or {.field fill} aesthetics?" - )) - } - - ggproto_parent(GeomPath, self)$draw_panel( - data, panel_params, coord, arrow, arrow.fill, lineend, linejoin, linemitre, na.rm - ) - } +geom_function <- boilerplate( + GeomFunction, stat = "function", + checks = {data <- data %||% ensure_nonempty_data} ) diff --git a/R/geom-raster.R b/R/geom-raster.R index 94b1775373..6c4a3b92aa 100644 --- a/R/geom-raster.R +++ b/R/geom-raster.R @@ -1,44 +1,6 @@ #' @include geom-.R NULL -#' @export -#' @rdname geom_tile -#' @param hjust,vjust horizontal and vertical justification of the grob. Each -#' justification value should be a number between 0 and 1. Defaults to 0.5 -#' for both, centering each pixel over its data location. -#' @param interpolate If `TRUE` interpolate linearly, if `FALSE` -#' (the default) don't interpolate. -geom_raster <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - hjust = 0.5, - vjust = 0.5, - interpolate = FALSE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) -{ - check_number_decimal(hjust) - check_number_decimal(vjust) - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomRaster, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - hjust = hjust, - vjust = vjust, - interpolate = interpolate, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -126,3 +88,18 @@ GeomRaster <- ggproto("GeomRaster", Geom, }, draw_key = draw_key_rect ) + +#' @export +#' @rdname geom_tile +#' @param hjust,vjust horizontal and vertical justification of the grob. Each +#' justification value should be a number between 0 and 1. Defaults to 0.5 +#' for both, centering each pixel over its data location. +#' @param interpolate If `TRUE` interpolate linearly, if `FALSE` +#' (the default) don't interpolate. +geom_raster <- boilerplate( + GeomRaster, + checks = { + check_number_decimal(hjust) + check_number_decimal(vjust) + } +) diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index a8f6b1be42..c4e41223d1 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -1,96 +1,3 @@ -#' Ribbons and area plots -#' -#' For each x value, `geom_ribbon()` displays a y interval defined -#' by `ymin` and `ymax`. `geom_area()` is a special case of -#' `geom_ribbon()`, where the `ymin` is fixed to 0 and `y` is used instead -#' of `ymax`. -#' -#' An area plot is the continuous analogue of a stacked bar chart (see -#' [geom_bar()]), and can be used to show how composition of the -#' whole varies over the range of x. Choosing the order in which different -#' components is stacked is very important, as it becomes increasing hard to -#' see the individual pattern as you move up the stack. See -#' [position_stack()] for the details of stacking algorithm. To facilitate -#' stacking, the default `stat = "align"` interpolates groups to a common set -#' of x-coordinates. To turn off this interpolation, `stat = "identity"` can -#' be used instead. -#' -#' @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_bar -#' @param outline.type Type of the outline of the area; `"both"` draws both the -#' upper and lower lines, `"upper"`/`"lower"` draws the respective lines only. -#' `"full"` draws a closed polygon around the area. -#' @export -#' @examples -#' # Generate data -#' huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron)) -#' h <- ggplot(huron, aes(year)) -#' -#' h + geom_ribbon(aes(ymin=0, ymax=level)) -#' h + geom_area(aes(y = level)) -#' -#' # Orientation cannot be deduced by mapping, so must be given explicitly for -#' # flipped orientation -#' h + geom_area(aes(x = level, y = year), orientation = "y") -#' -#' # Add aesthetic mappings -#' h + -#' geom_ribbon(aes(ymin = level - 1, ymax = level + 1), fill = "grey70") + -#' geom_line(aes(y = level)) -#' -#' # The underlying stat_align() takes care of unaligned data points -#' df <- data.frame( -#' g = c("a", "a", "a", "b", "b", "b"), -#' x = c(1, 3, 5, 2, 4, 6), -#' y = c(2, 5, 1, 3, 6, 7) -#' ) -#' a <- ggplot(df, aes(x, y, fill = g)) + -#' geom_area() -#' -#' # Two groups have points on different X values. -#' a + geom_point(size = 8) + facet_grid(g ~ .) -#' -#' # stat_align() interpolates and aligns the value so that the areas can stack -#' # properly. -#' a + geom_point(stat = "align", position = "stack", size = 8) -#' -#' # To turn off the alignment, the stat can be set to "identity" -#' ggplot(df, aes(x, y, fill = g)) + -#' geom_area(stat = "identity") -geom_ribbon <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE, - outline.type = "both") { - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomRibbon, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - outline.type = outline.type, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -266,31 +173,6 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, rename_size = TRUE ) -#' @rdname geom_ribbon -#' @export -geom_area <- function(mapping = NULL, data = NULL, stat = "align", - position = "stack", na.rm = FALSE, orientation = NA, - show.legend = NA, inherit.aes = TRUE, ..., - outline.type = "upper") { - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomArea, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - outline.type = outline.type, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -319,3 +201,88 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, flip_data(data, params$flipped_aes) } ) + +#' Ribbons and area plots +#' +#' For each x value, `geom_ribbon()` displays a y interval defined +#' by `ymin` and `ymax`. `geom_area()` is a special case of +#' `geom_ribbon()`, where the `ymin` is fixed to 0 and `y` is used instead +#' of `ymax`. +#' +#' An area plot is the continuous analogue of a stacked bar chart (see +#' [geom_bar()]), and can be used to show how composition of the +#' whole varies over the range of x. Choosing the order in which different +#' components is stacked is very important, as it becomes increasing hard to +#' see the individual pattern as you move up the stack. See +#' [position_stack()] for the details of stacking algorithm. To facilitate +#' stacking, the default `stat = "align"` interpolates groups to a common set +#' of x-coordinates. To turn off this interpolation, `stat = "identity"` can +#' be used instead. +#' +#' @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_bar +#' @param linemitre Line mitre limit (number greater than 1). +#' @param outline.type Type of the outline of the area; `"both"` draws both the +#' upper and lower lines, `"upper"`/`"lower"` draws the respective lines only. +#' `"full"` draws a closed polygon around the area. +#' @export +#' @examples +#' # Generate data +#' huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron)) +#' h <- ggplot(huron, aes(year)) +#' +#' h + geom_ribbon(aes(ymin=0, ymax=level)) +#' h + geom_area(aes(y = level)) +#' +#' # Orientation cannot be deduced by mapping, so must be given explicitly for +#' # flipped orientation +#' h + geom_area(aes(x = level, y = year), orientation = "y") +#' +#' # Add aesthetic mappings +#' h + +#' geom_ribbon(aes(ymin = level - 1, ymax = level + 1), fill = "grey70") + +#' geom_line(aes(y = level)) +#' +#' # The underlying stat_align() takes care of unaligned data points +#' df <- data.frame( +#' g = c("a", "a", "a", "b", "b", "b"), +#' x = c(1, 3, 5, 2, 4, 6), +#' y = c(2, 5, 1, 3, 6, 7) +#' ) +#' a <- ggplot(df, aes(x, y, fill = g)) + +#' geom_area() +#' +#' # Two groups have points on different X values. +#' a + geom_point(size = 8) + facet_grid(g ~ .) +#' +#' # stat_align() interpolates and aligns the value so that the areas can stack +#' # properly. +#' a + geom_point(stat = "align", position = "stack", size = 8) +#' +#' # To turn off the alignment, the stat can be set to "identity" +#' ggplot(df, aes(x, y, fill = g)) + +#' geom_area(stat = "identity") +#' +geom_ribbon <- boilerplate( + GeomRibbon, orientation = NA, + checks = { + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + } +) + +#' @rdname geom_ribbon +#' @export +geom_area <- boilerplate( + GeomArea, stat = "align", position = "stack", + orientation = NA, outline.type = "upper", + checks = { + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + } +) diff --git a/man/geom_density.Rd b/man/geom_density.Rd index 58f6dae9e2..1ae3ea371d 100644 --- a/man/geom_density.Rd +++ b/man/geom_density.Rd @@ -11,11 +11,13 @@ geom_density( stat = "density", position = "identity", ..., + lineend = "butt", + linejoin = "round", + linemitre = 10, + outline.type = "both", na.rm = FALSE, - orientation = NA, show.legend = NA, - inherit.aes = TRUE, - outline.type = "upper" + inherit.aes = TRUE ) stat_density( @@ -98,14 +100,19 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{linemitre}{Line mitre limit (number greater than 1).} + +\item{outline.type}{Type of the outline of the area; \code{"both"} draws both the +upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only. +\code{"full"} draws a closed polygon around the area.} + \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. @@ -119,10 +126,6 @@ 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{outline.type}{Type of the outline of the area; \code{"both"} draws both the -upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only. -\code{"full"} draws a closed polygon around the area.} - \item{geom, stat}{Use to override the default connection between \code{geom_density()} and \code{stat_density()}. For more information about overriding these connections, see how the \link[=layer_stats]{stat} and @@ -156,6 +159,11 @@ one plot or if you are manually adjusting the scale limits.} finite, boundary effect of default density estimation will be corrected by reflecting tails outside \code{bounds} around their closest edge. Data points outside of bounds are removed with a warning.} + +\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.} } \description{ Computes and draws kernel density estimate, which is a smoothed version of diff --git a/man/geom_function.Rd b/man/geom_function.Rd index faf9d8552e..8ce29f0daa 100644 --- a/man/geom_function.Rd +++ b/man/geom_function.Rd @@ -11,6 +11,11 @@ geom_function( stat = "function", position = "identity", ..., + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -93,6 +98,17 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} + +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + +\item{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{linemitre}{Line mitre limit (number greater than 1).} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} diff --git a/man/geom_ribbon.Rd b/man/geom_ribbon.Rd index d4f5a707e1..fcb79eb209 100644 --- a/man/geom_ribbon.Rd +++ b/man/geom_ribbon.Rd @@ -12,11 +12,14 @@ geom_ribbon( stat = "identity", position = "identity", ..., - na.rm = FALSE, orientation = NA, + lineend = "butt", + linejoin = "round", + linemitre = 10, + outline.type = "both", + na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, - outline.type = "both" + inherit.aes = TRUE ) geom_area( @@ -24,12 +27,15 @@ geom_area( data = NULL, stat = "align", position = "stack", - na.rm = FALSE, + ..., orientation = NA, + outline.type = "upper", + lineend = "butt", + linejoin = "round", + linemitre = 10, + na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, - ..., - outline.type = "upper" + inherit.aes = TRUE ) stat_align( @@ -118,14 +124,24 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\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{lineend}{Line end style (round, butt, square).} + +\item{linejoin}{Line join style (round, mitre, bevel).} + +\item{linemitre}{Line mitre limit (number greater than 1).} + +\item{outline.type}{Type of the outline of the area; \code{"both"} draws both the +upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only. +\code{"full"} draws a closed polygon around the area.} + +\item{na.rm}{If \code{FALSE}, the default, missing values are removed with +a warning. If \code{TRUE}, missing values are silently removed.} + \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. @@ -139,10 +155,6 @@ 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{outline.type}{Type of the outline of the area; \code{"both"} draws both the -upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only. -\code{"full"} draws a closed polygon around the area.} - \item{geom}{The geometric object to use to display the data for this layer. When using a \verb{stat_*()} function to construct a layer, the \code{geom} argument can be used to override the default coupling between stats and geoms. The @@ -231,6 +243,7 @@ a + geom_point(stat = "align", position = "stack", size = 8) # To turn off the alignment, the stat can be set to "identity" ggplot(df, aes(x, y, fill = g)) + geom_area(stat = "identity") + } \seealso{ \code{\link[=geom_bar]{geom_bar()}} for discrete intervals (bars), diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index 312357f40c..a09fd8b570 100644 --- a/man/geom_tile.Rd +++ b/man/geom_tile.Rd @@ -12,9 +12,9 @@ geom_raster( stat = "identity", position = "identity", ..., + interpolate = FALSE, hjust = 0.5, vjust = 0.5, - interpolate = FALSE, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -121,13 +121,13 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{interpolate}{If \code{TRUE} interpolate linearly, if \code{FALSE} +(the default) don't interpolate.} + \item{hjust, vjust}{horizontal and vertical justification of the grob. Each justification value should be a number between 0 and 1. Defaults to 0.5 for both, centering each pixel over its data location.} -\item{interpolate}{If \code{TRUE} interpolate linearly, if \code{FALSE} -(the default) don't interpolate.} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} From fa9f6d2683e745c4c0808cbba47316f755f5d7dc Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 17 Oct 2024 15:11:18 +0200 Subject: [PATCH 06/22] document --- R/boilerplates.R | 32 ++++++++++++++++++++++++++++++++ man/boilerplate.Rd | 44 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 man/boilerplate.Rd diff --git a/R/boilerplates.R b/R/boilerplates.R index 499144b53f..aac6927508 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -2,7 +2,39 @@ #' @include scale-type.R NULL +#' Produce boilerplate constructors +#' +#' The `boilerplate()` functions sets up a user-facing constructor for ggproto +#' classes. Currently, `boilerplate()` is implemented for `Geom` classes. +#' +#' @param x An object to setup a constructor for. +#' @param ... Name-value pairs to use as additional arguments in the +#' constructor. For layers, these are passed on to [`layer(params)`][layer()]. +#' @param checks Expressions evaluated before construction of the object. +#' Can be a `{}` block to include multiple expressions. +#' +#' @return A function #' @export +#' +#' @examples +#' # For testing purposes, a geom that returns grobs +#' GeomTest <- ggproto( +#' "GeomTest", Geom, +#' draw_group = function(..., grob = grid::pointsGrob()) { +#' return(grob) +#' } +#' ) +#' # Creating a constructor +#' geom_test <- boilerplate(GeomTest) +#' +#' # Note that `grob` is automatically an argument to the function +#' names(formals(geom_test)) +#' +#' # Use in a plot +#' set.seed(1234) +#' p <- ggplot(mtcars, aes(disp, mpg)) +#' p + geom_test() +#' p + geom_test(grob = grid::circleGrob()) boilerplate <- function(x, ...) { UseMethod("boilerplate") } diff --git a/man/boilerplate.Rd b/man/boilerplate.Rd new file mode 100644 index 0000000000..313c20d3de --- /dev/null +++ b/man/boilerplate.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/boilerplates.R +\name{boilerplate} +\alias{boilerplate} +\title{Produce boilerplate constructors} +\usage{ +boilerplate(x, ...) +} +\arguments{ +\item{x}{An object to setup a constructor for.} + +\item{...}{Name-value pairs to use as additional arguments in the +constructor. For layers, these are passed on to \code{\link[=layer]{layer(params)}}.} + +\item{checks}{Expressions evaluated before construction of the object. +Can be a \code{{}} block to include multiple expressions.} +} +\value{ +A function +} +\description{ +The \code{boilerplate()} functions sets up a user-facing constructor for ggproto +classes. Currently, \code{boilerplate()} is implemented for \code{Geom} classes. +} +\examples{ +# For testing purposes, a geom that returns grobs +GeomTest <- ggproto( + "GeomTest", Geom, + draw_group = function(..., grob = grid::pointsGrob()) { + return(grob) + } +) +# Creating a constructor +geom_test <- boilerplate(GeomTest) + +# Note that `grob` is automatically an argument to the function +names(formals(geom_test)) + +# Use in a plot +set.seed(1234) +p <- ggplot(mtcars, aes(disp, mpg)) +p + geom_test() +p + geom_test(grob = grid::circleGrob()) +} From 075ea86cb114db1a10684d525c84cbb4a68ea0eb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 17 Oct 2024 15:11:28 +0200 Subject: [PATCH 07/22] accept visual snapshots --- .../_snaps/geom-polygon/open-and-closed-munched-polygons.svg | 4 ++-- tests/testthat/_snaps/position-stack/area-stacking.svg | 4 ++-- .../testthat/_snaps/stat-align/align-two-areas-with-cliff.svg | 4 ++-- .../_snaps/stat-align/align-two-areas-with-pos-neg-y.svg | 4 ++-- tests/testthat/_snaps/stat-align/align-two-areas.svg | 4 ++-- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg index b970c9f317..113d1e45b1 100644 --- a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg +++ b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg @@ -32,8 +32,8 @@ colour - - + + closed open open and closed munched polygons diff --git a/tests/testthat/_snaps/position-stack/area-stacking.svg b/tests/testthat/_snaps/position-stack/area-stacking.svg index dea44df744..2629312a22 100644 --- a/tests/testthat/_snaps/position-stack/area-stacking.svg +++ b/tests/testthat/_snaps/position-stack/area-stacking.svg @@ -51,9 +51,9 @@ category - + - + A B Area stacking diff --git a/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg b/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg index abb667a819..2686f03715 100644 --- a/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg +++ b/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg @@ -53,9 +53,9 @@ g - + - + a b align two areas with cliff diff --git a/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg b/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg index 49be47a3ea..4cd5865e47 100644 --- a/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg +++ b/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg @@ -53,9 +53,9 @@ g - + - + a b align two areas with pos/neg y diff --git a/tests/testthat/_snaps/stat-align/align-two-areas.svg b/tests/testthat/_snaps/stat-align/align-two-areas.svg index 90186a513c..c123762358 100644 --- a/tests/testthat/_snaps/stat-align/align-two-areas.svg +++ b/tests/testthat/_snaps/stat-align/align-two-areas.svg @@ -53,9 +53,9 @@ g - + - + a b align two areas From ea572007317bc471e887bffba87e81c0d1e58cf3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 18 Oct 2024 09:05:47 +0200 Subject: [PATCH 08/22] Update R/boilerplates.R Thanks June! Co-authored-by: June Choe <52832839+yjunechoe@users.noreply.github.com> --- R/boilerplates.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index aac6927508..29a9101349 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -81,12 +81,12 @@ boilerplate.Geom <- function(x, ..., checks, env = caller_env()) { } # Build function formals - fmls <- list2( + fmls <- rlang::pairlist2( mapping = args$mapping, data = args$data, stat = args$stat %||% "identity", position = args$position %||% "identity", - `...` = quote(expr = ), + `...` = rlang::missing_arg(), !!!args[extra_args], na.rm = args$na.rm %||% FALSE, show.legend = args$show.legend %||% NA, From 6b44f331fb4d6e966c960d5cc496f1a073bab82a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 18 Oct 2024 09:35:37 +0200 Subject: [PATCH 09/22] Adopt advice from June --- R/boilerplates.R | 50 +++++++++++++++++++--------------------------- R/geom-density.R | 5 +++-- R/geom-function.R | 2 +- R/geom-raster.R | 6 +++--- R/geom-ribbon.R | 8 ++++---- man/boilerplate.Rd | 4 ++-- 6 files changed, 33 insertions(+), 42 deletions(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index 29a9101349..810b239a6e 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -10,8 +10,8 @@ NULL #' @param x An object to setup a constructor for. #' @param ... Name-value pairs to use as additional arguments in the #' constructor. For layers, these are passed on to [`layer(params)`][layer()]. -#' @param checks Expressions evaluated before construction of the object. -#' Can be a `{}` block to include multiple expressions. +#' @param checks A list of calls to be evaluated before construction of the +#' object, such as one constructed with [`exprs()`][rlang::exprs()]. #' #' @return A function #' @export @@ -40,7 +40,7 @@ boilerplate <- function(x, ...) { } #' @export -boilerplate.Geom <- function(x, ..., checks, env = caller_env()) { +boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) @@ -81,46 +81,36 @@ boilerplate.Geom <- function(x, ..., checks, env = caller_env()) { } # Build function formals - fmls <- rlang::pairlist2( + fmls <- pairlist2( mapping = args$mapping, data = args$data, stat = args$stat %||% "identity", position = args$position %||% "identity", - `...` = rlang::missing_arg(), + `...` = missing_arg(), !!!args[extra_args], na.rm = args$na.rm %||% FALSE, show.legend = args$show.legend %||% NA, inherit.aes = args$inherit.aes %||% TRUE ) - if (length(extra_args) > 0) { - extra_args <- paste0( - "\n ", extra_args, " = ", extra_args, ",", collapse = "" - ) - } + # Construct call for the 'layer(params)' argument + params <- exprs(!!!syms(c("na.rm", extra_args)), .named = TRUE) + params <- call2("list2", !!!params, quote(...)) - body <- paste0(" - layer( - data = data, - mapping = mapping, - stat = stat, - geom = \"", geom, "\", - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm,", - extra_args, " - ... - ) - ) - ") - body <- str2lang(body) + # Construct rest of 'layer()' call + layer_args <- syms(setdiff(fixed_fmls_names, c("...", "na.rm"))) + layer_args <- append(layer_args, list(geom = geom), after = 2) + layer_args <- exprs(!!!layer_args, params = !!params, .named = TRUE) + body <- call2("layer", !!!layer_args) - checks <- substitute(checks) + # Prepend any checks if (!missing(checks)) { - if (is_call(checks, "{")) { - checks[[1]] <- NULL + lang <- vapply(checks, is_call, logical(1)) + if (!all(lang)) { + cli::cli_abort( + "{.arg checks} must be a list of calls, such as one constructed \\ + with {.fn rlang::exprs}." + ) } body <- inject(quote(`{`(!!!c(checks, body)))) } diff --git a/R/geom-density.R b/R/geom-density.R index 3b8ee8a317..aa2a91ec77 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -74,7 +74,8 @@ GeomDensity <- ggproto( #' } geom_density <- boilerplate( GeomDensity, stat = "density", - checks = { + checks = exprs( outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - } + ) ) + diff --git a/R/geom-function.R b/R/geom-function.R index b2ba6df095..179bcc0dca 100644 --- a/R/geom-function.R +++ b/R/geom-function.R @@ -87,5 +87,5 @@ GeomFunction <- ggproto("GeomFunction", GeomPath, #' @export geom_function <- boilerplate( GeomFunction, stat = "function", - checks = {data <- data %||% ensure_nonempty_data} + checks = exprs(data <- data %||% ensure_nonempty_data) ) diff --git a/R/geom-raster.R b/R/geom-raster.R index 6c4a3b92aa..aeaf821692 100644 --- a/R/geom-raster.R +++ b/R/geom-raster.R @@ -98,8 +98,8 @@ GeomRaster <- ggproto("GeomRaster", Geom, #' (the default) don't interpolate. geom_raster <- boilerplate( GeomRaster, - checks = { - check_number_decimal(hjust) + checks = exprs( + check_number_decimal(hjust), check_number_decimal(vjust) - } + ) ) diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index c4e41223d1..9062432b20 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -272,9 +272,9 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, #' geom_ribbon <- boilerplate( GeomRibbon, orientation = NA, - checks = { + checks = exprs( outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - } + ) ) #' @rdname geom_ribbon @@ -282,7 +282,7 @@ geom_ribbon <- boilerplate( geom_area <- boilerplate( GeomArea, stat = "align", position = "stack", orientation = NA, outline.type = "upper", - checks = { + checks = exprs( outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) - } + ) ) diff --git a/man/boilerplate.Rd b/man/boilerplate.Rd index 313c20d3de..040f834f51 100644 --- a/man/boilerplate.Rd +++ b/man/boilerplate.Rd @@ -12,8 +12,8 @@ boilerplate(x, ...) \item{...}{Name-value pairs to use as additional arguments in the constructor. For layers, these are passed on to \code{\link[=layer]{layer(params)}}.} -\item{checks}{Expressions evaluated before construction of the object. -Can be a \code{{}} block to include multiple expressions.} +\item{checks}{A list of calls to be evaluated before construction of the +object, such as one constructed with \code{\link[rlang:defusing-advanced]{exprs()}}.} } \value{ A function From 6e71e1a527e013c81ce123c57b206ee63fe0038c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 18 Oct 2024 10:03:00 +0200 Subject: [PATCH 10/22] docfix --- R/boilerplates.R | 3 +++ man/boilerplate.Rd | 6 ++++++ 2 files changed, 9 insertions(+) diff --git a/R/boilerplates.R b/R/boilerplates.R index 810b239a6e..a909ea88f5 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -12,9 +12,11 @@ NULL #' constructor. For layers, these are passed on to [`layer(params)`][layer()]. #' @param checks A list of calls to be evaluated before construction of the #' object, such as one constructed with [`exprs()`][rlang::exprs()]. +#' @param env An environment to search for the object. #' #' @return A function #' @export +#' @keywords internal #' #' @examples #' # For testing purposes, a geom that returns grobs @@ -40,6 +42,7 @@ boilerplate <- function(x, ...) { } #' @export +#' @rdname boilerplate boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) { # Check that we can independently find the geom diff --git a/man/boilerplate.Rd b/man/boilerplate.Rd index 040f834f51..f703ece6e5 100644 --- a/man/boilerplate.Rd +++ b/man/boilerplate.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/boilerplates.R \name{boilerplate} \alias{boilerplate} +\alias{boilerplate.Geom} \title{Produce boilerplate constructors} \usage{ boilerplate(x, ...) + +\method{boilerplate}{Geom}(x, ..., checks = NULL, env = caller_env()) } \arguments{ \item{x}{An object to setup a constructor for.} @@ -14,6 +17,8 @@ constructor. For layers, these are passed on to \code{\link[=layer]{layer(params \item{checks}{A list of calls to be evaluated before construction of the object, such as one constructed with \code{\link[rlang:defusing-advanced]{exprs()}}.} + +\item{env}{An environment to search for the object.} } \value{ A function @@ -42,3 +47,4 @@ p <- ggplot(mtcars, aes(disp, mpg)) p + geom_test() p + geom_test(grob = grid::circleGrob()) } +\keyword{internal} From d488de8341220cce772cc4146c25ffc72be3f857 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 18 Oct 2024 21:36:08 +0200 Subject: [PATCH 11/22] Apply suggestions from code review Co-authored-by: June Choe <52832839+yjunechoe@users.noreply.github.com> --- R/boilerplates.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index a909ea88f5..111786a722 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -115,8 +115,8 @@ boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) { with {.fn rlang::exprs}." ) } - body <- inject(quote(`{`(!!!c(checks, body)))) + body <- call2("{", !!!checks, body) } - new_function(fmls, body) + new_function(fmls, body, env = caller_env()) } From e6db72d6426b02b869622eb4ba4839c31391d0c4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 21 Oct 2024 11:17:10 +0200 Subject: [PATCH 12/22] ensure `list2()` can be found --- R/boilerplates.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/boilerplates.R b/R/boilerplates.R index 111786a722..71e5318929 100644 --- a/R/boilerplates.R +++ b/R/boilerplates.R @@ -118,5 +118,8 @@ boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) { body <- call2("{", !!!checks, body) } - new_function(fmls, body, env = caller_env()) + # We encapsulate rlang::list2 + new_env <- new_environment(list(list2 = list2), env) + + new_function(fmls, body, env = new_env) } From 8c33474bc286fd41164921db6e2ef42d6bbd1359 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 22 Oct 2024 11:28:44 +0200 Subject: [PATCH 13/22] rename `boilerplate()` to `make_constructor()` --- DESCRIPTION | 2 +- NAMESPACE | 4 ++-- R/geom-bar.R | 5 ++++- R/geom-bin2d.R | 2 +- R/geom-col.R | 2 +- R/geom-contour.R | 4 ++-- R/geom-count.R | 2 +- R/geom-crossbar.R | 2 +- R/geom-curve.R | 2 +- R/geom-density.R | 2 +- R/geom-errorbar.R | 2 +- R/geom-errorbarh.R | 2 +- R/geom-function.R | 2 +- R/geom-hex.R | 2 +- R/geom-histogram.R | 2 +- R/geom-linerange.R | 2 +- R/geom-path.R | 6 +++--- R/geom-point.R | 2 +- R/geom-pointrange.R | 2 +- R/geom-polygon.R | 4 ++-- R/geom-quantile.R | 2 +- R/geom-raster.R | 2 +- R/geom-rect.R | 2 +- R/geom-ribbon.R | 4 ++-- R/geom-rug.R | 2 +- R/geom-segment.R | 2 +- R/geom-spoke.R | 2 +- R/geom-tile.R | 2 +- R/geom-violin.R | 2 +- R/{boilerplates.R => make-constructor.R} | 15 ++++++++------- man/{boilerplate.Rd => make_constructor.Rd} | 19 ++++++++++--------- 31 files changed, 56 insertions(+), 51 deletions(-) rename R/{boilerplates.R => make-constructor.R} (90%) rename man/{boilerplate.Rd => make_constructor.Rd} (69%) diff --git a/DESCRIPTION b/DESCRIPTION index fad521e72d..25a76067fb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -98,7 +98,7 @@ Collate: 'annotation-logticks.R' 'scale-type.R' 'layer.R' - 'boilerplates.R' + 'make-constructor.R' 'geom-polygon.R' 'geom-map.R' 'annotation-map.R' diff --git a/NAMESPACE b/NAMESPACE index 3b0b353c06..236cba49c3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,7 +16,6 @@ S3method(as.data.frame,mapped_discrete) S3method(as.list,ggproto) S3method(autolayer,default) S3method(autoplot,default) -S3method(boilerplate,Geom) S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(element_grob,element_blank) @@ -92,6 +91,7 @@ S3method(limits,character) S3method(limits,factor) S3method(limits,numeric) S3method(makeContext,dotstackGrob) +S3method(make_constructor,Geom) S3method(merge_element,default) S3method(merge_element,element) S3method(merge_element,element_blank) @@ -298,7 +298,6 @@ export(autolayer) export(autoplot) export(benchplot) export(binned_scale) -export(boilerplate) export(borders) export(calc_element) export(check_device) @@ -492,6 +491,7 @@ export(layer_grob) export(layer_scales) export(layer_sf) export(lims) +export(make_constructor) export(map_data) export(margin) export(max_height) diff --git a/R/geom-bar.R b/R/geom-bar.R index 2d877ce8a3..2746b5db17 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -136,4 +136,7 @@ GeomBar <- ggproto("GeomBar", GeomRect, #' ggplot(df, aes(x, y)) + geom_col(just = 0.5) #' # Columns begin on the first day of the month #' ggplot(df, aes(x, y)) + geom_col(just = 1) -geom_bar <- boilerplate(GeomBar, stat = "count", position = "stack", just = 0.5) +geom_bar <- make_constructor( + GeomBar, + stat = "count", position = "stack", just = 0.5 +) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 4313b28471..c235ddfde0 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -31,7 +31,7 @@ NULL #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) -geom_bin_2d <- boilerplate(GeomTile, stat = "bin2d") +geom_bin_2d <- make_constructor(GeomTile, stat = "bin2d") #' @export #' @rdname geom_bin_2d diff --git a/R/geom-col.R b/R/geom-col.R index f779fb6e3a..cb752986cd 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,6 +1,6 @@ #' @export #' @rdname geom_bar -geom_col <- boilerplate(GeomBar, position = "stack", just = 0.5) +geom_col <- make_constructor(GeomBar, position = "stack", just = 0.5) #' @rdname ggplot2-ggproto #' @format NULL diff --git a/R/geom-contour.R b/R/geom-contour.R index 5913d558bf..14a4b7c40e 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -83,7 +83,7 @@ GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) #' v + geom_raster(aes(fill = density)) + #' geom_contour(colour = "white") #' } -geom_contour <- boilerplate( +geom_contour <- make_constructor( GeomContour, stat = "contour", # Passed to contour stat: bins = NULL, binwidth = NULL, breaks = NULL @@ -91,7 +91,7 @@ geom_contour <- boilerplate( #' @rdname geom_contour #' @export -geom_contour_filled <- boilerplate( +geom_contour_filled <- make_constructor( GeomContourFilled, stat = "contour_filled", # Passed to contour_filled stat: bins = NULL, binwidth = NULL, breaks = NULL diff --git a/R/geom-count.R b/R/geom-count.R index a3c6de4cc2..32ae897c9f 100644 --- a/R/geom-count.R +++ b/R/geom-count.R @@ -46,4 +46,4 @@ NULL #' scale_size_area(max_size = 10) #' d + geom_count(aes(size = after_stat(prop), group = clarity)) + #' scale_size_area(max_size = 10) -geom_count <- boilerplate(GeomPoint, stat = "sum") +geom_count <- make_constructor(GeomPoint, stat = "sum") diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 288f5396c5..43092b748d 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -93,4 +93,4 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, #' @export #' @rdname geom_linerange -geom_crossbar <- boilerplate(GeomCrossbar) +geom_crossbar <- make_constructor(GeomCrossbar) diff --git a/R/geom-curve.R b/R/geom-curve.R index 2ddac968fc..e64f937bbb 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -47,4 +47,4 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, #' @inheritParams grid::curveGrob #' @export #' @rdname geom_segment -geom_curve <- boilerplate(GeomCurve) +geom_curve <- make_constructor(GeomCurve) diff --git a/R/geom-density.R b/R/geom-density.R index aa2a91ec77..460996c197 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -72,7 +72,7 @@ GeomDensity <- ggproto( #' ggplot(diamonds, aes(carat, after_stat(count), fill = cut)) + #' geom_density(position = "fill") #' } -geom_density <- boilerplate( +geom_density <- make_constructor( GeomDensity, stat = "density", checks = exprs( outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index 05deae5886..fd731eae47 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -58,4 +58,4 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, #' @export #' @rdname geom_linerange -geom_errorbar <- boilerplate(GeomErrorbar, orientation = NA) +geom_errorbar <- make_constructor(GeomErrorbar, orientation = NA) diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R index 96e5cdc412..be86454b68 100644 --- a/R/geom-errorbarh.R +++ b/R/geom-errorbarh.R @@ -69,4 +69,4 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, #' p + #' geom_point() + #' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) -geom_errorbarh <- boilerplate(GeomErrorbarh) +geom_errorbarh <- make_constructor(GeomErrorbarh) diff --git a/R/geom-function.R b/R/geom-function.R index 179bcc0dca..94e5ce2aaa 100644 --- a/R/geom-function.R +++ b/R/geom-function.R @@ -85,7 +85,7 @@ GeomFunction <- ggproto("GeomFunction", GeomPath, #' geom_function(fun = dnorm, colour = "red", xlim=c(-7, 7)) #' #' @export -geom_function <- boilerplate( +geom_function <- make_constructor( GeomFunction, stat = "function", checks = exprs(data <- data %||% ensure_nonempty_data) ) diff --git a/R/geom-hex.R b/R/geom-hex.R index 0f43a90ac7..b7e7a962c8 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -100,4 +100,4 @@ GeomHex <- ggproto("GeomHex", Geom, #' d + geom_hex(binwidth = c(1, 1000)) #' d + geom_hex(binwidth = c(.1, 500)) #' } -geom_hex <- boilerplate(GeomHex, stat = 'binhex') +geom_hex <- make_constructor(GeomHex, stat = 'binhex') diff --git a/R/geom-histogram.R b/R/geom-histogram.R index 15c8064264..9ec92e9f58 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -115,7 +115,7 @@ #' ggplot(economics_long, aes(value)) + #' facet_wrap(~variable, scales = 'free_x') + #' geom_histogram(binwidth = function(x) 2 * IQR(x) / (length(x)^(1/3))) -geom_histogram <- boilerplate( +geom_histogram <- make_constructor( GeomBar, stat = "bin", position = "stack", # Passed to bin stat: binwidth = NULL, bins = NULL, orientation = NA diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 434078bda0..af036638ae 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -109,4 +109,4 @@ GeomLinerange <- ggproto( #' aes(ymin = lower, ymax = upper), #' position = position_dodge2(width = 0.5, padding = 0.5) #' ) -geom_linerange <- boilerplate(GeomLinerange, orientation = NA) +geom_linerange <- make_constructor(GeomLinerange, orientation = NA) diff --git a/R/geom-path.R b/R/geom-path.R index ad1bbaa890..94e331f329 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -266,18 +266,18 @@ GeomStep <- ggproto( #' # But this doesn't #' should_stop(p + geom_line(aes(colour = x), linetype=2)) #' } -geom_path <- boilerplate(GeomPath) +geom_path <- make_constructor(GeomPath) #' @export #' @rdname geom_path -geom_line <- boilerplate(GeomLine, orientation = NA) +geom_line <- make_constructor(GeomLine, orientation = NA) #' @param direction direction of stairs: 'vh' for vertical then horizontal, #' 'hv' for horizontal then vertical, or 'mid' for step half-way between #' adjacent x-values. #' @export #' @rdname geom_path -geom_step <- boilerplate(GeomStep, orientation = NA) +geom_step <- make_constructor(GeomStep, orientation = NA) # Trim false values from left and right: keep all values from # first TRUE to last TRUE diff --git a/R/geom-point.R b/R/geom-point.R index d63bd0fede..962b6640b8 100644 --- a/R/geom-point.R +++ b/R/geom-point.R @@ -142,7 +142,7 @@ GeomPoint <- ggproto("GeomPoint", Geom, #' ggplot(mtcars2, aes(wt, mpg)) + #' geom_point(na.rm = TRUE) #' } -geom_point <- boilerplate(GeomPoint) +geom_point <- make_constructor(GeomPoint) #' Translating shape strings #' diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index 17a319b65c..4a1d439f75 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -47,4 +47,4 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, #' @export #' @rdname geom_linerange -geom_pointrange <- boilerplate(GeomPointrange, orientation = NA) +geom_pointrange <- make_constructor(GeomPointrange, orientation = NA) diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 9ee85a1c7b..08c44fc866 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -1,4 +1,4 @@ -#' @include boilerplates.R +#' @include make-constructor.R NULL #' @rdname ggplot2-ggproto @@ -176,7 +176,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, #' geom_polygon(aes(fill = value, group = id, subgroup = subid)) #' p #' } -geom_polygon <- boilerplate(GeomPolygon) +geom_polygon <- make_constructor(GeomPolygon) # Assigning pathGrob in .onLoad ensures that packages that subclass GeomPolygon # do not install with error `possible error in 'pathGrob(munched$x, munched$y, ': diff --git a/R/geom-quantile.R b/R/geom-quantile.R index 2e12248ee5..bd32cc93a8 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -44,4 +44,4 @@ GeomQuantile <- ggproto( #' #' # Set aesthetics to fixed value #' m + geom_quantile(colour = "red", linewidth = 2, alpha = 0.5) -geom_quantile <- boilerplate(GeomQuantile, stat = "quantile") +geom_quantile <- make_constructor(GeomQuantile, stat = "quantile") diff --git a/R/geom-raster.R b/R/geom-raster.R index aeaf821692..f0e7ff1c2c 100644 --- a/R/geom-raster.R +++ b/R/geom-raster.R @@ -96,7 +96,7 @@ GeomRaster <- ggproto("GeomRaster", Geom, #' for both, centering each pixel over its data location. #' @param interpolate If `TRUE` interpolate linearly, if `FALSE` #' (the default) don't interpolate. -geom_raster <- boilerplate( +geom_raster <- make_constructor( GeomRaster, checks = exprs( check_number_decimal(hjust), diff --git a/R/geom-rect.R b/R/geom-rect.R index 5157597017..d1065d0731 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -86,7 +86,7 @@ GeomRect <- ggproto("GeomRect", Geom, #' @export #' @rdname geom_tile -geom_rect <- boilerplate(GeomRect) +geom_rect <- make_constructor(GeomRect) resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL, fun, type) { diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index 9062432b20..79b9c799d9 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -270,7 +270,7 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, #' ggplot(df, aes(x, y, fill = g)) + #' geom_area(stat = "identity") #' -geom_ribbon <- boilerplate( +geom_ribbon <- make_constructor( GeomRibbon, orientation = NA, checks = exprs( outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) @@ -279,7 +279,7 @@ geom_ribbon <- boilerplate( #' @rdname geom_ribbon #' @export -geom_area <- boilerplate( +geom_area <- make_constructor( GeomArea, stat = "align", position = "stack", orientation = NA, outline.type = "upper", checks = exprs( diff --git a/R/geom-rug.R b/R/geom-rug.R index 3f4331d4c8..2c36e33a58 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -181,4 +181,4 @@ GeomRug <- ggproto("GeomRug", Geom, #' p + #' geom_rug(length = unit(0.05, "npc")) + #' scale_y_continuous(expand = c(0.1, 0.1)) -geom_rug <- boilerplate(GeomRug) +geom_rug <- make_constructor(GeomRug) diff --git a/R/geom-segment.R b/R/geom-segment.R index 026ac157a3..52c3201d02 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -128,4 +128,4 @@ GeomSegment <- ggproto("GeomSegment", Geom, #' #' ggplot(counts, aes(x, Freq)) + #' geom_segment(aes(xend = x, yend = 0), linewidth = 10, lineend = "butt") -geom_segment <- boilerplate(GeomSegment) +geom_segment <- make_constructor(GeomSegment) diff --git a/R/geom-spoke.R b/R/geom-spoke.R index 6ed4e89880..26d6422390 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -40,7 +40,7 @@ GeomSpoke <- ggproto( #' ggplot(df, aes(x, y)) + #' geom_point() + #' geom_spoke(aes(angle = angle, radius = speed)) -geom_spoke <- boilerplate(GeomSpoke) +geom_spoke <- make_constructor(GeomSpoke) #' @export #' @rdname geom_spoke diff --git a/R/geom-tile.R b/R/geom-tile.R index c441e5bd52..61fc5eb3a8 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -117,4 +117,4 @@ GeomTile <- ggproto("GeomTile", GeomRect, #' position = "identity" #' ) #' } -geom_tile <- boilerplate(GeomTile) +geom_tile <- make_constructor(GeomTile) diff --git a/R/geom-violin.R b/R/geom-violin.R index 16bdfaef1b..e98b1d5a31 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -180,7 +180,7 @@ GeomViolin <- ggproto("GeomViolin", Geom, #' geom_violin(aes(group = cut_width(year, 10)), scale = "width") #' } #' } -geom_violin <- boilerplate( +geom_violin <- make_constructor( GeomViolin, stat = "ydensity", position = "dodge", # arguments passed to ydensity stat: trim = TRUE, bounds = c(-Inf, Inf), scale = "area" diff --git a/R/boilerplates.R b/R/make-constructor.R similarity index 90% rename from R/boilerplates.R rename to R/make-constructor.R index 71e5318929..434027e122 100644 --- a/R/boilerplates.R +++ b/R/make-constructor.R @@ -4,8 +4,9 @@ NULL #' Produce boilerplate constructors #' -#' The `boilerplate()` functions sets up a user-facing constructor for ggproto -#' classes. Currently, `boilerplate()` is implemented for `Geom` classes. +#' The `make_constructor()` functions sets up a user-facing constructor for +#' ggproto classes. Currently, `make_constructor()` is implemented for +#' `Geom` classes. #' #' @param x An object to setup a constructor for. #' @param ... Name-value pairs to use as additional arguments in the @@ -27,7 +28,7 @@ NULL #' } #' ) #' # Creating a constructor -#' geom_test <- boilerplate(GeomTest) +#' geom_test <- make_constructor(GeomTest) #' #' # Note that `grob` is automatically an argument to the function #' names(formals(geom_test)) @@ -37,13 +38,13 @@ NULL #' p <- ggplot(mtcars, aes(disp, mpg)) #' p + geom_test() #' p + geom_test(grob = grid::circleGrob()) -boilerplate <- function(x, ...) { - UseMethod("boilerplate") +make_constructor <- function(x, ...) { + UseMethod("make_constructor") } #' @export -#' @rdname boilerplate -boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) { +#' @rdname make_constructor +make_constructor.Geom <- function(x, ..., checks = NULL, env = caller_env()) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) diff --git a/man/boilerplate.Rd b/man/make_constructor.Rd similarity index 69% rename from man/boilerplate.Rd rename to man/make_constructor.Rd index f703ece6e5..2fb9bbc1dd 100644 --- a/man/boilerplate.Rd +++ b/man/make_constructor.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/boilerplates.R -\name{boilerplate} -\alias{boilerplate} -\alias{boilerplate.Geom} +% Please edit documentation in R/make-constructor.R +\name{make_constructor} +\alias{make_constructor} +\alias{make_constructor.Geom} \title{Produce boilerplate constructors} \usage{ -boilerplate(x, ...) +make_constructor(x, ...) -\method{boilerplate}{Geom}(x, ..., checks = NULL, env = caller_env()) +\method{make_constructor}{Geom}(x, ..., checks = NULL, env = caller_env()) } \arguments{ \item{x}{An object to setup a constructor for.} @@ -24,8 +24,9 @@ object, such as one constructed with \code{\link[rlang:defusing-advanced]{exprs( A function } \description{ -The \code{boilerplate()} functions sets up a user-facing constructor for ggproto -classes. Currently, \code{boilerplate()} is implemented for \code{Geom} classes. +The \code{make_constructor()} functions sets up a user-facing constructor for +ggproto classes. Currently, \code{make_constructor()} is implemented for +\code{Geom} classes. } \examples{ # For testing purposes, a geom that returns grobs @@ -36,7 +37,7 @@ GeomTest <- ggproto( } ) # Creating a constructor -geom_test <- boilerplate(GeomTest) +geom_test <- make_constructor(GeomTest) # Note that `grob` is automatically an argument to the function names(formals(geom_test)) From c11c5ede2caa68caecd1d4cbebdd2c6bf575b988 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 22 Oct 2024 12:05:15 +0200 Subject: [PATCH 14/22] give body pretty braces --- R/make-constructor.R | 6 +++--- man/make_constructor.Rd | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/make-constructor.R b/R/make-constructor.R index 434027e122..1ae7e4b90e 100644 --- a/R/make-constructor.R +++ b/R/make-constructor.R @@ -44,7 +44,7 @@ make_constructor <- function(x, ...) { #' @export #' @rdname make_constructor -make_constructor.Geom <- function(x, ..., checks = NULL, env = caller_env()) { +make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) @@ -108,7 +108,7 @@ make_constructor.Geom <- function(x, ..., checks = NULL, env = caller_env()) { body <- call2("layer", !!!layer_args) # Prepend any checks - if (!missing(checks)) { + if (length(exprs) > 0) { lang <- vapply(checks, is_call, logical(1)) if (!all(lang)) { cli::cli_abort( @@ -116,8 +116,8 @@ make_constructor.Geom <- function(x, ..., checks = NULL, env = caller_env()) { with {.fn rlang::exprs}." ) } - body <- call2("{", !!!checks, body) } + body <- call2("{", !!!checks, body) # We encapsulate rlang::list2 new_env <- new_environment(list(list2 = list2), env) diff --git a/man/make_constructor.Rd b/man/make_constructor.Rd index 2fb9bbc1dd..7b162c98f5 100644 --- a/man/make_constructor.Rd +++ b/man/make_constructor.Rd @@ -7,7 +7,7 @@ \usage{ make_constructor(x, ...) -\method{make_constructor}{Geom}(x, ..., checks = NULL, env = caller_env()) +\method{make_constructor}{Geom}(x, ..., checks = exprs(), env = caller_env()) } \arguments{ \item{x}{An object to setup a constructor for.} From 44cf2dc2a229234fab820541a377860d08cd8f4b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 22 Oct 2024 13:08:34 +0200 Subject: [PATCH 15/22] purge unused parameters in `stat_bin()` --- R/stat-bin.R | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/R/stat-bin.R b/R/stat-bin.R index c085f818a2..5252f03d01 100644 --- a/R/stat-bin.R +++ b/R/stat-bin.R @@ -139,10 +139,7 @@ StatBin <- ggproto("StatBin", Stat, compute_group = function(data, scales, binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, closed = c("right", "left"), pad = FALSE, - 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) { + breaks = NULL, flipped_aes = FALSE) { x <- flipped_names(flipped_aes)$x if (!is.null(breaks)) { if (is.function(breaks)) { From cd54bfb5211cf3f7c50757a5438d1957d4fda817 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 13:45:01 +0100 Subject: [PATCH 16/22] add Stat method for `make_constructor()` --- NAMESPACE | 1 + R/make-constructor.R | 88 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 88 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 236cba49c3..00789368c0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -92,6 +92,7 @@ S3method(limits,factor) S3method(limits,numeric) S3method(makeContext,dotstackGrob) S3method(make_constructor,Geom) +S3method(make_constructor,Stat) S3method(merge_element,default) S3method(merge_element,element) S3method(merge_element,element_blank) diff --git a/R/make-constructor.R b/R/make-constructor.R index 1ae7e4b90e..15bbe3d683 100644 --- a/R/make-constructor.R +++ b/R/make-constructor.R @@ -75,6 +75,7 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) args[param] <- draw_args[param] } } + extra_args <- intersect(extra_args, names(args)) missing_params <- setdiff(missing_params, names(args)) if (length(missing_params) > 0) { cli::cli_warn( @@ -122,5 +123,90 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) # We encapsulate rlang::list2 new_env <- new_environment(list(list2 = list2), env) - new_function(fmls, body, env = new_env) + new_function(fmls, body, new_env) } + +#' @export +#' @rdname make_constructor +make_constructor.Stat <- function(x, ..., checks = exprs(), env = caller_env()) { + # Check that we can independently find the stat + stat <- gsub("^stat_", "", snake_class(x)) + check_subclass(stat, "Stat", env = env) + + # Split additional arguments into required and extra ones + args <- enexprs(...) + fixed_fmls_names <- c("mapping", "data", "geom", "position", "...", + "na.rm", "show.legend", "inherit.aes") + extra_args <- setdiff(names(args), fixed_fmls_names) + if ("stat" %in% extra_args) { + cli::cli_abort("{.arg stat} is a reversed argument.") + } + + known_params <- + unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics())) + missing_params <- setdiff(x$parameters(), known_params) + + # Fill in missing parameters from the compute methods + if (length(missing_params) > 0) { + compute_args <- ggproto_formals(x$compute_panel) + if ("..." %in% names(compute_args)) { + compute_args <- ggproto_formals(x$compute_group) + } + params <- intersect(missing_params, names(compute_args)) + extra_args <- c(extra_args, params) + for (param in params) { + if (!identical(compute_args[[param]], missing_arg())) { + args[param] <- compute_args[param] + } + } + extra_args <- intersect(extra_args, names(args)) + missing_params <- setdiff(missing_params, names(args)) + if (length(missing_params) > 0) { + cli::cli_warn( + "In {.fn stat_{stat}}: please consider providing default values for: \\ + {missing_params}." + ) + } + } + + # Build function formals + fmls <- pairlist2( + mapping = args$mapping, + data = args$data, + geom = args$geom %||% cli::cli_abort("{.arg geom} is required."), + position = args$position %||% "identity", + `...` = missing_arg(), + !!!args[extra_args], + na.rm = args$na.rm %||% FALSE, + show.legend = args$show.legend %||% NA, + inherit.aes = args$inherit.aes %||% TRUE + ) + + # Construct params for the `layer(params)` argument + params <- exprs(!!!syms(c("na.rm", extra_args)), .named = TRUE) + params <- call2("list2", !!!params, quote(...)) + + # Construct rest of `layer()` call + layer_args <- syms(setdiff(fixed_fmls_names, c("...", "na.rm"))) + layer_args <- append(layer_args, list(stat = stat), after = 3) + layer_args <- exprs(!!!layer_args, params = !!params, .named = TRUE) + body <- call2("layer", !!!layer_args) + + # Prepend any checks + if (length(exprs) > 0) { + lang <- vapply(checks, is_call, logical(1)) + if (!all(lang)) { + cli::cli_abort( + "{.arg checks} must be a list of calls, such as one constructed \\ + with {.fn rlang::exprs}." + ) + } + } + body <- call2("{", !!!checks, body) + + # We encapsulate rlang::list2 + new_env <- new_environment(list(list2 = list2), env) + + new_function(fmls, body, new_env) +} + From 4dd78b5c8ed861d0315613a2e641ed4faf55d4bd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 14:08:54 +0100 Subject: [PATCH 17/22] use the `make_constructor()` for Stats --- R/stat-align.R | 37 +++----- R/stat-bin.R | 137 +++++++++++----------------- R/stat-bin2d.R | 69 +++++--------- R/stat-binhex.R | 57 ++++-------- R/stat-boxplot.R | 67 +++++--------- R/stat-contour.R | 124 ++++++++----------------- R/stat-count.R | 58 ++++-------- R/stat-density-2d.R | 190 ++++++++++++++------------------------- R/stat-density.R | 114 +++++++++-------------- R/stat-ecdf.R | 123 +++++++++++-------------- R/stat-ellipse.R | 56 ++++-------- R/stat-function.R | 69 +++++--------- R/stat-identity.R | 41 +++------ R/stat-qq-line.R | 56 +++--------- R/stat-qq.R | 84 +++++++---------- R/stat-quantilemethods.R | 57 ++++-------- R/stat-sf-coordinates.R | 115 ++++++++++-------------- R/stat-sf.R | 18 +--- R/stat-smooth.R | 142 +++++++++++------------------ R/stat-sum.R | 42 +++------ R/stat-summary-2d.R | 116 +++++++++--------------- R/stat-summary-hex.R | 44 ++------- R/stat-unique.R | 38 +++----- R/stat-ydensity.R | 121 +++++++++---------------- 24 files changed, 668 insertions(+), 1307 deletions(-) diff --git a/R/stat-align.R b/R/stat-align.R index 3187ca28c0..85eb598c53 100644 --- a/R/stat-align.R +++ b/R/stat-align.R @@ -1,33 +1,9 @@ -#' @inheritParams layer -#' @inheritParams geom_point -#' @export -#' @rdname geom_ribbon -stat_align <- function(mapping = NULL, data = NULL, - geom = "area", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatAlign, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatAlign <- ggproto("StatAlign", Stat, +StatAlign <- ggproto( + "StatAlign", Stat, extra_params = c("na.rm", "orientation"), required_aes = c("x", "y"), @@ -99,3 +75,12 @@ StatAlign <- ggproto("StatAlign", Stat, flip_data(data_aligned, flipped_aes) } ) + +#' @inheritParams layer +#' @inheritParams geom_point +#' @export +#' @rdname geom_ribbon +stat_align <- make_constructor( + StatAlign, geom = "area", + exclude = c("unique_loc", "adjust") +) diff --git a/R/stat-bin.R b/R/stat-bin.R index 5252f03d01..11e1fe34ab 100644 --- a/R/stat-bin.R +++ b/R/stat-bin.R @@ -1,92 +1,9 @@ -#' @param binwidth The width of the bins. Can be specified as a numeric value -#' or as a function that takes x after scale transformation as input and -#' returns a single numeric value. When specifying a function along with a -#' grouping structure, the function will be called once per group. -#' The default is to use the number of bins in `bins`, -#' covering the range of the data. You should always override -#' this value, exploring multiple widths to find the best to illustrate the -#' stories in your data. -#' -#' The bin width of a date variable is the number of days in each time; the -#' bin width of a time variable is the number of seconds. -#' @param bins Number of bins. Overridden by `binwidth`. Defaults to 30. -#' @param center,boundary bin position specifiers. Only one, `center` or -#' `boundary`, may be specified for a single plot. `center` specifies the -#' center of one of the bins. `boundary` specifies the boundary between two -#' bins. Note that if either is above or below the range of the data, things -#' will be shifted by the appropriate integer multiple of `binwidth`. -#' For example, to center on integers use `binwidth = 1` and `center = 0`, even -#' if `0` is outside the range of the data. Alternatively, this same alignment -#' can be specified with `binwidth = 1` and `boundary = 0.5`, even if `0.5` is -#' outside the range of the data. -#' @param breaks Alternatively, you can supply a numeric vector giving -#' the bin boundaries. Overrides `binwidth`, `bins`, `center`, -#' and `boundary`. Can also be a function that takes group-wise values as input and returns bin boundaries. -#' @param closed One of `"right"` or `"left"` indicating whether right -#' or left edges of bins are included in the bin. -#' @param pad If `TRUE`, adds empty bins at either end of x. This ensures -#' frequency polygons touch 0. Defaults to `FALSE`. -#' @eval rd_computed_vars( -#' count = "number of points in bin.", -#' density = "density of points in bin, scaled to integrate to 1.", -#' ncount = "count, scaled to a maximum of 1.", -#' ndensity = "density, scaled to a maximum of 1.", -#' width = "widths of bins." -#' ) -#' -#' @section Dropped variables: -#' \describe{ -#' \item{`weight`}{After binning, weights of individual data points (if supplied) are no longer available.} -#' } -#' -#' @seealso [stat_count()], which counts the number of cases at each x -#' position, without binning. It is suitable for both discrete and continuous -#' x data, whereas `stat_bin()` is suitable only for continuous x data. -#' @export -#' @rdname geom_histogram -stat_bin <- function(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, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = StatBin, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - binwidth = binwidth, - bins = bins, - center = center, - boundary = boundary, - breaks = breaks, - closed = closed, - pad = pad, - na.rm = na.rm, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatBin <- ggproto("StatBin", Stat, +StatBin <- ggproto( + "StatBin", Stat, setup_params = function(self, data, params) { params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) @@ -171,3 +88,53 @@ StatBin <- ggproto("StatBin", Stat, dropped_aes = "weight" # after statistical transformation, weights are no longer available ) +#' @param binwidth The width of the bins. Can be specified as a numeric value +#' or as a function that takes x after scale transformation as input and +#' returns a single numeric value. When specifying a function along with a +#' grouping structure, the function will be called once per group. +#' The default is to use the number of bins in `bins`, +#' covering the range of the data. You should always override +#' this value, exploring multiple widths to find the best to illustrate the +#' stories in your data. +#' +#' The bin width of a date variable is the number of days in each time; the +#' bin width of a time variable is the number of seconds. +#' @param bins Number of bins. Overridden by `binwidth`. Defaults to 30. +#' @param center,boundary bin position specifiers. Only one, `center` or +#' `boundary`, may be specified for a single plot. `center` specifies the +#' center of one of the bins. `boundary` specifies the boundary between two +#' bins. Note that if either is above or below the range of the data, things +#' will be shifted by the appropriate integer multiple of `binwidth`. +#' For example, to center on integers use `binwidth = 1` and `center = 0`, even +#' if `0` is outside the range of the data. Alternatively, this same alignment +#' can be specified with `binwidth = 1` and `boundary = 0.5`, even if `0.5` is +#' outside the range of the data. +#' @param breaks Alternatively, you can supply a numeric vector giving +#' the bin boundaries. Overrides `binwidth`, `bins`, `center`, +#' and `boundary`. Can also be a function that takes group-wise values as input and returns bin boundaries. +#' @param closed One of `"right"` or `"left"` indicating whether right +#' or left edges of bins are included in the bin. +#' @param pad If `TRUE`, adds empty bins at either end of x. This ensures +#' frequency polygons touch 0. Defaults to `FALSE`. +#' @eval rd_computed_vars( +#' count = "number of points in bin.", +#' density = "density of points in bin, scaled to integrate to 1.", +#' ncount = "count, scaled to a maximum of 1.", +#' ndensity = "density, scaled to a maximum of 1.", +#' width = "widths of bins." +#' ) +#' +#' @section Dropped variables: +#' \describe{ +#' \item{`weight`}{After binning, weights of individual data points (if supplied) are no longer available.} +#' } +#' +#' @seealso [stat_count()], which counts the number of cases at each x +#' position, without binning. It is suitable for both discrete and continuous +#' x data, whereas `stat_bin()` is suitable only for continuous x data. +#' @export +#' @rdname geom_histogram +stat_bin <- make_constructor( + StatBin, geom = "bar", position = "stack", + orientation = NA +) diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index bdb69db23a..c8767d2cb5 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -1,54 +1,9 @@ -#' @param bins numeric vector giving number of bins in both vertical and -#' horizontal directions. Set to 30 by default. -#' @param binwidth Numeric vector giving bin width in both vertical and -#' horizontal directions. Overrides `bins` if both set. -#' @param drop if `TRUE` removes all cells with 0 counts. -#' @export -#' @rdname geom_bin_2d -#' @eval rd_computed_vars( -#' count = "number of points in bin.", -#' density = "density of points in bin, scaled to integrate to 1.", -#' ncount = "count, scaled to maximum of 1.", -#' ndensity = "density, scaled to a maximum of 1." -#' ) -stat_bin_2d <- function(mapping = NULL, data = NULL, - geom = "tile", position = "identity", - ..., - bins = 30, - binwidth = NULL, - drop = TRUE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatBin2d, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - drop = drop, - na.rm = na.rm, - ... - ) - ) -} - - -#' @export -#' @rdname geom_bin_2d -#' @usage NULL -stat_bin2d <- stat_bin_2d - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatBin2d <- ggproto("StatBin2d", Stat, +StatBin2d <- ggproto( + "StatBin2d", Stat, default_aes = aes(weight = 1, fill = after_stat(count)), required_aes = c("x", "y"), @@ -89,6 +44,26 @@ StatBin2d <- ggproto("StatBin2d", Stat, dropped_aes = "weight" # No longer available after transformation ) +#' @param bins numeric vector giving number of bins in both vertical and +#' horizontal directions. Set to 30 by default. +#' @param binwidth Numeric vector giving bin width in both vertical and +#' horizontal directions. Overrides `bins` if both set. +#' @param drop if `TRUE` removes all cells with 0 counts. +#' @export +#' @rdname geom_bin_2d +#' @eval rd_computed_vars( +#' count = "number of points in bin.", +#' density = "density of points in bin, scaled to integrate to 1.", +#' ncount = "count, scaled to maximum of 1.", +#' ndensity = "density, scaled to a maximum of 1." +#' ) +stat_bin_2d <- make_constructor(StatBin2d, geom = "tile") + +#' @export +#' @rdname geom_bin_2d +#' @usage NULL +stat_bin2d <- stat_bin_2d + dual_param <- function(x, default = list(x = NULL, y = NULL)) { if (is.null(x)) { default diff --git a/R/stat-binhex.R b/R/stat-binhex.R index 0b5d3991c6..623f849539 100644 --- a/R/stat-binhex.R +++ b/R/stat-binhex.R @@ -1,47 +1,9 @@ -#' @export -#' @rdname geom_hex -#' @inheritParams stat_bin_2d -#' @eval rd_computed_vars( -#' count = "number of points in bin.", -#' density = "density of points in bin, scaled to integrate to 1.", -#' ncount = "count, scaled to maximum of 1.", -#' ndensity = "density, scaled to maximum of 1." -#' ) -stat_bin_hex <- function(mapping = NULL, data = NULL, - geom = "hex", position = "identity", - ..., - bins = 30, - binwidth = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatBinhex, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - na.rm = na.rm, - ... - ) - ) -} - -#' @export -#' @rdname geom_hex -#' @usage NULL -stat_binhex <- stat_bin_hex - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatBinhex <- ggproto("StatBinhex", Stat, +StatBinhex <- ggproto( + "StatBinhex", Stat, default_aes = aes(weight = 1, fill = after_stat(count)), required_aes = c("x", "y"), @@ -66,3 +28,18 @@ StatBinhex <- ggproto("StatBinhex", Stat, dropped_aes = "weight" ) +#' @export +#' @rdname geom_hex +#' @inheritParams stat_bin_2d +#' @eval rd_computed_vars( +#' count = "number of points in bin.", +#' density = "density of points in bin, scaled to integrate to 1.", +#' ncount = "count, scaled to maximum of 1.", +#' ndensity = "density, scaled to maximum of 1." +#' ) +stat_bin_hex <- make_constructor(StatBinhex, geom = "hex") + +#' @export +#' @rdname geom_hex +#' @usage NULL +stat_binhex <- stat_bin_hex diff --git a/R/stat-boxplot.R b/R/stat-boxplot.R index 46ce14879f..23ac463244 100644 --- a/R/stat-boxplot.R +++ b/R/stat-boxplot.R @@ -1,47 +1,3 @@ -#' @rdname geom_boxplot -#' @param coef Length of the whiskers as multiple of IQR. Defaults to 1.5. -#' @inheritParams stat_identity -#' @export -#' @eval rd_computed_vars( -#' .details = "`stat_boxplot()` provides the following variables, some of -#' which depend on the orientation:", -#' width = "width of boxplot.", -#' "ymin|xmin" = "lower whisker = smallest observation greater than or equal -#' to lower hinger - 1.5 * IQR.", -#' "lower|xlower" = "lower hinge, 25% quantile.", -#' notchlower = "lower edge of notch = median - 1.58 * IQR / sqrt(n).", -#' "middle|xmiddle" = "median, 50% quantile.", -#' notchupper = "upper edge of notch = median + 1.58 * IQR / sqrt(n).", -#' "upper|xupper" = "upper hinge, 75% quantile.", -#' "ymax|xmax" = "upper whisker = largest observation less than or equal to -#' upper hinger + 1.5 * IQR." -#' ) -stat_boxplot <- function(mapping = NULL, data = NULL, - geom = "boxplot", position = "dodge2", - ..., - coef = 1.5, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatBoxplot, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - orientation = orientation, - coef = coef, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -131,3 +87,26 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, flip_data(df, flipped_aes) } ) + +#' @rdname geom_boxplot +#' @param coef Length of the whiskers as multiple of IQR. Defaults to 1.5. +#' @inheritParams stat_identity +#' @export +#' @eval rd_computed_vars( +#' .details = "`stat_boxplot()` provides the following variables, some of +#' which depend on the orientation:", +#' width = "width of boxplot.", +#' "ymin|xmin" = "lower whisker = smallest observation greater than or equal +#' to lower hinger - 1.5 * IQR.", +#' "lower|xlower" = "lower hinge, 25% quantile.", +#' notchlower = "lower edge of notch = median - 1.58 * IQR / sqrt(n).", +#' "middle|xmiddle" = "median, 50% quantile.", +#' notchupper = "upper edge of notch = median + 1.58 * IQR / sqrt(n).", +#' "upper|xupper" = "upper hinge, 75% quantile.", +#' "ymax|xmax" = "upper whisker = largest observation less than or equal to +#' upper hinger + 1.5 * IQR." +#' ) +stat_boxplot <- make_constructor( + StatBoxplot, geom = "boxplot", position = "dodge2", + orientation = NA +) diff --git a/R/stat-contour.R b/R/stat-contour.R index e0590f2ec9..4bf9261d45 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -1,92 +1,9 @@ -#' @inheritParams stat_identity -#' @inheritParams geom_contour -#' @export -#' @eval rd_aesthetics("stat", "contour") -#' @eval rd_aesthetics("stat", "contour_filled") -#' @eval rd_computed_vars( -#' .details = "The computed variables differ somewhat for contour lines -#' (computed by `stat_contour()`) and contour bands (filled contours, -#' computed by `stat_contour_filled()`). The variables `nlevel` and `piece` -#' are available for both, whereas `level_low`, `level_high`, and `level_mid` -#' are only available for bands. The variable `level` is a numeric or a factor -#' depending on whether lines or bands are calculated.", -#' level = "Height of contour. For contour lines, this is a numeric vector -#' that represents bin boundaries. For contour bands, this is an ordered -#' factor that represents bin ranges.", -#' "level_low,level_high,level_mid" = "(contour bands only) Lower and upper -#' bin boundaries for each band, as well as the mid point between boundaries.", -#' nlevel = "Height of contour, scaled to a maximum of 1.", -#' piece = "Contour piece (an integer)." -#' ) -#' -#' @section Dropped variables: -#' \describe{ -#' \item{`z`}{After contouring, the z values of individual data points are no longer available.} -#' } -#' -#' -#' @rdname geom_contour -stat_contour <- function(mapping = NULL, data = NULL, - geom = "contour", position = "identity", - ..., - bins = NULL, - binwidth = NULL, - breaks = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatContour, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - breaks = breaks, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname geom_contour -#' @export -stat_contour_filled <- function(mapping = NULL, data = NULL, - geom = "contour_filled", position = "identity", - ..., - bins = NULL, - binwidth = NULL, - breaks = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatContourFilled, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - breaks = breaks, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatContour <- ggproto("StatContour", Stat, +StatContour <- ggproto( + "StatContour", Stat, required_aes = c("x", "y", "z"), default_aes = aes(order = after_stat(level)), @@ -121,7 +38,8 @@ StatContour <- ggproto("StatContour", Stat, #' @format NULL #' @usage NULL #' @export -StatContourFilled <- ggproto("StatContourFilled", Stat, +StatContourFilled <- ggproto( + "StatContourFilled", Stat, required_aes = c("x", "y", "z"), default_aes = aes(order = after_stat(level), fill = after_stat(level)), @@ -154,6 +72,40 @@ StatContourFilled <- ggproto("StatContourFilled", Stat, } ) +#' @inheritParams stat_identity +#' @inheritParams geom_contour +#' @export +#' @eval rd_aesthetics("stat", "contour") +#' @eval rd_aesthetics("stat", "contour_filled") +#' @eval rd_computed_vars( +#' .details = "The computed variables differ somewhat for contour lines +#' (computed by `stat_contour()`) and contour bands (filled contours, +#' computed by `stat_contour_filled()`). The variables `nlevel` and `piece` +#' are available for both, whereas `level_low`, `level_high`, and `level_mid` +#' are only available for bands. The variable `level` is a numeric or a factor +#' depending on whether lines or bands are calculated.", +#' level = "Height of contour. For contour lines, this is a numeric vector +#' that represents bin boundaries. For contour bands, this is an ordered +#' factor that represents bin ranges.", +#' "level_low,level_high,level_mid" = "(contour bands only) Lower and upper +#' bin boundaries for each band, as well as the mid point between boundaries.", +#' nlevel = "Height of contour, scaled to a maximum of 1.", +#' piece = "Contour piece (an integer)." +#' ) +#' +#' @section Dropped variables: +#' \describe{ +#' \item{`z`}{After contouring, the z values of individual data points are no longer available.} +#' } +#' +#' +#' @rdname geom_contour +stat_contour <- make_constructor(StatContour, geom = "contour") + +#' @rdname geom_contour +#' @export +stat_contour_filled <- make_constructor(StatContourFilled, geom = "contour_filled") + #' Calculate the breaks used for contouring #' #' @inheritParams geom_contour diff --git a/R/stat-count.R b/R/stat-count.R index fd78d1beaa..b0a2ed282d 100644 --- a/R/stat-count.R +++ b/R/stat-count.R @@ -1,47 +1,10 @@ -#' @eval rd_computed_vars( -#' count = "number of points in bin.", -#' prop = "groupwise proportion" -#' ) -#' @seealso [stat_bin()], which bins data in ranges and counts the -#' cases in each range. It differs from `stat_count()`, which counts the -#' number of cases at each `x` position (without binning into ranges). -#' [stat_bin()] requires continuous `x` data, whereas -#' `stat_count()` can be used for both discrete and continuous `x` data. -#' -#' @export -#' @rdname geom_bar -stat_count <- function(mapping = NULL, data = NULL, - geom = "bar", position = "stack", - ..., - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - - params <- list2( - na.rm = na.rm, - orientation = orientation, - ... - ) - - layer( - data = data, - mapping = mapping, - stat = StatCount, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = params - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export #' @include stat-.R -StatCount <- ggproto("StatCount", Stat, +StatCount <- ggproto( + "StatCount", Stat, required_aes = "x|y", default_aes = aes(x = after_stat(count), y = after_stat(count), weight = 1), @@ -88,3 +51,20 @@ StatCount <- ggproto("StatCount", Stat, dropped_aes = "weight" ) + +#' @eval rd_computed_vars( +#' count = "number of points in bin.", +#' prop = "groupwise proportion" +#' ) +#' @seealso [stat_bin()], which bins data in ranges and counts the +#' cases in each range. It differs from `stat_count()`, which counts the +#' number of cases at each `x` position (without binning into ranges). +#' [stat_bin()] requires continuous `x` data, whereas +#' `stat_count()` can be used for both discrete and continuous `x` data. +#' +#' @export +#' @rdname geom_bar +stat_count <- make_constructor( + StatCount, geom = "bar", position = "stack", + orientation = NA +) diff --git a/R/stat-density-2d.R b/R/stat-density-2d.R index 3fd6cf60ee..c3128feca7 100644 --- a/R/stat-density-2d.R +++ b/R/stat-density-2d.R @@ -1,126 +1,9 @@ -#' @export -#' @rdname geom_density_2d -#' @param contour If `TRUE`, contour the results of the 2d density -#' estimation. -#' @param contour_var Character string identifying the variable to contour -#' by. Can be one of `"density"`, `"ndensity"`, or `"count"`. See the section -#' on computed variables for details. -#' @inheritDotParams geom_contour bins binwidth breaks -#' @param n Number of grid points in each direction. -#' @param h Bandwidth (vector of length two). If `NULL`, estimated -#' using [MASS::bandwidth.nrd()]. -#' @param adjust A multiplicative bandwidth adjustment to be used if 'h' is -#' 'NULL'. This makes it possible to adjust the bandwidth while still -#' using the a bandwidth estimator. For example, `adjust = 1/2` means -#' use half of the default bandwidth. -#' @eval rd_computed_vars( -#' .details = "`stat_density_2d()` and `stat_density_2d_filled()` compute -#' different variables depending on whether contouring is turned on or off. -#' With contouring off (`contour = FALSE`), both stats behave the same, and -#' the following variables are provided:", -#' density = "The density estimate.", -#' ndensity = "Density estimate, scaled to a maximum of 1.", -#' count = "Density estimate * number of observations in group.", -#' n = "Number of observations in each group." -#' ) -#' -#' @section Computed variables: -#' With contouring on (`contour = TRUE`), either [stat_contour()] or -#' [stat_contour_filled()] (for contour lines or contour bands, -#' respectively) is run after the density estimate has been obtained, -#' and the computed variables are determined by these stats. -#' Contours are calculated for one of the three types of density estimates -#' obtained before contouring, `density`, `ndensity`, and `count`. Which -#' of those should be used is determined by the `contour_var` parameter. -#' -#' @section Dropped variables: -#' \describe{ -#' \item{`z`}{After density estimation, the z values of individual data points are no longer available.} -#' } -#' -#' If contouring is enabled, then similarly `density`, `ndensity`, and `count` -#' are no longer available after the contouring pass. -#' -stat_density_2d <- function(mapping = NULL, data = NULL, - geom = "density_2d", position = "identity", - ..., - contour = TRUE, - contour_var = "density", - n = 100, - h = NULL, - adjust = c(1, 1), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatDensity2d, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - contour = contour, - contour_var = contour_var, - n = n, - h = h, - adjust = adjust, - ... - ) - ) -} - -#' @rdname geom_density_2d -#' @usage NULL -#' @export -stat_density2d <- stat_density_2d - -#' @rdname geom_density_2d -#' @export -stat_density_2d_filled <- function(mapping = NULL, data = NULL, - geom = "density_2d_filled", position = "identity", - ..., - contour = TRUE, - contour_var = "density", - n = 100, - h = NULL, - adjust = c(1, 1), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatDensity2dFilled, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - contour = contour, - contour_var = contour_var, - n = n, - h = h, - adjust = adjust, - ... - ) - ) -} - -#' @rdname geom_density_2d -#' @usage NULL -#' @export -stat_density2d_filled <- stat_density_2d_filled - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatDensity2d <- ggproto("StatDensity2d", Stat, +StatDensity2d <- ggproto( + "StatDensity2d", Stat, default_aes = aes(colour = "#3366FF", size = 0.5), required_aes = c("x", "y"), @@ -202,14 +85,77 @@ StatDensity2d <- ggproto("StatDensity2d", Stat, } ) - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatDensity2dFilled <- ggproto("StatDensity2dFilled", StatDensity2d, +StatDensity2dFilled <- ggproto( + "StatDensity2dFilled", StatDensity2d, default_aes = aes(colour = NA, fill = after_stat(level)), contour_type = "bands" ) +#' @export +#' @rdname geom_density_2d +#' @param contour If `TRUE`, contour the results of the 2d density +#' estimation. +#' @param contour_var Character string identifying the variable to contour +#' by. Can be one of `"density"`, `"ndensity"`, or `"count"`. See the section +#' on computed variables for details. +#' @inheritDotParams geom_contour bins binwidth breaks +#' @param n Number of grid points in each direction. +#' @param h Bandwidth (vector of length two). If `NULL`, estimated +#' using [MASS::bandwidth.nrd()]. +#' @param adjust A multiplicative bandwidth adjustment to be used if 'h' is +#' 'NULL'. This makes it possible to adjust the bandwidth while still +#' using the a bandwidth estimator. For example, `adjust = 1/2` means +#' use half of the default bandwidth. +#' @eval rd_computed_vars( +#' .details = "`stat_density_2d()` and `stat_density_2d_filled()` compute +#' different variables depending on whether contouring is turned on or off. +#' With contouring off (`contour = FALSE`), both stats behave the same, and +#' the following variables are provided:", +#' density = "The density estimate.", +#' ndensity = "Density estimate, scaled to a maximum of 1.", +#' count = "Density estimate * number of observations in group.", +#' n = "Number of observations in each group." +#' ) +#' +#' @section Computed variables: +#' With contouring on (`contour = TRUE`), either [stat_contour()] or +#' [stat_contour_filled()] (for contour lines or contour bands, +#' respectively) is run after the density estimate has been obtained, +#' and the computed variables are determined by these stats. +#' Contours are calculated for one of the three types of density estimates +#' obtained before contouring, `density`, `ndensity`, and `count`. Which +#' of those should be used is determined by the `contour_var` parameter. +#' +#' @section Dropped variables: +#' \describe{ +#' \item{`z`}{After density estimation, the z values of individual data points are no longer available.} +#' } +#' +#' If contouring is enabled, then similarly `density`, `ndensity`, and `count` +#' are no longer available after the contouring pass. +#' +stat_density_2d <- make_constructor( + StatDensity2d, geom = "density_2d", + contour = TRUE, contour_var = "density" +) + +#' @rdname geom_density_2d +#' @usage NULL +#' @export +stat_density2d <- stat_density_2d + +#' @rdname geom_density_2d +#' @export +stat_density_2d_filled <- make_constructor( + StatDensity2dFilled, geom = "density_2d_filled", + contour = TRUE, contour_var = "density" +) + +#' @rdname geom_density_2d +#' @usage NULL +#' @export +stat_density2d_filled <- stat_density_2d_filled diff --git a/R/stat-density.R b/R/stat-density.R index 5b948f5d88..e4a8193fee 100644 --- a/R/stat-density.R +++ b/R/stat-density.R @@ -1,78 +1,9 @@ -#' @param bw The smoothing bandwidth to be used. -#' If numeric, the standard deviation of the smoothing kernel. -#' If character, a rule to choose the bandwidth, as listed in -#' [stats::bw.nrd()]. Note that automatic calculation of the bandwidth does -#' not take weights into account. -#' @param adjust A multiplicate bandwidth adjustment. This makes it possible -#' to adjust the bandwidth while still using the a bandwidth estimator. -#' For example, `adjust = 1/2` means use half of the default bandwidth. -#' @param kernel Kernel. See list of available kernels in [density()]. -#' @param n number of equally spaced points at which the density is to be -#' estimated, should be a power of two, see [density()] for -#' details -#' @param trim If `FALSE`, the default, each density is computed on the -#' full range of the data. If `TRUE`, each density is computed over the -#' range of that group: this typically means the estimated x values will -#' not line-up, and hence you won't be able to stack density values. -#' This parameter only matters if you are displaying multiple densities in -#' one plot or if you are manually adjusting the scale limits. -#' @param bounds Known lower and upper bounds for estimated data. Default -#' `c(-Inf, Inf)` means that there are no (finite) bounds. If any bound is -#' finite, boundary effect of default density estimation will be corrected by -#' reflecting tails outside `bounds` around their closest edge. Data points -#' outside of bounds are removed with a warning. -#' @eval rd_computed_vars( -#' density = "density estimate.", -#' count = "density * number of points - useful for stacked density plots.", -#' wdensity = "density * sum of weights. In absence of weights, the same as -#' `count`.", -#' scaled = "density estimate, scaled to maximum of 1.", -#' n = "number of points.", -#' ndensity = "alias for `scaled`, to mirror the syntax of [`stat_bin()`]." -#' ) -#' @export -#' @rdname geom_density -stat_density <- function(mapping = NULL, data = NULL, - geom = "area", position = "stack", - ..., - bw = "nrd0", - adjust = 1, - kernel = "gaussian", - n = 512, - trim = FALSE, - na.rm = FALSE, - bounds = c(-Inf, Inf), - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - - layer( - data = data, - mapping = mapping, - stat = StatDensity, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bw = bw, - adjust = adjust, - kernel = kernel, - n = n, - trim = trim, - na.rm = na.rm, - bounds = bounds, - orientation = orientation, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatDensity <- ggproto("StatDensity", Stat, +StatDensity <- ggproto( + "StatDensity", Stat, required_aes = "x|y", default_aes = aes(x = after_stat(density), y = after_stat(density), fill = NA, weight = NULL), @@ -104,14 +35,49 @@ StatDensity <- ggproto("StatDensity", Stat, } density <- compute_density(data$x, data$weight, from = range[1], - to = range[2], bw = bw, adjust = adjust, kernel = kernel, n = n, - bounds = bounds) + to = range[2], bw = bw, adjust = adjust, kernel = kernel, n = n, + bounds = bounds) density$flipped_aes <- flipped_aes flip_data(density, flipped_aes) } - ) +#' @param bw The smoothing bandwidth to be used. +#' If numeric, the standard deviation of the smoothing kernel. +#' If character, a rule to choose the bandwidth, as listed in +#' [stats::bw.nrd()]. Note that automatic calculation of the bandwidth does +#' not take weights into account. +#' @param adjust A multiplicate bandwidth adjustment. This makes it possible +#' to adjust the bandwidth while still using the a bandwidth estimator. +#' For example, `adjust = 1/2` means use half of the default bandwidth. +#' @param kernel Kernel. See list of available kernels in [density()]. +#' @param n number of equally spaced points at which the density is to be +#' estimated, should be a power of two, see [density()] for +#' details +#' @param trim If `FALSE`, the default, each density is computed on the +#' full range of the data. If `TRUE`, each density is computed over the +#' range of that group: this typically means the estimated x values will +#' not line-up, and hence you won't be able to stack density values. +#' This parameter only matters if you are displaying multiple densities in +#' one plot or if you are manually adjusting the scale limits. +#' @param bounds Known lower and upper bounds for estimated data. Default +#' `c(-Inf, Inf)` means that there are no (finite) bounds. If any bound is +#' finite, boundary effect of default density estimation will be corrected by +#' reflecting tails outside `bounds` around their closest edge. Data points +#' outside of bounds are removed with a warning. +#' @eval rd_computed_vars( +#' density = "density estimate.", +#' count = "density * number of points - useful for stacked density plots.", +#' wdensity = "density * sum of weights. In absence of weights, the same as +#' `count`.", +#' scaled = "density estimate, scaled to maximum of 1.", +#' n = "number of points.", +#' ndensity = "alias for `scaled`, to mirror the syntax of [`stat_bin()`]." +#' ) +#' @export +#' @rdname geom_density +stat_density <- make_constructor(StatDensity, geom = "area", position = "stack") + compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, bounds = c(-Inf, Inf)) { diff --git a/R/stat-ecdf.R b/R/stat-ecdf.R index 96430b1e32..798f3160e8 100644 --- a/R/stat-ecdf.R +++ b/R/stat-ecdf.R @@ -1,3 +1,52 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatEcdf <- ggproto( + "StatEcdf", Stat, + required_aes = c("x|y"), + + default_aes = aes(x = after_stat(ecdf), y = after_stat(ecdf), weight = NULL), + + setup_params = function(self, 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) { + cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + } + + params + }, + + compute_group = function(data, scales, n = NULL, pad = TRUE, flipped_aes = FALSE) { + data <- flip_data(data, flipped_aes) + # If n is NULL, use raw values; otherwise interpolate + if (is.null(n)) { + x <- unique0(data$x) + } else { + x <- seq(min(data$x), max(data$x), length.out = n) + } + + if (pad) { + x <- c(-Inf, x, Inf) + } + data_ecdf <- wecdf(data$x, data$weight)(x) + + df_ecdf <- data_frame0( + x = x, + y = data_ecdf, + ecdf = data_ecdf, + .size = length(x) + ) + df_ecdf$flipped_aes <- flipped_aes + flip_data(df_ecdf, flipped_aes) + }, + + dropped_aes = "weight" +) + #' Compute empirical cumulative distribution #' #' The empirical cumulative distribution function (ECDF) provides an alternative @@ -62,79 +111,7 @@ #' aes(weight = weights), #' data = weighted, colour = "green" #' ) -stat_ecdf <- function(mapping = NULL, data = NULL, - geom = "step", position = "identity", - ..., - n = NULL, - pad = TRUE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatEcdf, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - n = n, - pad = pad, - na.rm = na.rm, - ... - ) - ) -} - - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatEcdf <- ggproto("StatEcdf", Stat, - required_aes = c("x|y"), - - default_aes = aes(x = after_stat(ecdf), y = after_stat(ecdf), weight = NULL), - - setup_params = function(self, 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) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") - } - - params - }, - - compute_group = function(data, scales, n = NULL, pad = TRUE, flipped_aes = FALSE) { - data <- flip_data(data, flipped_aes) - # If n is NULL, use raw values; otherwise interpolate - if (is.null(n)) { - x <- unique0(data$x) - } else { - x <- seq(min(data$x), max(data$x), length.out = n) - } - - if (pad) { - x <- c(-Inf, x, Inf) - } - data_ecdf <- wecdf(data$x, data$weight)(x) - - df_ecdf <- data_frame0( - x = x, - y = data_ecdf, - ecdf = data_ecdf, - .size = length(x) - ) - df_ecdf$flipped_aes <- flipped_aes - flip_data(df_ecdf, flipped_aes) - }, - - dropped_aes = "weight" -) +stat_ecdf <- make_constructor(StatEcdf, geom = "step") # Weighted eCDF function wecdf <- function(x, weights = NULL) { diff --git a/R/stat-ellipse.R b/R/stat-ellipse.R index 152b27d280..920acaf3bb 100644 --- a/R/stat-ellipse.R +++ b/R/stat-ellipse.R @@ -1,3 +1,18 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatEllipse <- ggproto( + "StatEllipse", Stat, + required_aes = c("x", "y"), + + compute_group = function(data, scales, type = "t", level = 0.95, + segments = 51, na.rm = FALSE) { + calculate_ellipse(data = data, vars = c("x", "y"), type = type, + level = level, segments = segments) + } +) + #' Compute normal data ellipses #' #' The method for calculating the ellipses has been modified from @@ -43,46 +58,7 @@ #' #' ggplot(faithful, aes(waiting, eruptions, fill = eruptions > 3)) + #' stat_ellipse(geom = "polygon") -stat_ellipse <- function(mapping = NULL, data = NULL, - geom = "path", position = "identity", - ..., - type = "t", - level = 0.95, - segments = 51, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatEllipse, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - type = type, - level = level, - segments = segments, - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatEllipse <- ggproto("StatEllipse", Stat, - required_aes = c("x", "y"), - - compute_group = function(data, scales, type = "t", level = 0.95, - segments = 51, na.rm = FALSE) { - calculate_ellipse(data = data, vars = c("x", "y"), type = type, - level = level, segments = segments) - } -) +stat_ellipse <- make_constructor(StatEllipse, geom = "path") calculate_ellipse <- function(data, vars, type, level, segments){ dfn <- 2 diff --git a/R/stat-function.R b/R/stat-function.R index bf6d2e4b74..3c70b6b54d 100644 --- a/R/stat-function.R +++ b/R/stat-function.R @@ -1,55 +1,9 @@ -#' @param fun Function to use. Either 1) an anonymous function in the base or -#' rlang formula syntax (see [rlang::as_function()]) -#' or 2) a quoted or character name referencing a function; see examples. Must -#' be vectorised. -#' @param n Number of points to interpolate along the x axis. -#' @param args List of additional arguments passed on to the function defined by `fun`. -#' @param xlim Optionally, specify the range of the function. -#' @eval rd_computed_vars( -#' x = "`x` values along a grid.", -#' y = "values of the function evaluated at corresponding `x`." -#' ) -#' @seealso [rlang::as_function()] -#' @export -#' @rdname geom_function -stat_function <- function(mapping = NULL, data = NULL, - geom = "function", position = "identity", - ..., - fun, - xlim = NULL, - n = 101, - args = list(), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - if (is.null(data)) { - data <- ensure_nonempty_data - } - - layer( - data = data, - mapping = mapping, - stat = StatFunction, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - fun = fun, - n = n, - args = args, - na.rm = na.rm, - xlim = xlim, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatFunction <- ggproto("StatFunction", Stat, +StatFunction <- ggproto( + "StatFunction", Stat, default_aes = aes(x = NULL, y = after_scale(y)), compute_group = function(data, scales, fun, xlim = NULL, n = 101, args = list()) { @@ -82,6 +36,25 @@ StatFunction <- ggproto("StatFunction", Stat, } ) +#' @param fun Function to use. Either 1) an anonymous function in the base or +#' rlang formula syntax (see [rlang::as_function()]) +#' or 2) a quoted or character name referencing a function; see examples. Must +#' be vectorised. +#' @param n Number of points to interpolate along the x axis. +#' @param args List of additional arguments passed on to the function defined by `fun`. +#' @param xlim Optionally, specify the range of the function. +#' @eval rd_computed_vars( +#' x = "`x` values along a grid.", +#' y = "values of the function evaluated at corresponding `x`." +#' ) +#' @seealso [rlang::as_function()] +#' @export +#' @rdname geom_function +stat_function <- make_constructor( + StatFunction, geom = "function", fun = , + checks = exprs(data <- data %||% ensure_nonempty_data) +) + # Convenience function used by `stat_function()` and # `geom_function()` to convert empty input data into # non-empty input data without touching any non-empty diff --git a/R/stat-identity.R b/R/stat-identity.R index 86c8c09b95..67ef0848e5 100644 --- a/R/stat-identity.R +++ b/R/stat-identity.R @@ -1,3 +1,14 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatIdentity <- ggproto( + "StatIdentity", Stat, + compute_layer = function(self, data, params, layout) { + data + } +) + #' Leave data as is #' #' The identity statistic leaves the data unchanged. @@ -8,32 +19,4 @@ #' @examples #' p <- ggplot(mtcars, aes(wt, mpg)) #' p + stat_identity() -stat_identity <- function(mapping = NULL, data = NULL, - geom = "point", position = "identity", - ..., - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatIdentity, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = FALSE, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatIdentity <- ggproto("StatIdentity", Stat, - compute_layer = function(self, data, params, layout) { - data - } -) +stat_identity <- make_constructor(StatIdentity, geom = "point") diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 8133216779..4de59ec4d2 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -1,49 +1,9 @@ -#' @rdname geom_qq -#' @export -#' @param line.p Vector of quantiles to use when fitting the Q-Q line, defaults -#' defaults to `c(.25, .75)`. -#' @param fullrange Should the q-q line span the full range of the plot, or just -#' the data -geom_qq_line <- function(mapping = NULL, - data = NULL, - geom = "path", - position = "identity", - ..., - distribution = stats::qnorm, - dparams = list(), - line.p = c(0.25, 0.75), - fullrange = FALSE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatQqLine, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - distribution = distribution, - dparams = dparams, - na.rm = na.rm, - line.p = line.p, - fullrange = fullrange, - ... - ) - ) -} - -#' @export -#' @rdname geom_qq -stat_qq_line <- geom_qq_line - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatQqLine <- ggproto("StatQqLine", Stat, +StatQqLine <- ggproto( + "StatQqLine", Stat, default_aes = aes(x = after_stat(x), y = after_stat(y)), required_aes = c("sample"), @@ -89,3 +49,15 @@ StatQqLine <- ggproto("StatQqLine", Stat, data_frame0(x = x, y = slope * x + intercept) } ) + +#' @rdname geom_qq +#' @export +#' @param line.p Vector of quantiles to use when fitting the Q-Q line, defaults +#' defaults to `c(.25, .75)`. +#' @param fullrange Should the q-q line span the full range of the plot, or just +#' the data +geom_qq_line <- make_constructor(StatQqLine, geom = "path") + +#' @export +#' @rdname geom_qq +stat_qq_line <- geom_qq_line diff --git a/R/stat-qq.R b/R/stat-qq.R index dc3762dacd..b7a73296fa 100644 --- a/R/stat-qq.R +++ b/R/stat-qq.R @@ -1,3 +1,33 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatQq <- ggproto( + "StatQq", Stat, + default_aes = aes(y = after_stat(sample), x = after_stat(theoretical)), + + required_aes = c("sample"), + + compute_group = function(self, data, scales, quantiles = NULL, + distribution = stats::qnorm, dparams = list(), + na.rm = FALSE) { + + sample <- sort(data$sample) + n <- length(sample) + + # Compute theoretical quantiles + if (is.null(quantiles)) { + quantiles <- stats::ppoints(n) + } else if (length(quantiles) != n) { + cli::cli_abort("The length of {.arg quantiles} must match the length of the data.") + } + + theoretical <- inject(distribution(p = quantiles, !!!dparams)) + + data_frame0(sample = sample, theoretical = theoretical) + } +) + #' A quantile-quantile plot #' #' `geom_qq()` and `stat_qq()` produce quantile-quantile plots. `geom_qq_line()` and @@ -46,60 +76,8 @@ #' stat_qq() + #' stat_qq_line() #' } -geom_qq <- function(mapping = NULL, data = NULL, - geom = "point", position = "identity", - ..., - distribution = stats::qnorm, - dparams = list(), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatQq, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - distribution = distribution, - dparams = dparams, - na.rm = na.rm, - ... - ) - ) -} +geom_qq <- make_constructor(StatQq, geom = "point") #' @export #' @rdname geom_qq stat_qq <- geom_qq - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatQq <- ggproto("StatQq", Stat, - default_aes = aes(y = after_stat(sample), x = after_stat(theoretical)), - - required_aes = c("sample"), - - compute_group = function(self, data, scales, quantiles = NULL, - distribution = stats::qnorm, dparams = list(), - na.rm = FALSE) { - - sample <- sort(data$sample) - n <- length(sample) - - # Compute theoretical quantiles - if (is.null(quantiles)) { - quantiles <- stats::ppoints(n) - } else if (length(quantiles) != n) { - cli::cli_abort("The length of {.arg quantiles} must match the length of the data.") - } - - theoretical <- inject(distribution(p = quantiles, !!!dparams)) - - data_frame0(sample = sample, theoretical = theoretical) - } -) diff --git a/R/stat-quantilemethods.R b/R/stat-quantilemethods.R index 9afb7e0b92..681b2348a7 100644 --- a/R/stat-quantilemethods.R +++ b/R/stat-quantilemethods.R @@ -1,49 +1,9 @@ -#' @param quantiles conditional quantiles of y to calculate and display -#' @param formula formula relating y variables to x variables -#' @param method Quantile regression method to use. Available options are `"rq"` (for -#' [`quantreg::rq()`]) and `"rqss"` (for [`quantreg::rqss()`]). -#' @inheritParams layer -#' @inheritParams geom_point -#' @eval rd_computed_vars( -#' quantile = "Quantile of distribution." -#' ) -#' @export -#' @rdname geom_quantile -stat_quantile <- function(mapping = NULL, data = NULL, - geom = "quantile", position = "identity", - ..., - quantiles = c(0.25, 0.5, 0.75), - formula = NULL, - method = "rq", - method.args = list(), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatQuantile, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - quantiles = quantiles, - formula = formula, - method = method, - method.args = method.args, - na.rm = na.rm, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatQuantile <- ggproto("StatQuantile", Stat, +StatQuantile <- ggproto( + "StatQuantile", Stat, required_aes = c("x", "y"), compute_group = function(data, scales, quantiles = c(0.25, 0.5, 0.75), @@ -102,6 +62,19 @@ StatQuantile <- ggproto("StatQuantile", Stat, dropped_aes = "weight" ) +#' @param quantiles conditional quantiles of y to calculate and display +#' @param formula formula relating y variables to x variables +#' @param method Quantile regression method to use. Available options are `"rq"` (for +#' [`quantreg::rq()`]) and `"rqss"` (for [`quantreg::rqss()`]). +#' @inheritParams layer +#' @inheritParams geom_point +#' @eval rd_computed_vars( +#' quantile = "Quantile of distribution." +#' ) +#' @export +#' @rdname geom_quantile +stat_quantile <- make_constructor(StatQuantile, geom = "quantile") + quant_pred <- function(quantile, data, method, formula, weight, grid, method.args = method.args) { model <- inject(method( diff --git a/R/stat-sf-coordinates.R b/R/stat-sf-coordinates.R index b54c8f6376..ce8391c0ac 100644 --- a/R/stat-sf-coordinates.R +++ b/R/stat-sf-coordinates.R @@ -1,3 +1,50 @@ +#' @rdname stat_sf_coordinates +#' @usage NULL +#' @format NULL +#' @export +StatSfCoordinates <- ggproto( + "StatSfCoordinates", Stat, + + compute_layer = function(self, data, params, layout) { + # add coord to the params, so it can be forwarded to compute_group() + params$coord <- layout$coord + ggproto_parent(Stat, self)$compute_layer(data, params, layout) + }, + + compute_group = function(self, data, scales, coord, fun.geometry = NULL) { + if (is.null(fun.geometry)) { + fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x)) + } + + points_sfc <- fun.geometry(data$geometry) + + if (inherits(coord, "CoordSf")) { + # register bounding box if the coord derives from CoordSf + bbox <- sf::st_bbox(points_sfc) + + coord$record_bbox( + xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], + ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] + ) + + # transform to the coord's default crs if possible + default_crs <- coord$get_default_crs() + if (!(is.null(default_crs) || is.na(default_crs) || + is.na(sf::st_crs(points_sfc)))) { + points_sfc <- sf::st_transform(points_sfc, default_crs) + } + } + coordinates <- sf::st_coordinates(points_sfc) + data$x <- coordinates[, "X"] + data$y <- coordinates[, "Y"] + + data + }, + + default_aes = aes(x = after_stat(x), y = after_stat(y)), + required_aes = c("geometry") +) + #' Extract coordinates from 'sf' objects #' #' `stat_sf_coordinates()` extracts the coordinates from 'sf' objects and @@ -56,70 +103,4 @@ #' will be used. Note that the function may warn about the incorrectness of #' the result if the data is not projected, but you can ignore this except #' when you really care about the exact locations. -stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point", - position = "identity", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE, - fun.geometry = NULL, - ...) { - layer_sf( - stat = StatSfCoordinates, - data = data, - mapping = mapping, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - fun.geometry = fun.geometry, - ... - ) - ) -} - -#' @rdname stat_sf_coordinates -#' @usage NULL -#' @format NULL -#' @export -StatSfCoordinates <- ggproto( - "StatSfCoordinates", Stat, - - compute_layer = function(self, data, params, layout) { - # add coord to the params, so it can be forwarded to compute_group() - params$coord <- layout$coord - ggproto_parent(Stat, self)$compute_layer(data, params, layout) - }, - - compute_group = function(self, data, scales, coord, fun.geometry = NULL) { - if (is.null(fun.geometry)) { - fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x)) - } - - points_sfc <- fun.geometry(data$geometry) - - if (inherits(coord, "CoordSf")) { - # register bounding box if the coord derives from CoordSf - bbox <- sf::st_bbox(points_sfc) - - coord$record_bbox( - xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], - ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] - ) - - # transform to the coord's default crs if possible - default_crs <- coord$get_default_crs() - if (!(is.null(default_crs) || is.na(default_crs) || - is.na(sf::st_crs(points_sfc)))) { - points_sfc <- sf::st_transform(points_sfc, default_crs) - } - } - coordinates <- sf::st_coordinates(points_sfc) - data$x <- coordinates[, "X"] - data$y <- coordinates[, "Y"] - - data - }, - - default_aes = aes(x = after_stat(x), y = after_stat(y)), - required_aes = c("geometry") -) +stat_sf_coordinates <- make_constructor(StatSfCoordinates, geom = "point") diff --git a/R/stat-sf.R b/R/stat-sf.R index cf0b55c0ec..d5170d1a67 100644 --- a/R/stat-sf.R +++ b/R/stat-sf.R @@ -59,21 +59,5 @@ StatSf <- ggproto("StatSf", Stat, #' @export #' @rdname ggsf #' @inheritParams stat_identity -stat_sf <- function(mapping = NULL, data = NULL, geom = "rect", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) { - layer_sf( - stat = StatSf, - data = data, - mapping = mapping, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} +stat_sf <- make_constructor(StatSf, geom = "rect") diff --git a/R/stat-smooth.R b/R/stat-smooth.R index 147bd06e41..6fb12772a7 100644 --- a/R/stat-smooth.R +++ b/R/stat-smooth.R @@ -1,97 +1,9 @@ -#' @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 = 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, -#' `loess` gives a better appearance, but is \eqn{O(N^{2})}{O(N^2)} in memory, -#' 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 = 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)`. `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 band around smooth? (`TRUE` by default, see -#' `level` to control.) -#' @param fullrange If `TRUE`, the smoothing line gets expanded to the range of the plot, -#' potentially beyond the data. This does not extend the line into any additional padding -#' created by `expansion`. -#' @param xseq A numeric vector of values at which the smoother is evaluated. -#' When `NULL` (default), `xseq` is internally evaluated as a sequence of `n` -#' equally spaced points for continuous data. -#' @param level Level of confidence band to use (0.95 by default). -#' @param span Controls the amount of smoothing for the default loess smoother. -#' Smaller numbers produce wigglier lines, larger numbers produce smoother -#' lines. Only used with loess, i.e. when `method = "loess"`, -#' or when `method = NULL` (the default) and there are fewer than 1,000 -#' observations. -#' @param n Number of points at which to evaluate smoother. -#' @param method.args List of additional arguments passed on to the modelling -#' function defined by `method`. -#' -#' @eval rd_computed_vars( -#' .details = "`stat_smooth()` provides the following variables, some of -#' which depend on the orientation:", -#' "y|x" = "Predicted value.", -#' "ymin|xmin" = "Lower pointwise confidence band around the mean.", -#' "ymax|xmax" = "Upper pointwise confidence band around the mean.", -#' "se" = "Standard error." -#' ) -#' @export -#' @rdname geom_smooth -stat_smooth <- function(mapping = NULL, data = NULL, - geom = "smooth", position = "identity", - ..., - method = NULL, - formula = NULL, - se = TRUE, - n = 80, - span = 0.75, - fullrange = FALSE, - xseq = NULL, - level = 0.95, - method.args = list(), - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatSmooth, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - method = method, - formula = formula, - se = se, - n = n, - fullrange = fullrange, - level = level, - na.rm = na.rm, - orientation = orientation, - method.args = method.args, - span = span, - xseq = xseq, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatSmooth <- ggproto("StatSmooth", Stat, +StatSmooth <- ggproto( + "StatSmooth", Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) msg <- character() @@ -214,6 +126,56 @@ StatSmooth <- ggproto("StatSmooth", Stat, required_aes = c("x", "y") ) +#' @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 = 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, +#' `loess` gives a better appearance, but is \eqn{O(N^{2})}{O(N^2)} in memory, +#' 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 = 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)`. `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 band around smooth? (`TRUE` by default, see +#' `level` to control.) +#' @param fullrange If `TRUE`, the smoothing line gets expanded to the range of the plot, +#' potentially beyond the data. This does not extend the line into any additional padding +#' created by `expansion`. +#' @param xseq A numeric vector of values at which the smoother is evaluated. +#' When `NULL` (default), `xseq` is internally evaluated as a sequence of `n` +#' equally spaced points for continuous data. +#' @param level Level of confidence band to use (0.95 by default). +#' @param span Controls the amount of smoothing for the default loess smoother. +#' Smaller numbers produce wigglier lines, larger numbers produce smoother +#' lines. Only used with loess, i.e. when `method = "loess"`, +#' or when `method = NULL` (the default) and there are fewer than 1,000 +#' observations. +#' @param n Number of points at which to evaluate smoother. +#' @param method.args List of additional arguments passed on to the modelling +#' function defined by `method`. +#' +#' @eval rd_computed_vars( +#' .details = "`stat_smooth()` provides the following variables, some of +#' which depend on the orientation:", +#' "y|x" = "Predicted value.", +#' "ymin|xmin" = "Lower pointwise confidence band around the mean.", +#' "ymax|xmax" = "Upper pointwise confidence band around the mean.", +#' "se" = "Standard error." +#' ) +#' @export +#' @rdname geom_smooth +stat_smooth <- make_constructor(StatSmooth, geom = "smooth") + # This function exists to silence an undeclared import warning gam_method <- function() { if (is_installed("mgcv")) { diff --git a/R/stat-sum.R b/R/stat-sum.R index 0dff7c07f2..a9529e6357 100644 --- a/R/stat-sum.R +++ b/R/stat-sum.R @@ -1,37 +1,9 @@ -#' @inheritParams layer -#' @inheritParams geom_point -#' @eval rd_computed_vars( -#' n = "Number of observations at position.", -#' prop = "Percent of points in that panel at that position." -#' ) -#' @export -#' @rdname geom_count -stat_sum <- function(mapping = NULL, data = NULL, - geom = "point", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatSum, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatSum <- ggproto("StatSum", Stat, +StatSum <- ggproto( + "StatSum", Stat, default_aes = aes(size = after_stat(n), weight = 1), required_aes = c("x", "y"), @@ -47,3 +19,13 @@ StatSum <- ggproto("StatSum", Stat, counts } ) + +#' @inheritParams layer +#' @inheritParams geom_point +#' @eval rd_computed_vars( +#' n = "Number of observations at position.", +#' prop = "Percent of points in that panel at that position." +#' ) +#' @export +#' @rdname geom_count +stat_sum <- make_constructor(StatSum, geom = "point") diff --git a/R/stat-summary-2d.R b/R/stat-summary-2d.R index 60e5e49813..fe524b3863 100644 --- a/R/stat-summary-2d.R +++ b/R/stat-summary-2d.R @@ -1,3 +1,46 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatSummary2d <- ggproto( + "StatSummary2d", Stat, + default_aes = aes(fill = after_stat(value)), + + required_aes = c("x", "y", "z"), + dropped_aes = "z", # z gets dropped during statistical transformation + + compute_group = function(data, scales, binwidth = NULL, bins = 30, + breaks = NULL, origin = NULL, drop = TRUE, + fun = "mean", fun.args = list()) { + origin <- dual_param(origin, list(NULL, NULL)) + binwidth <- dual_param(binwidth, list(NULL, NULL)) + breaks <- dual_param(breaks, list(NULL, NULL)) + bins <- dual_param(bins, list(x = 30, y = 30)) + + xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) + ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) + + xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) + ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) + + fun <- as_function(fun) + f <- function(x) { + inject(fun(x, !!!fun.args)) + } + out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop) + + xdim <- bin_loc(xbreaks, out$xbin) + out$x <- xdim$mid + out$width <- xdim$length + + ydim <- bin_loc(ybreaks, out$ybin) + out$y <- ydim$mid + out$height <- ydim$length + + out + } +) + #' Bin and summarise in 2d (rectangle & hexagons) #' #' `stat_summary_2d()` is a 2d variation of [stat_summary()]. @@ -43,36 +86,7 @@ #' d + stat_summary_hex() #' d + stat_summary_hex(fun = ~ sum(.x^2)) #' } -stat_summary_2d <- function(mapping = NULL, data = NULL, - geom = "tile", position = "identity", - ..., - bins = 30, - binwidth = NULL, - drop = TRUE, - fun = "mean", - fun.args = list(), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatSummary2d, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - drop = drop, - fun = fun, - fun.args = fun.args, - na.rm = na.rm, - ... - ) - ) -} +stat_summary_2d <- make_constructor(StatSummary2d, geom = "tile") #' @export #' @rdname stat_summary_2d @@ -82,48 +96,6 @@ stat_summary2d <- function(...) { stat_summary_2d(...) } -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatSummary2d <- ggproto("StatSummary2d", Stat, - default_aes = aes(fill = after_stat(value)), - - required_aes = c("x", "y", "z"), - dropped_aes = "z", # z gets dropped during statistical transformation - - compute_group = function(data, scales, binwidth = NULL, bins = 30, - breaks = NULL, origin = NULL, drop = TRUE, - fun = "mean", fun.args = list()) { - origin <- dual_param(origin, list(NULL, NULL)) - binwidth <- dual_param(binwidth, list(NULL, NULL)) - breaks <- dual_param(breaks, list(NULL, NULL)) - bins <- dual_param(bins, list(x = 30, y = 30)) - - xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) - ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) - - xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) - ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) - - fun <- as_function(fun) - f <- function(x) { - inject(fun(x, !!!fun.args)) - } - out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop) - - xdim <- bin_loc(xbreaks, out$xbin) - out$x <- xdim$mid - out$width <- xdim$length - - ydim <- bin_loc(ybreaks, out$ybin) - out$y <- ydim$mid - out$height <- ydim$length - - out - } -) - # Adaptation of tapply that returns a data frame instead of a matrix tapply_df <- function(x, index, fun, ..., drop = TRUE) { labels <- lapply(index, ulevels, na.last = NA) # drop NA diff --git a/R/stat-summary-hex.R b/R/stat-summary-hex.R index 959630b4ac..8ba4071ef2 100644 --- a/R/stat-summary-hex.R +++ b/R/stat-summary-hex.R @@ -1,42 +1,9 @@ -#' @export -#' @rdname stat_summary_2d -#' @inheritParams stat_bin_hex -stat_summary_hex <- function(mapping = NULL, data = NULL, - geom = "hex", position = "identity", - ..., - bins = 30, - binwidth = NULL, - drop = TRUE, - fun = "mean", - fun.args = list(), - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatSummaryHex, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bins = bins, - binwidth = binwidth, - drop = drop, - fun = fun, - fun.args = fun.args, - na.rm = na.rm, - ... - ) - ) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatSummaryHex <- ggproto("StatSummaryHex", Stat, +StatSummaryHex <- ggproto( + "StatSummaryHex", Stat, default_aes = aes(fill = after_stat(value)), required_aes = c("x", "y", "z"), @@ -50,6 +17,11 @@ StatSummaryHex <- ggproto("StatSummaryHex", Stat, binwidth <- binwidth %||% hex_binwidth(bins, scales) fun <- as_function(fun) hexBinSummarise(data$x, data$y, data$z, binwidth, - fun = fun, fun.args = fun.args, drop = drop) + fun = fun, fun.args = fun.args, drop = drop) } ) + +#' @export +#' @rdname stat_summary_2d +#' @inheritParams stat_bin_hex +stat_summary_hex <- make_constructor(StatSummaryHex, geom = "hex") diff --git a/R/stat-unique.R b/R/stat-unique.R index 38483a2d7b..160875c733 100644 --- a/R/stat-unique.R +++ b/R/stat-unique.R @@ -1,3 +1,12 @@ +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatUnique <- ggproto( + "StatUnique", Stat, + compute_panel = function(data, scales) unique0(data) +) + #' Remove duplicates #' #' @eval rd_aesthetics("stat", "unique") @@ -9,31 +18,4 @@ #' geom_point(alpha = 0.1) #' ggplot(mtcars, aes(vs, am)) + #' geom_point(alpha = 0.1, stat = "unique") -stat_unique <- function(mapping = NULL, data = NULL, - geom = "point", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = StatUnique, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -StatUnique <- ggproto("StatUnique", Stat, - compute_panel = function(data, scales) unique0(data) -) +stat_unique <- make_constructor(StatUnique, geom = "point") diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 4eadd8ca58..1930b16fd4 100644 --- a/R/stat-ydensity.R +++ b/R/stat-ydensity.R @@ -1,72 +1,9 @@ -#' @inheritParams layer -#' @inheritParams geom_point -#' @inheritParams stat_density -#' @param scale if "area" (default), all violins have the same area (before trimming -#' the tails). If "count", areas are scaled proportionally to the number of -#' observations. If "width", all violins have the same maximum width. -#' @param drop Whether to discard groups with less than 2 observations -#' (`TRUE`, default) or keep such groups for position adjustment purposes -#' (`FALSE`). -#' -#' @eval rd_computed_vars( -#' density = "Density estimate.", -#' scaled = "Density estimate, scaled to a maximum of 1.", -#' count = "Density * number of points - probably useless for violin -#' plots.", -#' violinwidth = "Density scaled for the violin plot, according to area, -#' counts or to a constant maximum width.", -#' n = "Number of points.", -#' width = "Width of violin bounding box." -#' ) -#' -#' @seealso [geom_violin()] for examples, and [stat_density()] -#' for examples with data along the x axis. -#' @export -#' @rdname geom_violin -stat_ydensity <- function(mapping = NULL, data = NULL, - geom = "violin", position = "dodge", - ..., - bw = "nrd0", - adjust = 1, - kernel = "gaussian", - trim = TRUE, - scale = "area", - drop = TRUE, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE, - bounds = c(-Inf, Inf)) { - scale <- arg_match0(scale, c("area", "count", "width")) - - layer( - data = data, - mapping = mapping, - stat = StatYdensity, - geom = geom, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - bw = bw, - adjust = adjust, - kernel = kernel, - trim = trim, - scale = scale, - drop = drop, - na.rm = na.rm, - bounds = bounds, - ... - ) - ) -} - - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export -StatYdensity <- ggproto("StatYdensity", Stat, +StatYdensity <- ggproto( + "StatYdensity", Stat, required_aes = c("x", "y"), non_missing_aes = "weight", @@ -79,8 +16,8 @@ StatYdensity <- ggproto("StatYdensity", Stat, extra_params = c("na.rm", "orientation"), compute_group = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, - kernel = "gaussian", trim = TRUE, na.rm = FALSE, - drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf)) { + kernel = "gaussian", trim = TRUE, na.rm = FALSE, + drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf)) { if (nrow(data) < 2) { if (isTRUE(drop)) { cli::cli_warn(c( @@ -88,7 +25,7 @@ StatYdensity <- ggproto("StatYdensity", Stat, i = paste0( "Set {.code drop = FALSE} to consider such groups for position ", "adjustment purposes." - ))) + ))) return(data_frame0()) } ans <- data_frame0(x = data$x, n = nrow(data)) @@ -135,15 +72,15 @@ StatYdensity <- ggproto("StatYdensity", Stat, # choose how violins are scaled relative to each other data$violinwidth <- switch(scale, - # area : keep the original densities but scale them to a max width of 1 - # for plotting purposes only - area = data$density / max(data$density, na.rm = TRUE), - # count: use the original densities scaled to a maximum of 1 (as above) - # and then scale them according to the number of observations - count = data$density / max(data$density, na.rm = TRUE) * - data$n / max(data$n), - # width: constant width (density scaled to a maximum of 1) - width = data$scaled + # area : keep the original densities but scale them to a max width of 1 + # for plotting purposes only + area = data$density / max(data$density, na.rm = TRUE), + # count: use the original densities scaled to a maximum of 1 (as above) + # and then scale them according to the number of observations + count = data$density / max(data$density, na.rm = TRUE) * + data$n / max(data$n), + # width: constant width (density scaled to a maximum of 1) + width = data$scaled ) data$flipped_aes <- flipped_aes flip_data(data, flipped_aes) @@ -152,6 +89,36 @@ StatYdensity <- ggproto("StatYdensity", Stat, dropped_aes = "weight" ) +#' @inheritParams layer +#' @inheritParams geom_point +#' @inheritParams stat_density +#' @param scale if "area" (default), all violins have the same area (before trimming +#' the tails). If "count", areas are scaled proportionally to the number of +#' observations. If "width", all violins have the same maximum width. +#' @param drop Whether to discard groups with less than 2 observations +#' (`TRUE`, default) or keep such groups for position adjustment purposes +#' (`FALSE`). +#' +#' @eval rd_computed_vars( +#' density = "Density estimate.", +#' scaled = "Density estimate, scaled to a maximum of 1.", +#' count = "Density * number of points - probably useless for violin +#' plots.", +#' violinwidth = "Density scaled for the violin plot, according to area, +#' counts or to a constant maximum width.", +#' n = "Number of points.", +#' width = "Width of violin bounding box." +#' ) +#' +#' @seealso [geom_violin()] for examples, and [stat_density()] +#' for examples with data along the x axis. +#' @export +#' @rdname geom_violin +stat_ydensity <- make_constructor( + StatYdensity, geom = "violin", position = "dodge", + checks = exprs(scale <- arg_match0(scale, c("area", "count", "width"))) +) + calc_bw <- function(x, bw) { if (is.character(bw)) { if (length(x) < 2) { From c7abdd7735afd722db80d0cb0c31179f0855b8bc Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 15:24:06 +0100 Subject: [PATCH 18/22] revert 4dd78b5c for `layer_sf()` stats --- R/stat-sf-coordinates.R | 115 +++++++++++++++++++++++----------------- R/stat-sf.R | 18 ++++++- 2 files changed, 84 insertions(+), 49 deletions(-) diff --git a/R/stat-sf-coordinates.R b/R/stat-sf-coordinates.R index ce8391c0ac..b54c8f6376 100644 --- a/R/stat-sf-coordinates.R +++ b/R/stat-sf-coordinates.R @@ -1,50 +1,3 @@ -#' @rdname stat_sf_coordinates -#' @usage NULL -#' @format NULL -#' @export -StatSfCoordinates <- ggproto( - "StatSfCoordinates", Stat, - - compute_layer = function(self, data, params, layout) { - # add coord to the params, so it can be forwarded to compute_group() - params$coord <- layout$coord - ggproto_parent(Stat, self)$compute_layer(data, params, layout) - }, - - compute_group = function(self, data, scales, coord, fun.geometry = NULL) { - if (is.null(fun.geometry)) { - fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x)) - } - - points_sfc <- fun.geometry(data$geometry) - - if (inherits(coord, "CoordSf")) { - # register bounding box if the coord derives from CoordSf - bbox <- sf::st_bbox(points_sfc) - - coord$record_bbox( - xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], - ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] - ) - - # transform to the coord's default crs if possible - default_crs <- coord$get_default_crs() - if (!(is.null(default_crs) || is.na(default_crs) || - is.na(sf::st_crs(points_sfc)))) { - points_sfc <- sf::st_transform(points_sfc, default_crs) - } - } - coordinates <- sf::st_coordinates(points_sfc) - data$x <- coordinates[, "X"] - data$y <- coordinates[, "Y"] - - data - }, - - default_aes = aes(x = after_stat(x), y = after_stat(y)), - required_aes = c("geometry") -) - #' Extract coordinates from 'sf' objects #' #' `stat_sf_coordinates()` extracts the coordinates from 'sf' objects and @@ -103,4 +56,70 @@ StatSfCoordinates <- ggproto( #' will be used. Note that the function may warn about the incorrectness of #' the result if the data is not projected, but you can ignore this except #' when you really care about the exact locations. -stat_sf_coordinates <- make_constructor(StatSfCoordinates, geom = "point") +stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point", + position = "identity", na.rm = FALSE, + show.legend = NA, inherit.aes = TRUE, + fun.geometry = NULL, + ...) { + layer_sf( + stat = StatSfCoordinates, + data = data, + mapping = mapping, + geom = geom, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + fun.geometry = fun.geometry, + ... + ) + ) +} + +#' @rdname stat_sf_coordinates +#' @usage NULL +#' @format NULL +#' @export +StatSfCoordinates <- ggproto( + "StatSfCoordinates", Stat, + + compute_layer = function(self, data, params, layout) { + # add coord to the params, so it can be forwarded to compute_group() + params$coord <- layout$coord + ggproto_parent(Stat, self)$compute_layer(data, params, layout) + }, + + compute_group = function(self, data, scales, coord, fun.geometry = NULL) { + if (is.null(fun.geometry)) { + fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x)) + } + + points_sfc <- fun.geometry(data$geometry) + + if (inherits(coord, "CoordSf")) { + # register bounding box if the coord derives from CoordSf + bbox <- sf::st_bbox(points_sfc) + + coord$record_bbox( + xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], + ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] + ) + + # transform to the coord's default crs if possible + default_crs <- coord$get_default_crs() + if (!(is.null(default_crs) || is.na(default_crs) || + is.na(sf::st_crs(points_sfc)))) { + points_sfc <- sf::st_transform(points_sfc, default_crs) + } + } + coordinates <- sf::st_coordinates(points_sfc) + data$x <- coordinates[, "X"] + data$y <- coordinates[, "Y"] + + data + }, + + default_aes = aes(x = after_stat(x), y = after_stat(y)), + required_aes = c("geometry") +) diff --git a/R/stat-sf.R b/R/stat-sf.R index d5170d1a67..cf0b55c0ec 100644 --- a/R/stat-sf.R +++ b/R/stat-sf.R @@ -59,5 +59,21 @@ StatSf <- ggproto("StatSf", Stat, #' @export #' @rdname ggsf #' @inheritParams stat_identity -stat_sf <- make_constructor(StatSf, geom = "rect") +stat_sf <- function(mapping = NULL, data = NULL, geom = "rect", + position = "identity", na.rm = FALSE, show.legend = NA, + inherit.aes = TRUE, ...) { + layer_sf( + stat = StatSf, + data = data, + mapping = mapping, + geom = geom, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + ... + ) + ) +} From d1043b0998cb12d064b23fb3ad1b597c77c97d9d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 15:26:23 +0100 Subject: [PATCH 19/22] mechanism to hide internal variables --- R/make-constructor.R | 10 ++++++---- R/stat-align.R | 2 +- R/stat-bin2d.R | 5 ++++- R/stat-boxplot.R | 2 +- R/stat-contour.R | 10 ++++++++-- R/stat-count.R | 2 +- R/stat-density.R | 5 ++++- R/stat-qq-line.R | 2 +- R/stat-quantilemethods.R | 5 ++++- R/stat-smooth.R | 2 +- R/stat-summary-2d.R | 5 ++++- R/stat-ydensity.R | 3 ++- 12 files changed, 37 insertions(+), 16 deletions(-) diff --git a/R/make-constructor.R b/R/make-constructor.R index 15bbe3d683..62ccde8464 100644 --- a/R/make-constructor.R +++ b/R/make-constructor.R @@ -44,7 +44,8 @@ make_constructor <- function(x, ...) { #' @export #' @rdname make_constructor -make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) { +make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(), + env = caller_env()) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) @@ -61,7 +62,7 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) # Fill in values for parameters from draw functions known_params <- - unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics())) + unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics(), omit)) missing_params <- setdiff(x$parameters(), known_params) if (length(missing_params) > 0) { draw_args <- ggproto_formals(x$draw_panel) @@ -128,7 +129,8 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), env = caller_env()) #' @export #' @rdname make_constructor -make_constructor.Stat <- function(x, ..., checks = exprs(), env = caller_env()) { +make_constructor.Stat <- function(x, ..., checks = exprs(), omit = character(), + env = caller_env()) { # Check that we can independently find the stat stat <- gsub("^stat_", "", snake_class(x)) check_subclass(stat, "Stat", env = env) @@ -143,7 +145,7 @@ make_constructor.Stat <- function(x, ..., checks = exprs(), env = caller_env()) } known_params <- - unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics())) + unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics(), omit)) missing_params <- setdiff(x$parameters(), known_params) # Fill in missing parameters from the compute methods diff --git a/R/stat-align.R b/R/stat-align.R index 85eb598c53..48d6481ade 100644 --- a/R/stat-align.R +++ b/R/stat-align.R @@ -82,5 +82,5 @@ StatAlign <- ggproto( #' @rdname geom_ribbon stat_align <- make_constructor( StatAlign, geom = "area", - exclude = c("unique_loc", "adjust") + omit = c("unique_loc", "adjust") ) diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index c8767d2cb5..254a8ac8dd 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -57,7 +57,10 @@ StatBin2d <- ggproto( #' ncount = "count, scaled to maximum of 1.", #' ndensity = "density, scaled to a maximum of 1." #' ) -stat_bin_2d <- make_constructor(StatBin2d, geom = "tile") +stat_bin_2d <- make_constructor( + StatBin2d, geom = "tile", + omit = c("breaks", "origin") +) #' @export #' @rdname geom_bin_2d diff --git a/R/stat-boxplot.R b/R/stat-boxplot.R index 23ac463244..77336cb547 100644 --- a/R/stat-boxplot.R +++ b/R/stat-boxplot.R @@ -108,5 +108,5 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, #' ) stat_boxplot <- make_constructor( StatBoxplot, geom = "boxplot", position = "dodge2", - orientation = NA + orientation = NA, omit = "width" ) diff --git a/R/stat-contour.R b/R/stat-contour.R index 4bf9261d45..c70f48eebb 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -100,11 +100,17 @@ StatContourFilled <- ggproto( #' #' #' @rdname geom_contour -stat_contour <- make_constructor(StatContour, geom = "contour") +stat_contour <- make_constructor( + StatContour, geom = "contour", + omit = "z.range" +) #' @rdname geom_contour #' @export -stat_contour_filled <- make_constructor(StatContourFilled, geom = "contour_filled") +stat_contour_filled <- make_constructor( + StatContourFilled, geom = "contour_filled", + omit = "z.range" +) #' Calculate the breaks used for contouring #' diff --git a/R/stat-count.R b/R/stat-count.R index b0a2ed282d..7768b9e191 100644 --- a/R/stat-count.R +++ b/R/stat-count.R @@ -66,5 +66,5 @@ StatCount <- ggproto( #' @rdname geom_bar stat_count <- make_constructor( StatCount, geom = "bar", position = "stack", - orientation = NA + orientation = NA, omit = "width" ) diff --git a/R/stat-density.R b/R/stat-density.R index e4a8193fee..7614c99000 100644 --- a/R/stat-density.R +++ b/R/stat-density.R @@ -76,7 +76,10 @@ StatDensity <- ggproto( #' ) #' @export #' @rdname geom_density -stat_density <- make_constructor(StatDensity, geom = "area", position = "stack") +stat_density <- make_constructor( + StatDensity, geom = "area", position = "stack", + orientation = NA +) compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 4de59ec4d2..7bbe31be7f 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -56,7 +56,7 @@ StatQqLine <- ggproto( #' defaults to `c(.25, .75)`. #' @param fullrange Should the q-q line span the full range of the plot, or just #' the data -geom_qq_line <- make_constructor(StatQqLine, geom = "path") +geom_qq_line <- make_constructor(StatQqLine, geom = "path", omit = "quantiles") #' @export #' @rdname geom_qq diff --git a/R/stat-quantilemethods.R b/R/stat-quantilemethods.R index 681b2348a7..48f30bbdfe 100644 --- a/R/stat-quantilemethods.R +++ b/R/stat-quantilemethods.R @@ -73,7 +73,10 @@ StatQuantile <- ggproto( #' ) #' @export #' @rdname geom_quantile -stat_quantile <- make_constructor(StatQuantile, geom = "quantile") +stat_quantile <- make_constructor( + StatQuantile, geom = "quantile", + omit = c("xseq", "lambda") +) quant_pred <- function(quantile, data, method, formula, weight, grid, method.args = method.args) { diff --git a/R/stat-smooth.R b/R/stat-smooth.R index 6fb12772a7..f2ebc2e22b 100644 --- a/R/stat-smooth.R +++ b/R/stat-smooth.R @@ -174,7 +174,7 @@ StatSmooth <- ggproto( #' ) #' @export #' @rdname geom_smooth -stat_smooth <- make_constructor(StatSmooth, geom = "smooth") +stat_smooth <- make_constructor(StatSmooth, geom = "smooth", orientation = NA) # This function exists to silence an undeclared import warning gam_method <- function() { diff --git a/R/stat-summary-2d.R b/R/stat-summary-2d.R index fe524b3863..4bf72d6b1a 100644 --- a/R/stat-summary-2d.R +++ b/R/stat-summary-2d.R @@ -86,7 +86,10 @@ StatSummary2d <- ggproto( #' d + stat_summary_hex() #' d + stat_summary_hex(fun = ~ sum(.x^2)) #' } -stat_summary_2d <- make_constructor(StatSummary2d, geom = "tile") +stat_summary_2d <- make_constructor( + StatSummary2d, geom = "tile", + omit = c("breaks", "origin") +) #' @export #' @rdname stat_summary_2d diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 1930b16fd4..e71260cde3 100644 --- a/R/stat-ydensity.R +++ b/R/stat-ydensity.R @@ -116,7 +116,8 @@ StatYdensity <- ggproto( #' @rdname geom_violin stat_ydensity <- make_constructor( StatYdensity, geom = "violin", position = "dodge", - checks = exprs(scale <- arg_match0(scale, c("area", "count", "width"))) + checks = exprs(scale <- arg_match0(scale, c("area", "count", "width"))), + orientation = NA, omit = "width" ) calc_bw <- function(x, bw) { From a68e4bb0f95499fdd8afbb801aa6d948a067e4f2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 15:29:33 +0100 Subject: [PATCH 20/22] document --- R/make-constructor.R | 3 +++ man/geom_bar.Rd | 2 +- man/geom_bin_2d.Rd | 8 ++++---- man/geom_boxplot.Rd | 2 +- man/geom_density.Rd | 14 +++++++------- man/geom_density_2d.Rd | 8 ++++---- man/geom_hex.Rd | 8 ++++---- man/geom_histogram.Rd | 12 ++++++------ man/geom_qq.Rd | 2 ++ man/geom_smooth.Rd | 2 +- man/geom_violin.Rd | 16 ++++++++-------- man/make_constructor.Rd | 21 ++++++++++++++++++++- man/stat_identity.Rd | 4 ++++ man/stat_summary_2d.Rd | 10 +++++----- 14 files changed, 70 insertions(+), 42 deletions(-) diff --git a/R/make-constructor.R b/R/make-constructor.R index 62ccde8464..dcf54eff6a 100644 --- a/R/make-constructor.R +++ b/R/make-constructor.R @@ -13,6 +13,9 @@ NULL #' constructor. For layers, these are passed on to [`layer(params)`][layer()]. #' @param checks A list of calls to be evaluated before construction of the #' object, such as one constructed with [`exprs()`][rlang::exprs()]. +#' @param omit A character vector of automatically retrieved argument names +#' that should not be converted to user-facing arguments. Useful for +#' internally computed variables. #' @param env An environment to search for the object. #' #' @return A function diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index eb8855f587..45d5666759 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -40,8 +40,8 @@ stat_count( geom = "bar", position = "stack", ..., - na.rm = FALSE, orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) diff --git a/man/geom_bin_2d.Rd b/man/geom_bin_2d.Rd index 121cf0765c..d639102866 100644 --- a/man/geom_bin_2d.Rd +++ b/man/geom_bin_2d.Rd @@ -26,8 +26,8 @@ stat_bin_2d( geom = "tile", position = "identity", ..., - bins = 30, binwidth = NULL, + bins = 30, drop = TRUE, na.rm = FALSE, show.legend = NA, @@ -121,12 +121,12 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - \item{binwidth}{Numeric vector giving bin width in both vertical and horizontal directions. Overrides \code{bins} if both set.} +\item{bins}{numeric vector giving number of bins in both vertical and +horizontal directions. Set to 30 by default.} + \item{drop}{if \code{TRUE} removes all cells with 0 counts.} } \description{ diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index 3fc39d212b..ac8d6daacb 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -35,9 +35,9 @@ stat_boxplot( geom = "boxplot", position = "dodge2", ..., + orientation = NA, coef = 1.5, na.rm = FALSE, - orientation = NA, show.legend = NA, inherit.aes = TRUE ) diff --git a/man/geom_density.Rd b/man/geom_density.Rd index 1ae3ea371d..4a2858b2a1 100644 --- a/man/geom_density.Rd +++ b/man/geom_density.Rd @@ -26,14 +26,14 @@ stat_density( geom = "area", position = "stack", ..., + orientation = NA, bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, trim = FALSE, - na.rm = FALSE, bounds = c(-Inf, Inf), - orientation = NA, + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -131,6 +131,11 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} +\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{bw}{The smoothing bandwidth to be used. If numeric, the standard deviation of the smoothing kernel. If character, a rule to choose the bandwidth, as listed in @@ -159,11 +164,6 @@ one plot or if you are manually adjusting the scale limits.} finite, boundary effect of default density estimation will be corrected by reflecting tails outside \code{bounds} around their closest edge. Data points outside of bounds are removed with a warning.} - -\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.} } \description{ Computes and draws kernel density estimate, which is a smoothed version of diff --git a/man/geom_density_2d.Rd b/man/geom_density_2d.Rd index f063cfdd4a..38eb2027ef 100644 --- a/man/geom_density_2d.Rd +++ b/man/geom_density_2d.Rd @@ -46,9 +46,9 @@ stat_density_2d( ..., contour = TRUE, contour_var = "density", - n = 100, h = NULL, adjust = c(1, 1), + n = 100, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -62,9 +62,9 @@ stat_density_2d_filled( ..., contour = TRUE, contour_var = "density", - n = 100, h = NULL, adjust = c(1, 1), + n = 100, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -155,8 +155,6 @@ overriding these connections, see how the \link[=layer_stats]{stat} and \item{contour}{If \code{TRUE}, contour the results of the 2d density estimation.} -\item{n}{Number of grid points in each direction.} - \item{h}{Bandwidth (vector of length two). If \code{NULL}, estimated using \code{\link[MASS:bandwidth.nrd]{MASS::bandwidth.nrd()}}.} @@ -164,6 +162,8 @@ using \code{\link[MASS:bandwidth.nrd]{MASS::bandwidth.nrd()}}.} 'NULL'. This makes it possible to adjust the bandwidth while still using the a bandwidth estimator. For example, \code{adjust = 1/2} means use half of the default bandwidth.} + +\item{n}{Number of grid points in each direction.} } \description{ Perform a 2D kernel density estimation using \code{\link[MASS:kde2d]{MASS::kde2d()}} and diff --git a/man/geom_hex.Rd b/man/geom_hex.Rd index 0079b1e89c..5306211e4e 100644 --- a/man/geom_hex.Rd +++ b/man/geom_hex.Rd @@ -26,8 +26,8 @@ stat_bin_hex( geom = "hex", position = "identity", ..., - bins = 30, binwidth = NULL, + bins = 30, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -121,11 +121,11 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \code{stat_bin_hex()}. For more information about overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - \item{binwidth}{Numeric vector giving bin width in both vertical and horizontal directions. Overrides \code{bins} if both set.} + +\item{bins}{numeric vector giving number of bins in both vertical and +horizontal directions. Set to 30 by default.} } \description{ Divides the plane into regular hexagons, counts the number of cases in diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index fbf7b29184..1c25dc166f 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -40,15 +40,15 @@ stat_bin( geom = "bar", position = "stack", ..., + orientation = NA, binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, - breaks = NULL, closed = c("right", "left"), pad = FALSE, + breaks = NULL, na.rm = FALSE, - orientation = NA, show.legend = NA, inherit.aes = TRUE ) @@ -169,15 +169,15 @@ if \code{0} is outside the range of the data. Alternatively, this same alignment can be specified with \code{binwidth = 1} and \code{boundary = 0.5}, even if \code{0.5} is outside the range of the data.} -\item{breaks}{Alternatively, you can supply a numeric vector giving -the bin boundaries. Overrides \code{binwidth}, \code{bins}, \code{center}, -and \code{boundary}. Can also be a function that takes group-wise values as input and returns bin boundaries.} - \item{closed}{One of \code{"right"} or \code{"left"} indicating whether right or left edges of bins are included in the bin.} \item{pad}{If \code{TRUE}, adds empty bins at either end of x. This ensures frequency polygons touch 0. Defaults to \code{FALSE}.} + +\item{breaks}{Alternatively, you can supply a numeric vector giving +the bin boundaries. Overrides \code{binwidth}, \code{bins}, \code{center}, +and \code{boundary}. Can also be a function that takes group-wise values as input and returns bin boundaries.} } \description{ Visualise the distribution of a single continuous variable by dividing diff --git a/man/geom_qq.Rd b/man/geom_qq.Rd index d450b3d948..c5bb130928 100644 --- a/man/geom_qq.Rd +++ b/man/geom_qq.Rd @@ -43,6 +43,7 @@ geom_qq( geom = "point", position = "identity", ..., + quantiles = NULL, distribution = stats::qnorm, dparams = list(), na.rm = FALSE, @@ -56,6 +57,7 @@ stat_qq( geom = "point", position = "identity", ..., + quantiles = NULL, distribution = stats::qnorm, dparams = list(), na.rm = FALSE, diff --git a/man/geom_smooth.Rd b/man/geom_smooth.Rd index 6d89a61782..a8f72b34a7 100644 --- a/man/geom_smooth.Rd +++ b/man/geom_smooth.Rd @@ -26,6 +26,7 @@ stat_smooth( geom = "smooth", position = "identity", ..., + orientation = NA, method = NULL, formula = NULL, se = TRUE, @@ -36,7 +37,6 @@ stat_smooth( level = 0.95, method.args = list(), na.rm = FALSE, - orientation = NA, show.legend = NA, inherit.aes = TRUE ) diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index c3df4b9cbc..6e7ff30280 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -26,17 +26,17 @@ stat_ydensity( geom = "violin", position = "dodge", ..., + orientation = NA, bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, scale = "area", drop = TRUE, + bounds = c(-Inf, Inf), na.rm = FALSE, - orientation = NA, show.legend = NA, - inherit.aes = TRUE, - bounds = c(-Inf, Inf) + inherit.aes = TRUE ) } \arguments{ @@ -138,6 +138,11 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} +\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{bw}{The smoothing bandwidth to be used. If numeric, the standard deviation of the smoothing kernel. If character, a rule to choose the bandwidth, as listed in @@ -153,11 +158,6 @@ For example, \code{adjust = 1/2} means use half of the default bandwidth.} \item{drop}{Whether to discard groups with less than 2 observations (\code{TRUE}, default) or keep such groups for position adjustment purposes (\code{FALSE}).} - -\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.} } \description{ A violin plot is a compact display of a continuous distribution. It is a diff --git a/man/make_constructor.Rd b/man/make_constructor.Rd index 7b162c98f5..a1882e3252 100644 --- a/man/make_constructor.Rd +++ b/man/make_constructor.Rd @@ -3,11 +3,26 @@ \name{make_constructor} \alias{make_constructor} \alias{make_constructor.Geom} +\alias{make_constructor.Stat} \title{Produce boilerplate constructors} \usage{ make_constructor(x, ...) -\method{make_constructor}{Geom}(x, ..., checks = exprs(), env = caller_env()) +\method{make_constructor}{Geom}( + x, + ..., + checks = exprs(), + omit = character(), + env = caller_env() +) + +\method{make_constructor}{Stat}( + x, + ..., + checks = exprs(), + omit = character(), + env = caller_env() +) } \arguments{ \item{x}{An object to setup a constructor for.} @@ -18,6 +33,10 @@ constructor. For layers, these are passed on to \code{\link[=layer]{layer(params \item{checks}{A list of calls to be evaluated before construction of the object, such as one constructed with \code{\link[rlang:defusing-advanced]{exprs()}}.} +\item{omit}{A character vector of automatically retrieved argument names +that should not be converted to user-facing arguments. Useful for +internally computed variables.} + \item{env}{An environment to search for the object.} } \value{ diff --git a/man/stat_identity.Rd b/man/stat_identity.Rd index f5dd6e1a5d..64ffa0d494 100644 --- a/man/stat_identity.Rd +++ b/man/stat_identity.Rd @@ -10,6 +10,7 @@ stat_identity( geom = "point", position = "identity", ..., + na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) @@ -89,6 +90,9 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{na.rm}{If \code{FALSE}, the default, missing values are removed with +a warning. If \code{TRUE}, missing values are silently removed.} + \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. diff --git a/man/stat_summary_2d.Rd b/man/stat_summary_2d.Rd index 9ee4604b65..ad9c7d004a 100644 --- a/man/stat_summary_2d.Rd +++ b/man/stat_summary_2d.Rd @@ -12,8 +12,8 @@ stat_summary_2d( geom = "tile", position = "identity", ..., - bins = 30, binwidth = NULL, + bins = 30, drop = TRUE, fun = "mean", fun.args = list(), @@ -28,8 +28,8 @@ stat_summary_hex( geom = "hex", position = "identity", ..., - bins = 30, binwidth = NULL, + bins = 30, drop = TRUE, fun = "mean", fun.args = list(), @@ -113,12 +113,12 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - \item{binwidth}{Numeric vector giving bin width in both vertical and horizontal directions. Overrides \code{bins} if both set.} +\item{bins}{numeric vector giving number of bins in both vertical and +horizontal directions. Set to 30 by default.} + \item{drop}{drop if the output of \code{fun} is \code{NA}.} \item{fun}{function for summary.} From 6c95f245cf1419e23ca1b013358a475359bf57dd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 15:48:14 +0100 Subject: [PATCH 21/22] make GeomCol parent of `geom_col()` again for error message purposes --- R/geom-col.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/geom-col.R b/R/geom-col.R index cb752986cd..8a4fc2eaf9 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,7 +1,3 @@ -#' @export -#' @rdname geom_bar -geom_col <- make_constructor(GeomBar, position = "stack", just = 0.5) - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -9,3 +5,7 @@ geom_col <- make_constructor(GeomBar, position = "stack", just = 0.5) #' @include geom-rect.R # TODO: deprecate this GeomCol <- ggproto("GeomCol", GeomBar) + +#' @export +#' @rdname geom_bar +geom_col <- make_constructor(GeomCol, position = "stack", just = 0.5) From 52e66f26e12f7e8d9ad5edc2f06fdb8add1611da Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 28 Nov 2024 17:06:11 +0100 Subject: [PATCH 22/22] rebalance omissions --- R/geom-linerange.R | 2 -- R/stat-qq.R | 2 +- man/geom_linerange.Rd | 3 --- man/geom_qq.Rd | 2 -- 4 files changed, 1 insertion(+), 8 deletions(-) diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 9493d72690..e0d217c99f 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -59,8 +59,6 @@ GeomLinerange <- ggproto( #' @export #' @inheritParams layer #' @inheritParams geom_bar -#' @param width Bar width. By default, set to 90% of the [`resolution()`] of -#' the data. #' @examples #' # Create a simple example dataset #' df <- data.frame( diff --git a/R/stat-qq.R b/R/stat-qq.R index 6526067928..68eea4e4cd 100644 --- a/R/stat-qq.R +++ b/R/stat-qq.R @@ -80,7 +80,7 @@ StatQq <- ggproto( #' stat_qq() + #' stat_qq_line() #' } -geom_qq <- make_constructor(StatQq, geom = "point") +geom_qq <- make_constructor(StatQq, geom = "point", omit = "quantiles") #' @export #' @rdname geom_qq diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 811b9b0686..0a508b3a27 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -179,9 +179,6 @@ that define both data and aesthetics and shouldn't inherit behaviour from the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \item{lineend}{Line end style (round, butt, square).} - -\item{width}{Bar width. By default, set to 90\% of the \code{\link[=resolution]{resolution()}} of -the data.} } \description{ Various ways of representing a vertical interval defined by \code{x}, diff --git a/man/geom_qq.Rd b/man/geom_qq.Rd index 08b8891a34..d6bedf3427 100644 --- a/man/geom_qq.Rd +++ b/man/geom_qq.Rd @@ -43,7 +43,6 @@ geom_qq( geom = "point", position = "identity", ..., - quantiles = NULL, distribution = stats::qnorm, dparams = list(), na.rm = FALSE, @@ -57,7 +56,6 @@ stat_qq( geom = "point", position = "identity", ..., - quantiles = NULL, distribution = stats::qnorm, dparams = list(), na.rm = FALSE,