diff --git a/DESCRIPTION b/DESCRIPTION index 0d36d4b..d592f31 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: ggpattern Type: Package Title: 'ggplot2' Pattern Geoms -Version: 1.1.0-7 +Version: 1.1.0-8 Authors@R: c(person("Mike", "FC", role = "aut"), person("Trevor L.", "Davis", role = c("aut", "cre"), email = "trevor.l.davis@gmail.com", @@ -15,13 +15,15 @@ Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.1 Imports: - ggplot2 (>= 3.5.0), + cli, + ggplot2 (>= 3.5.1), glue, grid, gridpattern (>= 1.2.0-4), lifecycle, - rlang, + rlang (>= 1.1.3), scales, + vctrs Suggests: ambient, dplyr, @@ -47,7 +49,6 @@ Collate: 'aaa-ggplot2-scale-manual.R' 'aaa-ggplot2-utilities-grid.R' 'aaa-ggplot2-utilities.R' - 'aab-utils.R' 'geom-.R' 'geom-rect.R' 'geom-bar.R' diff --git a/NAMESPACE b/NAMESPACE index 3ad1a7c..0c5ee25 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -198,10 +198,12 @@ import(glue) import(grid) import(rlang) import(scales) +import(vctrs) importFrom(grDevices,col2rgb) importFrom(grDevices,dev.off) importFrom(grDevices,png) importFrom(grDevices,rgb) +importFrom(lifecycle,deprecate_soft) importFrom(lifecycle,deprecated) importFrom(stats,setNames) importFrom(utils,head) diff --git a/NEWS.md b/NEWS.md index e1ecc77..c92733a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,10 @@ * The `draw_key_polygon_pattern()` called by `geom_sf_pattern()` is now passed in its actual aspect ratio (instead of 1). This may cause your legends to `geom_sf_pattern()` to look different. +* `outline.type = "legacy"` has been removed in + `geom_area_pattern()` and `geom_ribbon_pattern()`. + `outline.type = "legacy"` was deprecated with ggpattern 0.1.0 (2020-04-01). + Use `outline.type = "full"` instead. ## Deprecated features @@ -15,10 +19,18 @@ ## New features -* `geom_bar_pattern()` and `geom_col_pattern()` now accept argument `just`. - The `just` argument was added to `ggplot2::geom_bar()` and `ggplot2::geom_col()` with ggplot2 3.4.0. -* `geom_bin_2d_pattern()` is now an alias for `geom_bin2d_pattern()`. - This matches `{ggplot2}` which has both `geom_bin_2d()` and `geom_bin2d()`. +* Geoms now more consistently expose the `lineend` and `linejoin` parameters (#94). + This matches a similar upstream change in ggplot2 3.4.0. +* `geom_area_pattern()` and `geom_ribbon_pattern()` now accept `outline.type = "lower"` and `outline.type = "full"`. + `geom_density_pattern()` now exposes the `outline.type` parameter. +* `geom_bar_pattern()` and `geom_col_pattern()` now accept parameter `just`. + The `just` parameter was added to `ggplot2::geom_bar()` and `ggplot2::geom_col()` with ggplot2 3.4.0. +* `geom_boxplot_pattern()` now accept the `outliers` and `staplewidth` parameters. + The `outliers` and `staplewidth` parameters were added to `geom_boxplot()` in ggplot2 3.5.0. +* `geom_sf_pattern()` now accepts the `arrow` parameter. + The `arrow` parameter was added to `geom_sf()` in ggplot2 3.5.0. +* `geom_violin_pattern()` now accepts the `bounds` parameter. + The `bounds` parameter was added to `geom_violin()` in ggplot2 3.5.0. * Each pattern aesthetic may now be a list of vectors with each list element providing that aesthetic for a different pattern (#100). Most builtin `{gridpattern}` "geometry" patterns support multiple fill colors etc. which previously we could only access in `{ggpattern}` via custom patterns. @@ -26,6 +38,8 @@ (in addition to color strings) (#112). Note using gradient/pattern fills will require R (>= 4.2) and a graphics device with support for the gradient/pattern fill feature. Use of just color fills should continue to work on a wider variety of R versions and graphics devices. +* `geom_bin_2d_pattern()` is now an alias for `geom_bin2d_pattern()`. + This matches `{ggplot2}` which has both `geom_bin_2d()` and `geom_bin2d()`. ## Bug fixes and minor improvements diff --git a/R/aaa-ggplot2-compat-plyr.R b/R/aaa-ggplot2-compat-plyr.R index 8cfe4ac..10bb752 100644 --- a/R/aaa-ggplot2-compat-plyr.R +++ b/R/aaa-ggplot2-compat-plyr.R @@ -1,7 +1,6 @@ +# This file was copied (mostly untouched) from ggplot2 -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000 -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +defaults <- function(x, y) c(x, y[setdiff(names(y), names(x))]) #' Rename elements in a list, data.frame or vector #' diff --git a/R/aaa-ggplot2-performance.R b/R/aaa-ggplot2-performance.R index 0489051..12c856e 100644 --- a/R/aaa-ggplot2-performance.R +++ b/R/aaa-ggplot2-performance.R @@ -1,68 +1,5 @@ - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000 -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -# Fast data.frame constructor and indexing -# No checking, recycling etc. unless asked for -new_data_frame <- function(x = list(), n = NULL) { - if (length(x) != 0 && is.null(names(x))) { - abort("Elements must be named") - } - lengths <- vapply(x, length, integer(1)) - if (is.null(n)) { - n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths) - } - for (i in seq_along(x)) { - if (lengths[i] == n) next - if (lengths[i] != 1) { - abort("Elements must equal the number of rows or 1") - } - x[[i]] <- rep(x[[i]], n) - } - - class(x) <- "data.frame" - - attr(x, "row.names") <- .set_row_names(n) - x -} - -data_frame <- function(...) { - new_data_frame(list(...)) -} - -# data.frame <- function(...) { -# abort(glue(" -# Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. -# See the vignette 'ggplot2 internal programming guidelines' for details. -# ")) -# } - -split_matrix <- function(x, col_names = colnames(x)) { - force(col_names) - x <- lapply(seq_len(ncol(x)), function(i) x[, i]) - if (!is.null(col_names)) names(x) <- col_names - x -} - -mat_2_df <- function(x, col_names = colnames(x)) { - new_data_frame(split_matrix(x, col_names)) -} - -df_col <- function(x, name) .subset2(x, name) - -df_rows <- function(x, i) { - new_data_frame(lapply(x, `[`, i = i)) -} - # More performant modifyList without recursion modify_list <- function(old, new) { for (i in names(new)) old[[i]] <- new[[i]] old } -# modifyList <- function(...) { -# abort(glue(" -# Please use `modify_list()` instead of `modifyList()` for better performance. -# See the vignette 'ggplot2 internal programming guidelines' for details. -# ")) -# } diff --git a/R/aaa-ggplot2-utilities.R b/R/aaa-ggplot2-utilities.R index 9e3d140..914e20a 100644 --- a/R/aaa-ggplot2-utilities.R +++ b/R/aaa-ggplot2-utilities.R @@ -1,41 +1,3 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# This file was copied (mostly untouched) from ggplot2 v3.3.0.9000 -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -"%||%" <- function(a, b) { - if (!is.null(a)) a else b -} - -# Check required aesthetics are present -# This is used by geoms and stats to give a more helpful error message -# when required aesthetics are missing. -# -# @param character vector of required aesthetics -# @param character vector of present aesthetics -# @param name of object for error message -# @keyword internal -check_required_aesthetics <- function(required, present, name) { - if (is.null(required)) return() - - required <- strsplit(required, "|", fixed = TRUE) - if (any(vapply(required, length, integer(1)) > 1)) { - required <- lapply(required, rep_len, 2) - required <- list( - vapply(required, `[`, character(1), 1), - vapply(required, `[`, character(1), 2) - ) - } else { - required <- list(unlist(required)) - } - missing_aes <- lapply(required, setdiff, present) - if (any(vapply(missing_aes, length, integer(1)) == 0)) return() - - abort(glue( - "{name} requires the following missing aesthetics: ", - glue_collapse(lapply(missing_aes, glue_collapse, sep = ", ", last = " and "), sep = " or ") - )) -} - # Returns a logical vector of same length as nrow(x). If all data on a row # is finite (not NA, NaN, Inf, or -Inf) return TRUE; otherwise FALSE. cases <- function(x, fun) { @@ -78,11 +40,8 @@ binned_pal <- function(palette) { } } -is.formula <- function(x) inherits(x, "formula") - -warning_wrap <- function(...) { - msg <- paste(..., collapse = "", sep = "") - wrapped <- strwrap(msg, width = getOption("width") - 2) - warn(glue_collapse(wrapped, "\n", last = "\n")) -} +# Wrapping vctrs data_frame constructor with no name repair +data_frame0 <- function(...) data_frame(..., .name_repair = "minimal") +# Wrapping unique0() to accept NULL +unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...) diff --git a/R/aab-utils.R b/R/aab-utils.R deleted file mode 100644 index c61be58..0000000 --- a/R/aab-utils.R +++ /dev/null @@ -1,11 +0,0 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#' Combine two aes() mappings -#' -#' @param a1,a2 the two aes mappings or lists -#' @return combined aes mapping -#' @noRd -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -augment_aes <- function(a1, a2) { - a3 <- utils::modifyList(a1, a2, keep.null = TRUE) - do.call(aes, a3) -} diff --git a/R/geom-.R b/R/geom-.R index 421bffe..02d35ba 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -1,9 +1,6 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# This is the list of all pattern aesthetics. +# * This is the list of all pattern aesthetics. # * List is shared across every geom # * Not all aesthetics are used by all patterns. -# is only used by the 'point' pattern. -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ pattern_aesthetics <- aes( pattern = 'stripe', pattern_type = NA, @@ -46,60 +43,6 @@ pattern_aesthetics <- aes( pattern_res = getOption("ggpattern_res", NA) ) -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# Utils for debugging viewports -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -print_vp_tree <- function() { - startport <- grid::current.viewport()$name - on.exit({ - if (startport != 'ROOT') { - grid::seekViewport(startport) - } - }) - - # myvp <<- grid::current.viewport() - - while (TRUE) { - vp <- grid::current.viewport() - message( - "-------------- ", - sprintf("%20s", vp$name), - " ", - round(get_aspect_ratio(), 3) - ) - tmat <- grid::current.transform() - print(tmat) - message( - round(tmat[3, 1]/tmat[3, 2], 3), " ", - round(tmat[3, 2]/tmat[3, 1], 3) - ) - - if (vp$name == 'layout') { - # myll <<- grid::current.viewport() - } - - - if (vp$name == 'ROOT') { - message("ROOT. done") - break - } - - grid::upViewport() - } -} - - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# Utils for debugging viewports -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -verboseGrob <- function(name = "Viewport Tree") { - delayGrob({ - message("=================== ", name, " ===================") - print_vp_tree() - nullGrob() - }, list=list(name = name)) -} - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' Create the patterned area to be used in the legend key #' @inheritParams draw_key_polygon_pattern @@ -377,3 +320,11 @@ draw_key_crossbar_pattern <- function(data, params, size, aspect_ratio = get_asp key_grob_line ) } + +check_linewidth <- function(data, name) { + if (is.null(data$linewidth) && !is.null(data$size)) { + deprecate_soft("1.0.1", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic")) + data$linewidth <- data$size + } + data +} diff --git a/R/geom-bar.R b/R/geom-bar.R index 8a60903..55e96bf 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -123,7 +123,6 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL, orientation = NA, show.legend = NA, inherit.aes = TRUE) { - layer( data = data, mapping = mapping, @@ -132,7 +131,7 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( just = just, width = width, na.rm = na.rm, @@ -142,7 +141,6 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' Geom ggproto objects #' #' Geom ggproto objects that could be extended to create a new geom. @@ -150,12 +148,14 @@ geom_bar_pattern <- function(mapping = NULL, data = NULL, #' @seealso [ggplot2::Geom] #' #' @name ggpattern-ggproto +NULL + +#' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export #' @include geom-rect.R -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomBarPattern <- ggproto( - "GeomBarPattern", GeomRectPattern, +GeomBarPattern <- ggproto( "GeomBarPattern", GeomRectPattern, required_aes = c("x", "y"), # These aes columns are created by setup_data(). They need to be listed here so @@ -174,7 +174,10 @@ GeomBarPattern <- ggproto( data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE) * 0.9) + 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), @@ -184,10 +187,16 @@ GeomBarPattern <- ggproto( flip_data(data, params$flipped_aes) }, - draw_panel = function(self, data, panel_params, coord, - width = NULL, flipped_aes = FALSE) { + draw_panel = function(self, data, panel_params, coord, lineend = "butt", + linejoin = "mitre", width = NULL, flipped_aes = FALSE) { # Hack to ensure that width is detected as a parameter - ggproto_parent(GeomRectPattern, self)$draw_panel(data, panel_params, coord) + ggproto_parent(GeomRectPattern, self)$draw_panel( + data, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin + ) }, rename_size = TRUE ) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 084413c..3263103 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_bin_2d_pattern <- function(mapping = NULL, data = NULL, stat = "bin2d", position = "identity", ..., diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 4f8cc07..5447085 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -1,10 +1,9 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, stat = "boxplot", position = "dodge2", ..., + outliers = TRUE, outlier.colour = NULL, outlier.color = NULL, outlier.fill = NULL, @@ -14,6 +13,7 @@ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, + staplewidth = 0, varwidth = FALSE, na.rm = FALSE, orientation = NA, @@ -25,11 +25,14 @@ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, if (varwidth == TRUE) position <- position_dodge2(preserve = "single") } else { if (identical(position$preserve, "total") & varwidth == TRUE) { - warn("Can't preserve total widths when varwidth = TRUE.") + cli::cli_warn("Can't preserve total widths when {.code varwidth = TRUE}.") position$preserve <- "single" } } + stopifnot(is.numeric(staplewidth)) + stopifnot(is.logical(outliers)) + layer( data = data, mapping = mapping, @@ -38,7 +41,8 @@ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( + outliers = outliers, outlier.colour = outlier.color %||% outlier.colour, outlier.fill = outlier.fill, outlier.shape = outlier.shape, @@ -47,6 +51,7 @@ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, outlier.alpha = outlier.alpha, notch = notch, notchwidth = notchwidth, + staplewidth = staplewidth, varwidth = varwidth, na.rm = na.rm, orientation = orientation, @@ -55,29 +60,28 @@ geom_boxplot_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomBoxplotPattern <- ggproto( - "GeomBoxplotPattern", GeomBoxplot, +GeomBoxplotPattern <- ggproto("GeomBoxplotPattern", GeomBoxplot, - draw_group = function(self, data, panel_params, coord, fatten = 2, - outlier.colour = NULL, outlier.fill = NULL, - outlier.shape = 19, + draw_group = function(self, data, panel_params, coord, lineend = "butt", + linejoin = "mitre", fatten = 2, outlier.colour = NULL, + outlier.fill = NULL, outlier.shape = 19, outlier.size = 1.5, outlier.stroke = 0.5, - outlier.alpha = NULL, - notch = FALSE, notchwidth = 0.5, varwidth = FALSE, flipped_aes = FALSE) { + outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, + staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) { + data <- check_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) # this may occur when using geom_boxplot(stat = "identity") if (nrow(data) != 1) { - abort("Can't draw more than one boxplot per group. Did you forget aes(group = ...)?") + cli::cli_abort(c( + "Can only draw one boxplot per group.", + "i"= "Did you forget {.code aes(group = ...)}?" + )) } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Hack needed so that legend/key drawing knows something about sizing - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ common <- list( colour = data$colour, linewidth = data$linewidth, @@ -86,20 +90,18 @@ GeomBoxplotPattern <- ggproto( group = data$group ) - whiskers <- new_data_frame(c( - list( + whiskers <- data_frame0( x = c(data$x, data$x), xend = c(data$x, data$x), y = c(data$upper, data$lower), yend = c(data$ymax, data$ymin), - alpha = c(NA_real_, NA_real_) - ), - common - ), n = 2) + alpha = c(NA_real_, NA_real_), + !!!common, + .size = 2 + ) whiskers <- flip_data(whiskers, flipped_aes) - box <- new_data_frame(c( - list( + box <- data_frame0( xmin = data$xmin, xmax = data$xmax, ymin = data$lower, @@ -108,22 +110,19 @@ GeomBoxplotPattern <- ggproto( ynotchlower = ifelse(notch, data$notchlower, NA), ynotchupper = ifelse(notch, data$notchupper, NA), notchwidth = notchwidth, - alpha = data$alpha - ), - common - )) - + alpha = data$alpha, + !!!common + ) # Copy across all the pattern aesthetics for (varname in names(pattern_aesthetics)) { box[[varname]] <- data[[varname]] } - box <- flip_data(box, flipped_aes) - if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) { - outliers <- new_data_frame(list( + if (!is.null(data$outliers) && length(data$outliers[[1]]) >= 1) { + outliers <- data_frame0( y = data$outliers[[1]], x = data$x[1], colour = outlier.colour %||% data$colour[1], @@ -132,8 +131,9 @@ GeomBoxplotPattern <- ggproto( size = outlier.size %||% data$size[1], stroke = outlier.stroke %||% data$stroke[1], fill = NA, - alpha = outlier.alpha %||% data$alpha[1] - ), n = length(data$outliers[[1]])) + alpha = outlier.alpha %||% data$alpha[1], + .size = length(data$outliers[[1]]) + ) outliers <- flip_data(outliers, flipped_aes) outliers_grob <- GeomPoint$draw_panel(outliers, panel_params, coord) @@ -141,29 +141,47 @@ GeomBoxplotPattern <- ggproto( outliers_grob <- NULL } - ggname("geom_boxplot", grobTree( + if (staplewidth != 0) { + staples <- data_frame0( + x = rep((data$xmin - data$x) * staplewidth + data$x, 2), + xend = rep((data$xmax - data$x) * staplewidth + data$x, 2), + y = c(data$ymax, data$ymin), + yend = c(data$ymax, data$ymin), + alpha = c(NA_real_, NA_real_), + !!!common, + .size = 2 + ) + staples <- flip_data(staples, flipped_aes) + staple_grob <- GeomSegment$draw_panel( + staples, panel_params, coord, + lineend = lineend + ) + } else { + staple_grob <- NULL + } + + ggname("geom_boxplot_pattern", grobTree( outliers_grob, - GeomSegment$draw_panel(whiskers, panel_params, coord), - GeomCrossbarPattern$draw_panel(box, fatten = fatten, panel_params, coord, flipped_aes = flipped_aes), - grid::nullGrob() + staple_grob, + GeomSegment$draw_panel(whiskers, panel_params, coord, lineend = lineend), + GeomCrossbarPattern$draw_panel( + box, + fatten = fatten, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin, + flipped_aes = flipped_aes + ) )) }, - default_aes = augment_aes( - pattern_aesthetics, - aes( - weight = 1, - colour = "grey20", - fill = "white", - size = NULL, - alpha = NA, - shape = 19, - linetype = "solid", - linewidth = 0.5 - ) - ), - draw_key = function(self, ...) draw_key_boxplot_pattern(...), + default_aes = defaults(aes(weight = 1, colour = "grey20", fill = "white", size = NULL, + alpha = NA, shape = 19, linetype = "solid", linewidth = 0.5), + pattern_aesthetics + ), + rename_size = TRUE ) diff --git a/R/geom-col.R b/R/geom-col.R index 6a4c3da..a519aa0 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#' @rdname geom-docs geom_col_pattern <- function(mapping = NULL, data = NULL, position = "stack", ..., @@ -19,7 +17,7 @@ geom_col_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( just = just, width = width, na.rm = na.rm, @@ -28,10 +26,10 @@ geom_col_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export #' @include geom-rect.R -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# TODO: deprecate this GeomColPattern <- ggproto("GeomColPattern", GeomBarPattern) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 61b4328..1b83fa1 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#' @rdname geom-docs geom_crossbar_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., @@ -18,7 +16,7 @@ geom_crossbar_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( fatten = fatten, na.rm = na.rm, orientation = orientation, @@ -27,29 +25,24 @@ geom_crossbar_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomCrossbarPattern <- ggproto( - "GeomCrossbarPattern", GeomCrossbar, +GeomCrossbarPattern <- ggproto("GeomCrossbarPattern", GeomCrossbar, - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = "black", - fill = NA, - linewidth= 0.5, - linetype = 1, - alpha = NA - ) + + default_aes = defaults(aes(colour = "black", fill = NA, linewidth = 0.5, linetype = 1, + alpha = NA), + pattern_aesthetics ), draw_key = function(self, ...) draw_key_crossbar_pattern(...), - draw_panel = function(self, data, panel_params, coord, fatten = 2.5, width = NULL, flipped_aes = FALSE) { - + draw_panel = function(self, data, panel_params, coord, lineend = "butt", + linejoin = "mitre", fatten = 2.5, width = NULL, + flipped_aes = FALSE) { + data <- check_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA) @@ -59,14 +52,17 @@ GeomCrossbarPattern <- ggproto( if (has_notch) { if (data$ynotchlower < data$ymin || data$ynotchupper > data$ymax) - message("notch went outside hinges. Try setting notch=FALSE.") + cli::cli_inform(c( + "Notch went outside hinges", + i = "Do you want {.code notch = FALSE}?" + )) notchindent <- (1 - data$notchwidth) * (data$xmax - data$xmin) / 2 middle$x <- middle$x + notchindent middle$xend <- middle$xend - notchindent - box <- new_data_frame(list( + box <- data_frame0( x = c( data$xmin, data$xmin, data$xmin + notchindent, data$xmin, data$xmin, data$xmax, data$xmax, data$xmax - notchindent, data$xmax, data$xmax, @@ -83,7 +79,7 @@ GeomCrossbarPattern <- ggproto( linetype = rep(data$linetype, 11), fill = rep(data$fill, 11), group = rep(seq_len(nrow(data)), 11) - )) + ) # Copy across all the pattern aesthetics for (varname in names(pattern_aesthetics)) { @@ -91,7 +87,7 @@ GeomCrossbarPattern <- ggproto( } } else { # No notch - box <- new_data_frame(list( + box <- data_frame0( x = c(data$xmin, data$xmin, data$xmax, data$xmax, data$xmin), y = c(data$ymax, data$ymin, data$ymin, data$ymax, data$ymax), alpha = rep(data$alpha, 5), @@ -99,8 +95,8 @@ GeomCrossbarPattern <- ggproto( linewidth = rep(data$linewidth, 5), linetype = rep(data$linetype, 5), fill = rep(data$fill, 5), - group = rep(seq_len(nrow(data)), 5) - )) + group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group + ) # Copy across all the pattern aesthetics for (varname in names(pattern_aesthetics)) { @@ -110,10 +106,11 @@ GeomCrossbarPattern <- ggproto( box <- flip_data(box, flipped_aes) middle <- flip_data(middle, flipped_aes) - ggname("geom_crossbar", gTree(children = gList( - GeomPolygonPattern$draw_panel(box, panel_params, coord), - GeomSegment$draw_panel(middle, panel_params, coord) + ggname("geom_crossbar_pattern", gTree(children = gList( + GeomPolygonPattern$draw_panel(box, panel_params, coord, lineend = lineend, linejoin = linejoin), + GeomSegment$draw_panel(middle, panel_params, coord, lineend = lineend, linejoin = linejoin) ))) }, + rename_size = TRUE ) diff --git a/R/geom-density.R b/R/geom-density.R index c098ee8..d660987 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -1,14 +1,14 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_density_pattern <- function(mapping = NULL, data = NULL, stat = "density", position = "identity", ..., na.rm = FALSE, orientation = NA, show.legend = NA, - inherit.aes = TRUE) { + inherit.aes = TRUE, + outline.type = "upper") { + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) layer( data = data, @@ -18,32 +18,23 @@ geom_density_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( na.rm = na.rm, orientation = orientation, + outline.type = outline.type, ... ) ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL -#' @include geom-ribbon.R +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomDensityPattern <- ggproto( - "GeomDensityPattern", GeomAreaPattern, - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = 'black', - fill = "NA", - linewidth= 0.5, - linetype = 1, - weight = 1, - alpha = NA - ) - ), - rename_size = TRUE +#' @include geom-ribbon.R +GeomDensityPattern <- ggproto("GeomDensityPattern", GeomAreaPattern, + default_aes = defaults( + aes(fill = NA, weight = 1, colour = "black", alpha = NA), + defaults(GeomArea$default_aes, pattern_aesthetics) + ) ) diff --git a/R/geom-histogram.R b/R/geom-histogram.R index 678b45f..f0e1752 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -1,15 +1,30 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_histogram_pattern <- function (mapping = NULL, data = NULL, - stat = "bin", position = "stack", ..., - binwidth = NULL, bins = NULL, na.rm = FALSE, + 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 = GeomBarPattern, - position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list(binwidth = binwidth, bins = bins, na.rm = na.rm, - orientation = orientation, pad = FALSE, ...)) + show.legend = NA, + inherit.aes = TRUE) { + + layer( + data = data, + mapping = mapping, + stat = stat, + geom = GeomBarPattern, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + binwidth = binwidth, + bins = bins, + na.rm = na.rm, + orientation = orientation, + pad = FALSE, + ... + ) + ) } diff --git a/R/geom-map.R b/R/geom-map.R index 28a91a8..e3d3280 100644 --- a/R/geom-map.R +++ b/R/geom-map.R @@ -1,10 +1,8 @@ #' @include geom-polygon.R NULL -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_map_pattern <- function(mapping = NULL, data = NULL, stat = "identity", ..., @@ -13,14 +11,12 @@ geom_map_pattern <- function(mapping = NULL, data = NULL, show.legend = NA, inherit.aes = TRUE) { # Get map input into correct form - if (!is.data.frame(map)) { - abort("`map` must be a data.frame") - } + stopifnot(is.data.frame(map)) if (!is.null(map$lat)) map$y <- map$lat if (!is.null(map$long)) map$x <- map$long if (!is.null(map$region)) map$id <- map$region if (!all(c("x", "y", "id") %in% names(map))) { - abort("`map` must have the columns `x`, `y`, and `id`") + cli::cli_abort("{.arg map} must have the columns {.col x}, {.col y}, and {.col id}.") } layer( @@ -31,7 +27,7 @@ geom_map_pattern <- function(mapping = NULL, data = NULL, position = PositionIdentity, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( map = map, na.rm = na.rm, ... @@ -39,39 +35,28 @@ geom_map_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomMapPattern <- ggproto( - "GeomMapPattern", GeomPolygonPattern, - draw_panel = function(data, panel_params, coord, map) { - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GeomMapPattern <- ggproto("GeomMapPattern", GeomPolygonPattern, + draw_panel = function(data, panel_params, coord, lineend = "butt", + linejoin = "round", linemitre = 10, map) { # Only use matching data and map ids - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ common <- intersect(data$map_id, map$id) data <- data[data$map_id %in% common, , drop = FALSE] map <- map[map$id %in% common, , drop = FALSE] - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Munch, then set up id variable for polygonGrob - # must be sequential integers - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - coords <- coord_munch(coord, map, panel_params) + coords <- coord_munch(coord, map, panel_params, is_closed = TRUE) coords$group <- coords$group %||% coords$id - grob_id <- match(coords$group, unique(coords$group)) + grob_id <- match(coords$group, unique0(coords$group)) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Align data with map - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ data_rows <- match(coords$id[!duplicated(grob_id)], data$map_id) data <- data[data_rows, , drop = FALSE] - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate all the boundary_dfs for all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ polygons <- split(coords, coords$group) boundary_dfs <- lapply(polygons, function(polygon) { create_polygon_df( @@ -80,40 +65,32 @@ GeomMapPattern <- ggproto( ) }) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate pattern grobs - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - all_params <- data - pattern_grobs <- grid::nullGrob() - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create the pattern grobs given the current params for every element - # (given in all_params), and the boundary_dfs of all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pattern_grobs <- create_pattern_grobs(all_params, boundary_dfs) + pattern_grobs <- create_pattern_grobs(data, boundary_dfs) col <- data$colour fill <- fill_alpha(data$fill, data$alpha) lwd <- data$linewidth * .pt - base_grob_fn <- function(col, fill, lwd) { - grid::polygonGrob( + polygon_grob_fn <- function(col, fill, lwd) { + polygonGrob( x = coords$x, y = coords$y, default.units = "native", id = grob_id, - gp = gpar(col = col, fill = fill, lwd = lwd) + gp = gpar(col = col, + fill = fill, + lwd = lwd, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) ) } - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Tree - final assembled grob tree - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - grid::grobTree( - base_grob_fn(NA, fill, NA), + grobTree( + polygon_grob_fn(NA, fill, 0), pattern_grobs, - base_grob_fn(col, NA, lwd) + polygon_grob_fn(col, NA, lwd) ) }, diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 8bced18..44f4a17 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_polygon_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", rule = "evenodd", @@ -17,7 +15,7 @@ geom_polygon_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( na.rm = na.rm, rule = rule, ... @@ -25,18 +23,18 @@ geom_polygon_pattern <- function(mapping = NULL, data = NULL, ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, - - draw_panel = function(self, data, panel_params, coord, rule = "evenodd") { + draw_panel = function(self, data, panel_params, coord, rule = "evenodd", + lineend = "butt", linejoin = "round", linemitre = 10) { + data <- check_linewidth(data, snake_class(self)) n <- nrow(data) if (n == 1) return(zeroGrob()) - munched <- coord_munch(coord, data, panel_params) + munched <- coord_munch(coord, data, panel_params, is_closed = TRUE) if (is.null(munched$subgroup)) { # Sort by group to make sure that colors, fill, etc. come in same order @@ -48,9 +46,6 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, first_idx <- !duplicated(munched$group) first_rows <- munched[first_idx, ] - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate all the boundary_dfs for all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ stopifnot(!is.null(munched$group)) polygons <- split(munched, munched$group) boundary_dfs <- lapply(polygons, function(polygon) { @@ -59,54 +54,43 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, y = polygon$y ) }) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # For polygons, every row in first_rows represents an element. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - all_params <- first_rows - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create the pattern grobs given the current params for every element - # (given in all_params), and the boundary_dfs of all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pattern_grobs <- create_pattern_grobs(all_params, boundary_dfs) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Adapt the returned geom to always be a grobTree with the - # pattern_grobs as the final element. Since the pattern grobs are - # drawn last, there can be z-ordering issues that the user will have - # to handle manually if there are overlapping elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + pattern_grobs <- create_pattern_grobs(first_rows, boundary_dfs) col <- first_rows$colour fill <- fill_alpha(first_rows$fill, first_rows$alpha) lwd <- first_rows$linewidth * .pt polygon_grob_fn <- function(col, fill, lwd) { - grid::polygonGrob( + polygonGrob( munched$x, munched$y, default.units = "native", id = munched$group, - gp = grid::gpar(col = col, fill = fill, lwd = lwd, - lty = first_rows$linetype) + gp = gpar( + col = col, + fill = fill, + lwd = lwd, + lty = first_rows$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) + ) } ggname( "geom_polygon", - grid::grobTree( + grobTree( polygon_grob_fn(NA, fill, 0), - # verboseGrob("polygon"), pattern_grobs, polygon_grob_fn(col, NA, lwd) ) ) } else { - if (utils::packageVersion('grid') < "3.6") { - abort("Polygons with holes requires R 3.6 or above") + if (getRversion() < "3.6") { + cli::cli_abort("Polygons with holes requires R 3.6 or above.") } - # Sort by group to make sure that colors, fill, etc. come in same order munched <- munched[order(munched$group, munched$subgroup), ] - id <- match(munched$subgroup, unique(munched$subgroup)) + id <- match(munched$subgroup, unique0(munched$subgroup)) # For gpar(), there is one entry per polygon (not one entry per point). # We'll pull the first value from each group, and assume all these values @@ -114,9 +98,6 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, first_idx <- !duplicated(munched$group) first_rows <- munched[first_idx, ] - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate all the boundary_dfs for all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ stopifnot(!is.null(munched$group)) polygons <- split(munched, munched$group) boundary_grobs <- lapply(polygons, function(polygon) { @@ -126,28 +107,21 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, id = polygon$subgroup, rule = rule) }) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # For polygons, every row in first_rows represents an element. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - all_params <- first_rows - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create the pattern grobs given the current params for every element - # (given in all_params), and the boundary_dfs of all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pattern_grobs <- create_pattern_grobs(all_params, boundary_grobs) + pattern_grobs <- create_pattern_grobs(first_rows, boundary_grobs) gp_fill <- grid::gpar( col = NA, fill = fill_alpha(first_rows$fill, first_rows$alpha), - lwd = first_rows$linewidth * .pt, - lty = first_rows$linetype + lwd = 0 ) gp_border <- grid::gpar( col = first_rows$colour, fill = NA, lwd = first_rows$linewidth * .pt, - lty = first_rows$linetype + lty = first_rows$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre ) path_grob_fn <- function(gp = gpar()) { grid::pathGrob( @@ -157,12 +131,6 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, gp = gp) } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Adapt the returned geom to always be a grobTree with the - # pattern_grobs as the final element. Since the pattern grobs are - # drawn last, there can be z-ordering issues that the user will have - # to handle manually if there are overlapping elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ggname( "geom_polygon", grid::grobTree( @@ -172,22 +140,15 @@ GeomPolygonPattern <- ggproto("GeomPolygonPattern", GeomPolygon, ) ) } - }, - draw_key = function(self, ...) draw_key_polygon_pattern(...), - - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = "NA", - fill = "grey20", - linewidth = 0.5, - linetype = 1, - alpha = NA, - subgroup = NULL, - ) + default_aes = defaults(aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, + alpha = NA, subgroup = NULL), + pattern_aesthetics ), + + draw_key = function(self, ...) draw_key_polygon_pattern(...), + rename_size = TRUE ) diff --git a/R/geom-rect.R b/R/geom-rect.R index 156f7d4..798c319 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#' @rdname geom-docs geom_rect_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., @@ -17,7 +15,7 @@ geom_rect_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( linejoin = linejoin, na.rm = na.rm, ... @@ -25,48 +23,35 @@ geom_rect_pattern <- function(mapping = NULL, data = NULL, ) } - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomRectPattern <- ggproto( - "GeomRectPattern", GeomRect, - - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = NA, - fill = "grey35", - linewidth = 0.5, - linetype = 1, - alpha = NA - ) +GeomRectPattern <- ggproto( "GeomRectPattern", GeomRect, + default_aes = defaults(aes(colour = NA, fill = "grey35", linewidth = 0.5, linetype = 1, + alpha = NA), + pattern_aesthetics ), - draw_key = function(self, ...) draw_key_polygon_pattern(...), - - draw_panel = function(self, data, panel_params, coord, linejoin = "mitre") { + draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") { + data <- check_linewidth(data, snake_class(self)) if (!coord$is_linear()) { aesthetics <- setdiff( names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax") ) + index <- rep(seq_len(nrow(data)), each = 4) - polys <- lapply(split(data, seq_len(nrow(data))), function(row) { - poly <- rect_to_poly(row$xmin, row$xmax, row$ymin, row$ymax) - aes <- new_data_frame(row[aesthetics])[rep(1,5), ] + new <- data[index, aesthetics, drop = FALSE] + new$x <- vec_interleave(data$xmin, data$xmax, data$xmax, data$xmin) + new$y <- vec_interleave(data$ymax, data$ymax, data$ymin, data$ymin) + new$group <- index - GeomPolygonPattern$draw_panel(cbind(poly, aes), panel_params, coord) - }) - - ggname("bar", do.call("grobTree", polys)) + ggname("geom_rect_pattern", GeomPolygonPattern$draw_panel( + new, panel_params, coord, lineend = lineend, linejoin = linejoin + )) } else { coords <- coord$transform(data, panel_params) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate all the boundary_dfs for all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ boundary_dfs <- lapply(seq(nrow(coords)), function(i) { params <- coords[i,] create_polygon_df( @@ -74,90 +59,36 @@ GeomRectPattern <- ggproto( x = with(params, c(xmin, xmax, xmax, xmin, xmin)) ) }) + pattern_grobs <- create_pattern_grobs(coords, boundary_dfs) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # For rectangles, every row in coords represents an element. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - all_params <- coords - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create the pattern grobs given the current params for every element - # (given in coords), and the boundary_dfs of all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pattern_grobs <- create_pattern_grobs(all_params, boundary_dfs) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Adapt the returned geom to always be a grobTree with the - # pattern_grobs as the final element. Since the pattern grobs are - # drawn last, there can be z-ordering issues that the user will have - # to handle manually if there are overlapping rects - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ggname( - "geom_rect", - grid::grobTree( - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # The area fill of the rect - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - grid::rectGrob( + rect_grob_fn <- function(col, fill, lwd) { + rectGrob( coords$xmin, coords$ymax, width = coords$xmax - coords$xmin, height = coords$ymax - coords$ymin, default.units = "native", just = c("left", "top"), - gp = grid::gpar( - col = NA, - fill = fill_alpha(coords$fill, coords$alpha), - lwd = coords$linewidth * .pt, - lty = coords$linetype, + gp = gpar( + col = col, + fill = fill, + lwd = lwd, + lty = coords$linetype, linejoin = linejoin, - lineend = if (identical(linejoin, "round")) "round" else "square" + lineend = lineend ) - ), + ) + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # The pattern over the top of the fill - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ggname("geom_rect_pattern", grobTree( + rect_grob_fn(NA, fill_alpha(coords$fill, coords$alpha), 0), pattern_grobs, - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # The edge of the rect - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - grid::rectGrob( - coords$xmin, coords$ymax, - width = coords$xmax - coords$xmin, - height = coords$ymax - coords$ymin, - default.units = "native", - just = c("left", "top"), - gp = grid::gpar( - col = coords$colour, - fill = NA, - lwd = coords$linewidth * .pt, - lty = coords$linetype, - linejoin = linejoin, - lineend = if (identical(linejoin, "round")) "round" else "square" - ) - ) + rect_grob_fn(coords$colour, NA, coords$linewidth * .pt) ) ) } }, + draw_key = function(self, ...) draw_key_polygon_pattern(...), + rename_size = TRUE ) - - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# Convert rectangle to polygon -# Useful for non-Cartesian coordinate systems where it's easy to work purely in -# terms of locations, rather than locations and dimensions. Note that, though -# `polygonGrob()` expects an open form, closed form is needed for correct -# munching (c.f. https://github.com/tidyverse/ggplot2/issues/3037#issuecomment-458406857). -# -# @keyword internal -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -rect_to_poly <- function(xmin, xmax, ymin, ymax) { - new_data_frame(list( - y = c(ymax, ymax, ymin, ymin, ymax), - x = c(xmin, xmax, xmax, xmin, xmin) - )) -} diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index 9cbe82d..918ab5e 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_ribbon_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., @@ -10,7 +8,7 @@ geom_ribbon_pattern <- function(mapping = NULL, data = NULL, show.legend = NA, inherit.aes = TRUE, outline.type = "both") { - outline.type <- match.arg(outline.type, c("both", "upper", "legacy")) + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) layer( data = data, @@ -20,7 +18,7 @@ geom_ribbon_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( na.rm = na.rm, orientation = orientation, outline.type = outline.type, @@ -29,45 +27,30 @@ geom_ribbon_pattern <- function(mapping = NULL, data = NULL, ) } - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomRibbonPattern <- ggproto( - "GeomRibbonPattern", GeomRibbon, - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = NA, - fill = "grey20", - linewidth = 0.5, - linetype = 1, - alpha = NA - ) +GeomRibbonPattern <- ggproto("GeomRibbonPattern", GeomRibbon, + default_aes = defaults(aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, + alpha = NA), + pattern_aesthetics ), draw_key = function(self, ...) draw_key_polygon_pattern(...), - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Where the magic happens - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - draw_group = function(self, data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") { + draw_group = function(self, data, panel_params, coord, lineend = "butt", + linejoin = "round", linemitre = 10, na.rm = FALSE, + flipped_aes = FALSE, outline.type = "both") { + data <- check_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ] data <- data[order(data$group), ] # Check that aesthetics are constant - aes_names <- c( - "colour", "fill", "linewidth", "linetype", "alpha", - names(pattern_aesthetics) - ) - - - aes <- unique(data[aes_names]) + aes <- unique0(data[names(data) %in% c("colour", "fill", "linewidth", "linetype", "alpha", names(pattern_aesthetics))]) if (nrow(aes) > 1) { - abort("Aesthetics can not vary with a ribbon") + cli::cli_abort("Aesthetics can not vary along a ribbon.") } aes <- as.list(aes) @@ -83,32 +66,49 @@ GeomRibbonPattern <- ggproto( ids[missing_pos] <- NA data <- unclass(data) #for faster indexing - positions <- new_data_frame(list( - x = c(data$x, rev(data$x)), - y = c(data$ymax, rev(data$ymin)), - id = c(ids, rev(ids)) - )) - positions <- flip_data(positions, flipped_aes) + # In case the data comes from stat_align + upper_keep <- if (is.null(data$align_padding)) TRUE else !data$align_padding - munched <- coord_munch(coord, positions, panel_params) + # The upper line and lower line need to processed separately (#4023) + positions_upper <- data_frame0( + x = data$x[upper_keep], + y = data$ymax[upper_keep], + id = ids[upper_keep] + ) - g_poly <- polygonGrob( - munched$x, munched$y, id = munched$id, - default.units = "native", - gp = gpar( - fill = fill_alpha(aes$fill, aes$alpha), - col = if (identical(outline.type, "legacy")) aes$colour else NA - ) + positions_lower <- data_frame0( + x = rev(data$x), + y = rev(data$ymin), + id = rev(ids) ) + positions_upper <- flip_data(positions_upper, flipped_aes) + positions_lower <- flip_data(positions_lower, flipped_aes) + + munched_upper <- coord_munch(coord, positions_upper, panel_params) + munched_lower <- coord_munch(coord, positions_lower, panel_params) + + munched_poly <- vec_rbind(munched_upper, munched_lower) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate all the boundary_dfs for all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - stopifnot(!is.null(munched$id)) + is_full_outline <- identical(outline.type, "full") + g_poly_fn <- function(col, fill, lwd) { polygonGrob( + munched_poly$x, munched_poly$y, id = munched_poly$id, + default.units = "native", + gp = gpar( + col = col, + fill = fill, + lwd = lwd, + lty = if (is_full_outline) aes$linetype else 1, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) + )} + g_poly_fill <- g_poly_fn(NA, fill_alpha(aes$fill, aes$alpha), 0) - polygons <- split(munched, munched$id) + stopifnot(!is.null(munched_poly$id)) + polygons <- split(munched_poly, munched_poly$id) boundary_dfs <- lapply(polygons, function(polygon) { create_polygon_df( x = polygon$x, @@ -116,61 +116,53 @@ GeomRibbonPattern <- ggproto( ) }) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # For polygons, every row in first_rows represents an element. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - first_idx <- !duplicated(munched$id) - first_rows <- munched[first_idx, ] - all_params <- first_rows - all_params <- cbind(all_params, aes) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create the pattern grobs given the current params for every element - # (given in all_params), and the boundary_dfs of all the elements - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + first_idx <- !duplicated(munched_poly$id) + first_rows <- munched_poly[first_idx, ] + all_params <- cbind(first_rows, aes) pattern_grobs <- create_pattern_grobs(all_params, boundary_dfs) - if (identical(outline.type, "legacy")) { - warn(glue('outline.type = "legacy" is only for backward-compatibility ', - 'and might be removed eventually')) - return(ggname("geom_ribbon", grobTree(g_poly, pattern_grobs))) - } - - munched_lines <- munched - # increment the IDs of the lower line - munched_lines$id <- switch( - outline.type, - both = munched_lines$id + rep(c(0, max(ids, na.rm = TRUE)), each = length(ids)), - upper = munched_lines$id + rep(c(0, NA), each = length(ids)), - abort(glue("invalid outline.type: {outline.type}")) - ) - g_lines <- polylineGrob( - munched_lines$x, munched_lines$y, id = munched_lines$id, - default.units = "native", - gp = gpar( - col = aes$colour, - lwd = aes$linewidth * .pt, - lty = aes$linetype) - ) + if (is_full_outline) { + col <- if (is_full_outline) aes$colour else NA + lwd <- if (is_full_outline) aes$linewidth * .pt else 0 + g_poly_border <- g_poly_fn(col, NA, lwd) + ggname("geom_ribbon_pattern", grobTree(g_poly_fill, pattern_grobs, g_poly_border)) + } else { + # Increment the IDs of the lower line so that they will be drawn as separate lines + munched_lower$id <- munched_lower$id + max(ids, na.rm = TRUE) - ggname("geom_ribbon", grobTree(g_poly, pattern_grobs, g_lines)) + munched_lines <- switch(outline.type, + both = vec_rbind(munched_upper, munched_lower), + upper = munched_upper, + lower = munched_lower + ) + g_lines <- polylineGrob( + munched_lines$x, munched_lines$y, id = munched_lines$id, + default.units = "native", + gp = gpar( + col = aes$colour, + lwd = aes$linewidth * .pt, + lty = aes$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) + ) + ggname("geom_ribbon_pattern", grobTree(g_poly_fill, pattern_grobs, g_lines)) + } }, rename_size = TRUE - ) -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -geom_area_pattern <- function(mapping = NULL, data = NULL, stat = "identity", +geom_area_pattern <- 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 <- match.arg(outline.type, c("both", "upper", "legacy")) + outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) layer( data = data, @@ -180,7 +172,7 @@ geom_area_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( na.rm = na.rm, orientation = orientation, outline.type = outline.type, @@ -189,22 +181,14 @@ geom_area_pattern <- function(mapping = NULL, data = NULL, stat = "identity", ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomAreaPattern <- ggproto( - "GeomAreaPattern", GeomRibbonPattern, - default_aes = augment_aes( - pattern_aesthetics, - aes( - colour = NA, - fill = "grey20", - linewidth = 0.5, - linetype = 1, - alpha = NA - ) +GeomAreaPattern <- ggproto("GeomAreaPattern", GeomRibbonPattern, + default_aes = defaults(aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, + alpha = NA), + pattern_aesthetics ), required_aes = c("x", "y"), @@ -219,7 +203,5 @@ GeomAreaPattern <- ggproto( data <- flip_data(data, params$flipped_aes) data <- transform(data[order(data$PANEL, data$group, data$x), ], ymin = 0, ymax = y) flip_data(data, params$flipped_aes) - }, - - rename_size = TRUE + } ) diff --git a/R/geom-sf.R b/R/geom-sf.R index 2d3d85d..17b702a 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_sf_pattern <- function(mapping = aes(), data = NULL, stat = "sf", position = "identity", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) { @@ -24,38 +22,28 @@ geom_sf_pattern <- function(mapping = aes(), data = NULL, stat = "sf", } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#' @export #' @rdname ggpattern-ggproto +#' @usage NULL #' @format NULL -#' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomSfPattern <- ggproto( - "GeomSfPattern", Geom, +GeomSfPattern <- ggproto("GeomSfPattern", Geom, required_aes = "geometry", - default_aes = augment_aes( - pattern_aesthetics, - aes( - shape = NULL, - colour = NULL, - fill = NULL, - size = NULL, - linetype = 1, - linewidth = NULL, - alpha = NA, - stroke = 0.5 - ) + default_aes = defaults(aes(shape = NULL, colour = NULL, fill = NULL, size = NULL, linewidth = NULL, linetype = 1, + alpha = NA, stroke = 0.5), + pattern_aesthetics ), - draw_panel = function(data, panel_params, coord, legend = NULL, + draw_panel = function(self, data, panel_params, coord, legend = NULL, lineend = "butt", linejoin = "round", linemitre = 10, - na.rm = TRUE) { + arrow = NULL, na.rm = TRUE) { if (!inherits(coord, "CoordSf")) { - abort("geom_sf_pattern() must be used with coord_sf()") + cli::cli_abort("{.fn {snake_class(self)}} can only be used with {.fn coord_sf}.") } # Need to refactor this to generate one grob per geometry type coord <- coord$transform(data, panel_params) - sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm, panel_params) + sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre, + arrow = arrow, na.rm = na.rm, panel_params) }, draw_key = function(data, params, size) { @@ -82,7 +70,8 @@ default_aesthetics <- function(type) { # ggpattern note: panel params added to arguments -sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = TRUE, panel_params) { +sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, + arrow = NULL, na.rm = TRUE, panel_params) { if (!requireNamespace("sf")) abort(c("Suggested package {sf} must be installed", i = 'Install using `install.packages("sf")`')) @@ -98,9 +87,10 @@ sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, na. remove[is_other] <- detect_missing(x, c(GeomPolygonPattern$required_aes, GeomPolygonPattern$non_missing_aes))[is_other] if (any(remove)) { if (!na.rm) { - warning_wrap( - "Removed ", sum(remove), " rows containing missing values (geom_sf_pattern)." - ) + cli::cli_warn(paste0( + "Removed {sum(remove)} row{?s} containing missing values or values ", + "outside the scale range ({.fn geom_sf})." + )) } x <- x[!remove, , drop = FALSE] type_ind <- type_ind[!remove] @@ -109,40 +99,34 @@ sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, na. defaults <- list( GeomPoint$default_aes, GeomLine$default_aes, - modify_list(GeomPolygonPattern$default_aes, list(fill = "grey90", colour = "grey35")) + modify_list(GeomPolygonPattern$default_aes, list(fill = "grey90", colour = "grey35", linewidth = 0.2)) ) defaults[[4]] <- modify_list( defaults[[3]], rename(GeomPoint$default_aes, c(size = "point_size", fill = "point_fill")) ) - default_names <- unique(unlist(lapply(defaults, names))) + default_names <- unique0(unlist(lapply(defaults, names))) defaults <- lapply(setNames(default_names, default_names), function(n) { unlist(lapply(defaults, function(def) def[[n]] %||% NA)) }) alpha <- x$alpha %||% defaults$alpha[type_ind] col <- x$colour %||% defaults$colour[type_ind] - col[is_point | is_line] <- scales::alpha(col[is_point | is_line], alpha[is_point | is_line]) + col[is_point | is_line] <- alpha(col[is_point | is_line], alpha[is_point | is_line]) fill <- x$fill %||% defaults$fill[type_ind] fill <- fill_alpha(fill, alpha) size <- x$size %||% defaults$size[type_ind] linewidth <- x$linewidth %||% defaults$linewidth[type_ind] - point_size <- ifelse(is_collection, + point_size <- ifelse( + is_collection, x$size %||% defaults$point_size[type_ind], - ifelse(is_point, size, linewidth)) + ifelse(is_point, size, linewidth) + ) stroke <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2 fontsize <- point_size * .pt + stroke lwd <- ifelse(is_point, stroke, linewidth * .pt) pch <- x$shape %||% defaults$shape[type_ind] lty <- x$linetype %||% defaults$linetype[type_ind] - gp_fill <- gpar( - col = NA, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty, - lineend = lineend, linejoin = linejoin, linemitre = linemitre - ) - gp_border <- gpar( - col = col, fill = NA, fontsize = fontsize, lwd = lwd, lty = lty, - lineend = lineend, linejoin = linejoin, linemitre = linemitre - ) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # For each row in 'x', @@ -169,20 +153,20 @@ sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, na. pattern_grobs_list <- append(pattern_grobs_list, list(pattern_grobs)) } } - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Combine all the individual pattern grobs into a grob tree - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ pattern_grobs <- do.call(grid::grobTree, pattern_grobs_list) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Plot the {sf} geometry first, then plot the tree of pattern grobs - # over the top. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - grob_sf <- sf::st_as_grob(x$geometry, pch = pch, gp = gp_fill) + gp_fill <- gpar( + col = NA, fill = fill, fontsize = fontsize, lwd = 0, lty = lty, + lineend = lineend, linejoin = linejoin, linemitre = linemitre + ) + gp_border <- gpar( + col = col, fill = NA, fontsize = fontsize, lwd = lwd, lty = lty, + lineend = lineend, linejoin = linejoin, linemitre = linemitre + ) + grob_fill <- sf::st_as_grob(x$geometry, pch = pch, gp = gp_fill) grob_border <- sf::st_as_grob(x$geometry, pch = pch, gp = gp_border) grid::grobTree( - grob_sf, + grob_fill, pattern_grobs, grob_border ) diff --git a/R/geom-tile.R b/R/geom-tile.R index b09be1c..422b78a 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -1,7 +1,5 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_tile_pattern <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., @@ -17,7 +15,7 @@ geom_tile_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( linejoin = linejoin, na.rm = na.rm, ... @@ -25,20 +23,17 @@ geom_tile_pattern <- function(mapping = NULL, data = NULL, ) } - -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export #' @include geom-rect.R -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomTilePattern <- ggproto( - "GeomTilePattern", GeomRectPattern, +GeomTilePattern <- ggproto("GeomTilePattern", GeomRectPattern, extra_params = c("na.rm"), setup_data = function(data, params) { - data$width <- data$width %||% params$width %||% resolution(data$x, FALSE) - data$height <- data$height %||% params$height %||% resolution(data$y, FALSE) + data$width <- data$width %||% params$width %||% resolution(data$x, FALSE, TRUE) + data$height <- data$height %||% params$height %||% resolution(data$y, FALSE, TRUE) transform(data, xmin = x - width / 2, xmax = x + width / 2, width = NULL, @@ -46,36 +41,11 @@ GeomTilePattern <- ggproto( ) }, - default_aes = augment_aes( - pattern_aesthetics, - aes( - fill = "grey20", - colour = NA, - linewidth = 0.1, - linetype = 1, - alpha = NA, - width = NA, - height = NA - ) + default_aes = defaults( + aes(fill = "grey20", colour = NA, linewidth = 0.1, linetype = 1, + alpha = NA, width = NA, height = NA), + pattern_aesthetics ), required_aes = c("x", "y") ) - - -if (FALSE) { - library(ggplot2) - - df <- data.frame( - x = rep(c(2, 5, 7, 9, 12), 2), - y = rep(c(1, 2), each = 5), - z = factor(rep(1:5, each = 2)), - w = rep(diff(c(0, 4, 6, 8, 10, 14)), 2) - ) - - ggplot(df, aes(x, y)) + - geom_tile_pattern(aes(fill = z, pattern = z), colour = "grey50") + - theme_bw() + - labs(title = "ggpattern::geom_tile_pattern()") - -} diff --git a/R/geom-violin.R b/R/geom-violin.R index a6794d6..9df2f48 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -1,12 +1,11 @@ -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname geom-docs #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ geom_violin_pattern <- 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, @@ -20,29 +19,25 @@ geom_violin_pattern <- function(mapping = NULL, data = NULL, position = position, show.legend = show.legend, inherit.aes = inherit.aes, - params = list( + params = list2( trim = trim, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, orientation = orientation, + bounds = bounds, ... ) ) } -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' @rdname ggpattern-ggproto #' @format NULL +#' @usage NULL #' @export -#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GeomViolinPattern <- ggproto( - "GeomViolinPattern", GeomViolin, +GeomViolinPattern <- ggproto("GeomViolinPattern", GeomViolin, draw_group = function(self, data, ..., draw_quantiles = NULL, flipped_aes = FALSE) { - - args <- list(...) - data <- flip_data(data, flipped_aes) # Find the points for the line to go all the way around data <- transform(data, @@ -51,20 +46,20 @@ GeomViolinPattern <- ggproto( ) # Make sure it's sorted properly to draw the outline - newdata <- rbind( + newdata <- vec_rbind( transform(data, x = xminv)[order(data$y), ], transform(data, x = xmaxv)[order(data$y, decreasing = TRUE), ] ) # Close the polygon: set first and last point the same # Needed for coord_polar and such - newdata <- rbind(newdata, newdata[1,]) + newdata <- vec_rbind(newdata, newdata[1,]) newdata <- flip_data(newdata, flipped_aes) # Draw quantiles if requested, so long as there is non-zero y range if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) { if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) { - abort("`draw_quantiles must be between 0 and 1") + cli::cli_abort("{.arg draw_quantiles} must be between 0 and 1.") } # Compute the quantile segments and combine with existing aesthetics @@ -75,7 +70,7 @@ GeomViolinPattern <- ggproto( drop = FALSE ] aesthetics$alpha <- rep(1, nrow(quantiles)) - both <- cbind(quantiles, aesthetics) + both <- vec_cbind(quantiles, aesthetics) both <- both[!is.na(both$group), , drop = FALSE] both <- flip_data(both, flipped_aes) quantile_grob <- if (nrow(both) == 0) { @@ -84,28 +79,22 @@ GeomViolinPattern <- ggproto( GeomPath$draw_panel(both, ...) } - ggname("geom_violin", grobTree( + ggname("geom_violin_pattern", grobTree( GeomPolygonPattern$draw_panel(newdata, ...), - quantile_grob - )) + quantile_grob) + ) } else { - ggname("geom_violin", GeomPolygonPattern$draw_panel(newdata, ...)) + ggname("geom_violin_pattern", GeomPolygonPattern$draw_panel(newdata, ...)) } }, - default_aes = augment_aes( - pattern_aesthetics, - aes( - weight = 1, - colour = "grey20", - fill = "white", - linewidth = 0.5, - alpha = NA, - linetype = "solid" - ) - ), - draw_key = function(self, ...) draw_key_polygon_pattern(...), + default_aes = defaults( + aes(weight = 1, colour = "grey20", fill = "white", linewidth = 0.5, + alpha = NA, linetype = "solid"), + pattern_aesthetics + ), + rename_size = TRUE ) diff --git a/R/zzz.R b/R/zzz.R index 3508331..3117355 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,5 @@ -#' @import ggplot2 glue grid rlang scales -#' @importFrom lifecycle deprecated +#' @import ggplot2 glue grid rlang scales vctrs +#' @importFrom lifecycle deprecated deprecate_soft #' @importFrom stats setNames #' @importFrom utils tail #' @importFrom grDevices col2rgb dev.off png rgb diff --git a/man/geom-docs.Rd b/man/geom-docs.Rd index 6fa5bc9..e7c088f 100644 --- a/man/geom-docs.Rd +++ b/man/geom-docs.Rd @@ -76,6 +76,7 @@ geom_boxplot_pattern( stat = "boxplot", position = "dodge2", ..., + outliers = TRUE, outlier.colour = NULL, outlier.color = NULL, outlier.fill = NULL, @@ -85,6 +86,7 @@ geom_boxplot_pattern( outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, + staplewidth = 0, varwidth = FALSE, na.rm = FALSE, orientation = NA, @@ -133,7 +135,7 @@ geom_ribbon_pattern( geom_area_pattern( mapping = NULL, data = NULL, - stat = "identity", + stat = "align", position = "stack", na.rm = FALSE, orientation = NA, @@ -152,7 +154,8 @@ geom_density_pattern( na.rm = FALSE, orientation = NA, show.legend = NA, - inherit.aes = TRUE + inherit.aes = TRUE, + outline.type = "upper" ) geom_histogram_pattern( @@ -223,6 +226,7 @@ geom_violin_pattern( ..., draw_quantiles = NULL, trim = TRUE, + bounds = c(-Inf, Inf), scale = "area", na.rm = FALSE, orientation = NA, @@ -251,20 +255,59 @@ the plot data. The return value must be a \code{data.frame}, and will be used as the layer data. A \code{function} can be created from a \code{formula} (e.g. \code{~ head(.x, 10)}).} -\item{stat}{The statistical transformation to use on the data for this -layer, either as a \code{ggproto} \code{Geom} subclass or as a string naming the -stat stripped of the \code{stat_} prefix (e.g. \code{"count"} rather than -\code{"stat_count"})} - -\item{position}{Position adjustment, either as a string naming the adjustment -(e.g. \code{"jitter"} to use \code{position_jitter}), or the result of a call to a -position adjustment function. Use the latter if you need to change the -settings of the adjustment.} - -\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}. These are -often aesthetics, used to set an aesthetic to a fixed value, like -\code{colour = "red"} or \code{size = 3}. They may also be parameters -to the paired geom/stat.} +\item{stat}{The statistical transformation to use on the data for this layer. +When using a \verb{geom_*()} function to construct a layer, the \code{stat} +argument can be used the override the default coupling between geoms and +stats. The \code{stat} argument accepts the following: +\itemize{ +\item A \code{Stat} ggproto subclass, for example \code{StatCount}. +\item A string naming the stat. To give the stat as a string, strip the +function name of the \code{stat_} prefix. For example, to use \code{stat_count()}, +give the stat as \code{"count"}. +\item For more information and other ways to specify the stat, see the +\link[ggplot2:layer_stats]{layer stat} documentation. +}} + +\item{position}{A position adjustment to use on the data for this layer. This +can be used in various ways, including to prevent overplotting and +improving the display. The \code{position} argument accepts the following: +\itemize{ +\item The result of calling a position function, such as \code{position_jitter()}. +This method allows for passing extra arguments to the position. +\item A string naming the position adjustment. To give the position as a +string, strip the function name of the \code{position_} prefix. For example, +to use \code{position_jitter()}, give the position as \code{"jitter"}. +\item For more information and other ways to specify the position, see the +\link[ggplot2:layer_positions]{layer position} documentation. +}} + +\item{...}{Other arguments passed on to \code{\link[ggplot2: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 +can \emph{not} be passed through \code{...}. Unknown arguments that are not part +of the 4 categories below are ignored. +\itemize{ +\item Static aesthetics that are not mapped to a scale, but are at a fixed +value and apply to the layer as a whole. For example, \code{colour = "red"} +or \code{linewidth = 3}. The geom's documentation has an \strong{Aesthetics} +section that lists the available options. The 'required' aesthetics +cannot be passed on to the \code{params}. Please note that while passing +unmapped aesthetics as vectors is technically possible, the order and +required length is not guaranteed to be parallel to the input data. +\item When constructing a layer using +a \verb{stat_*()} function, the \code{...} argument can be used to pass on +parameters to the \code{geom} part of the layer. An example of this is +\code{stat_density(geom = "area", outline.type = "both")}. The geom's +documentation lists which parameters it can accept. +\item Inversely, when constructing a layer using a +\verb{geom_*()} function, the \code{...} argument can be used to pass on parameters +to the \code{stat} part of the layer. An example of this is +\code{geom_area(stat = "density", adjust = 0.5)}. The stat's documentation +lists which parameters it can accept. +\item The \code{key_glyph} argument of \code{\link[ggplot2:layer]{layer()}} may also be passed on through +\code{...}. This can be one of the functions described as +\link[ggplot2:draw_key]{key glyphs}, to change the display of the layer in the legend. +}} \item{linejoin}{Line join style (round, mitre, bevel).} @@ -296,6 +339,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{outliers}{Whether to display (\code{TRUE}) or discard (\code{FALSE}) outliers +from the plot. Hiding or discarding outliers can be useful when, for +example, raw data points need to be displayed on top of the boxplot. +By discarding outliers, the axis limits will adapt to the box and whiskers +only, not the full data range. If outliers need to be hidden and the axes +needs to show the full data range, please use \code{outlier.shape = NA} instead.} + \item{outlier.colour, outlier.color, outlier.fill, outlier.shape, outlier.size, outlier.stroke, outlier.alpha}{Default aesthetics for outliers. Set to \code{NULL} to inherit from the aesthetics used for the box. @@ -310,6 +360,9 @@ are significantly different.} \item{notchwidth}{For a notched box plot, width of the notch relative to the body (defaults to \code{notchwidth = 0.5}).} +\item{staplewidth}{The relative width of staples to the width of the box. +Staples mark the ends of the whiskers with a line.} + \item{varwidth}{If \code{FALSE} (default) make a standard box plot. If \code{TRUE}, boxes are drawn with widths proportional to the square-roots of the number of observations in the groups (possibly @@ -354,6 +407,12 @@ 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.} +\item{bounds}{Known lower and upper bounds for estimated data. Default +\code{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 \code{bounds} around their closest edge. Data points +outside of bounds are removed with a warning.} + \item{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.} diff --git a/man/ggpattern-ggproto.Rd b/man/ggpattern-ggproto.Rd index 61d51bd..d908096 100644 --- a/man/ggpattern-ggproto.Rd +++ b/man/ggpattern-ggproto.Rd @@ -19,33 +19,6 @@ \alias{GeomTilePattern} \alias{GeomViolinPattern} \title{Geom ggproto objects} -\usage{ -GeomRectPattern - -GeomBarPattern - -GeomBoxplotPattern - -GeomColPattern - -GeomCrossbarPattern - -GeomRibbonPattern - -GeomAreaPattern - -GeomDensityPattern - -GeomPolygonPattern - -GeomMapPattern - -GeomSfPattern - -GeomTilePattern - -GeomViolinPattern -} \description{ Geom ggproto objects that could be extended to create a new geom. } diff --git a/tests/testthat/_snaps/array-patterns/ambient.svg b/tests/testthat/_snaps/array-patterns/ambient.svg index 152e256..ae0eedd 100644 --- a/tests/testthat/_snaps/array-patterns/ambient.svg +++ b/tests/testthat/_snaps/array-patterns/ambient.svg @@ -37,15 +37,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/array-patterns/gradient.svg b/tests/testthat/_snaps/array-patterns/gradient.svg index 7e1c9bc..b2a83d5 100644 --- a/tests/testthat/_snaps/array-patterns/gradient.svg +++ b/tests/testthat/_snaps/array-patterns/gradient.svg @@ -37,15 +37,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/array-patterns/image-logo-none.svg b/tests/testthat/_snaps/array-patterns/image-logo-none.svg index 2f21382..dedd4ef 100644 --- a/tests/testthat/_snaps/array-patterns/image-logo-none.svg +++ b/tests/testthat/_snaps/array-patterns/image-logo-none.svg @@ -46,15 +46,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/array-patterns/image-logo-variety.svg b/tests/testthat/_snaps/array-patterns/image-logo-variety.svg index 7f9f3c6..1558c6f 100644 --- a/tests/testthat/_snaps/array-patterns/image-logo-variety.svg +++ b/tests/testthat/_snaps/array-patterns/image-logo-variety.svg @@ -46,15 +46,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/array-patterns/magick.svg b/tests/testthat/_snaps/array-patterns/magick.svg index d718abb..cd87400 100644 --- a/tests/testthat/_snaps/array-patterns/magick.svg +++ b/tests/testthat/_snaps/array-patterns/magick.svg @@ -37,15 +37,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/fill/pattern-fill-fill.svg b/tests/testthat/_snaps/fill/pattern-fill-fill.svg index 6e4c7aa..cf8caa6 100644 --- a/tests/testthat/_snaps/fill/pattern-fill-fill.svg +++ b/tests/testthat/_snaps/fill/pattern-fill-fill.svg @@ -46,137 +46,137 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -189,7 +189,7 @@ - + @@ -202,16 +202,16 @@ - + - - - + + + @@ -234,9 +234,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/fill/pattern-fill-pattern-fill.svg b/tests/testthat/_snaps/fill/pattern-fill-pattern-fill.svg index 627be2f..befdbc9 100644 --- a/tests/testthat/_snaps/fill/pattern-fill-pattern-fill.svg +++ b/tests/testthat/_snaps/fill/pattern-fill-pattern-fill.svg @@ -40,9 +40,9 @@ - - - + + + @@ -1788,9 +1788,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/fill/vectorized-pattern-fill.svg b/tests/testthat/_snaps/fill/vectorized-pattern-fill.svg index 15b8073..d4e59fd 100644 --- a/tests/testthat/_snaps/fill/vectorized-pattern-fill.svg +++ b/tests/testthat/_snaps/fill/vectorized-pattern-fill.svg @@ -37,9 +37,9 @@ - - - + + + @@ -87,9 +87,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom/bar.svg b/tests/testthat/_snaps/geom/bar.svg index 4e529e1..7ce0361 100644 --- a/tests/testthat/_snaps/geom/bar.svg +++ b/tests/testthat/_snaps/geom/bar.svg @@ -50,13 +50,13 @@ - - - - - - - + + + + + + + @@ -638,13 +638,13 @@ - - - - - - - + + + + + + + diff --git a/tests/testthat/_snaps/geom/bin2d.svg b/tests/testthat/_snaps/geom/bin2d.svg index 2b9f3c7..175c6a2 100644 --- a/tests/testthat/_snaps/geom/bin2d.svg +++ b/tests/testthat/_snaps/geom/bin2d.svg @@ -41,17 +41,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -228,17 +228,17 @@ - - - - - - - - - - - + + + + + + + + + + + diff --git a/tests/testthat/_snaps/geom/boxplot.svg b/tests/testthat/_snaps/geom/boxplot.svg index 93c59dc..5afd703 100644 --- a/tests/testthat/_snaps/geom/boxplot.svg +++ b/tests/testthat/_snaps/geom/boxplot.svg @@ -52,43 +52,43 @@ - + - - + + - + - - + + - + - - + + - + @@ -100,15 +100,15 @@ - - + + - + @@ -120,13 +120,13 @@ - - + + - + @@ -161,8 +161,8 @@ - - + + @@ -173,7 +173,7 @@ - + @@ -187,8 +187,8 @@ - - + + diff --git a/tests/testthat/_snaps/geom/col.svg b/tests/testthat/_snaps/geom/col.svg index 88326e2..28cab72 100644 --- a/tests/testthat/_snaps/geom/col.svg +++ b/tests/testthat/_snaps/geom/col.svg @@ -46,9 +46,9 @@ - - - + + + @@ -294,9 +294,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom/crossbar.svg b/tests/testthat/_snaps/geom/crossbar.svg index 8bac17d..fdb6666 100644 --- a/tests/testthat/_snaps/geom/crossbar.svg +++ b/tests/testthat/_snaps/geom/crossbar.svg @@ -48,10 +48,10 @@ - - - - + + + + @@ -139,14 +139,14 @@ - - - - - - - - + + + + + + + + diff --git a/tests/testthat/_snaps/geom/density.svg b/tests/testthat/_snaps/geom/density.svg index f35ceed..c159f7c 100644 --- a/tests/testthat/_snaps/geom/density.svg +++ b/tests/testthat/_snaps/geom/density.svg @@ -58,7 +58,7 @@ - + @@ -70,9 +70,8 @@ - - - + + @@ -127,9 +126,8 @@ - - - + + @@ -199,8 +197,7 @@ - - + diff --git a/tests/testthat/_snaps/geom/map.svg b/tests/testthat/_snaps/geom/map.svg index 99871e3..4da101d 100644 --- a/tests/testthat/_snaps/geom/map.svg +++ b/tests/testthat/_snaps/geom/map.svg @@ -45,68 +45,68 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -490,68 +490,68 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/geom/polygon-hole.svg b/tests/testthat/_snaps/geom/polygon-hole.svg index 85a711e..568ad74 100644 --- a/tests/testthat/_snaps/geom/polygon-hole.svg +++ b/tests/testthat/_snaps/geom/polygon-hole.svg @@ -27,12 +27,12 @@ - - + + - - + + diff --git a/tests/testthat/_snaps/geom/polygon.svg b/tests/testthat/_snaps/geom/polygon.svg index 9afd574..615dd1d 100644 --- a/tests/testthat/_snaps/geom/polygon.svg +++ b/tests/testthat/_snaps/geom/polygon.svg @@ -52,7 +52,7 @@ - + @@ -60,7 +60,7 @@ - + diff --git a/tests/testthat/_snaps/geom/rect.svg b/tests/testthat/_snaps/geom/rect.svg index 38bceec..1fb0ea3 100644 --- a/tests/testthat/_snaps/geom/rect.svg +++ b/tests/testthat/_snaps/geom/rect.svg @@ -43,8 +43,8 @@ - - + + @@ -300,8 +300,8 @@ - - + + diff --git a/tests/testthat/_snaps/geom/ribbon.svg b/tests/testthat/_snaps/geom/ribbon.svg index 4845599..2c6840b 100644 --- a/tests/testthat/_snaps/geom/ribbon.svg +++ b/tests/testthat/_snaps/geom/ribbon.svg @@ -43,7 +43,7 @@ - + @@ -470,6 +470,7 @@ + diff --git a/tests/testthat/_snaps/geom/sf-hole.svg b/tests/testthat/_snaps/geom/sf-hole.svg index 20c8274..5d3abbd 100644 --- a/tests/testthat/_snaps/geom/sf-hole.svg +++ b/tests/testthat/_snaps/geom/sf-hole.svg @@ -36,9 +36,9 @@ - + - + diff --git a/tests/testthat/_snaps/geom/sf.svg b/tests/testthat/_snaps/geom/sf.svg index 64646f0..828272f 100644 --- a/tests/testthat/_snaps/geom/sf.svg +++ b/tests/testthat/_snaps/geom/sf.svg @@ -52,15 +52,15 @@ - - - + + + - - - + + + diff --git a/tests/testthat/_snaps/geom/tile.svg b/tests/testthat/_snaps/geom/tile.svg index 09d80a6..80db120 100644 --- a/tests/testthat/_snaps/geom/tile.svg +++ b/tests/testthat/_snaps/geom/tile.svg @@ -50,16 +50,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -313,16 +313,16 @@ - - - - - - - - - - + + + + + + + + + + diff --git a/tests/testthat/_snaps/geom/violin.svg b/tests/testthat/_snaps/geom/violin.svg index bda6c91..e1757af 100644 --- a/tests/testthat/_snaps/geom/violin.svg +++ b/tests/testthat/_snaps/geom/violin.svg @@ -50,7 +50,7 @@ - + @@ -61,8 +61,8 @@ - - + + @@ -77,8 +77,8 @@ - - + + @@ -110,7 +110,7 @@ - + diff --git a/tests/testthat/_snaps/geometry-patterns/circle.svg b/tests/testthat/_snaps/geometry-patterns/circle.svg index 400a717..f48d293 100644 --- a/tests/testthat/_snaps/geometry-patterns/circle.svg +++ b/tests/testthat/_snaps/geometry-patterns/circle.svg @@ -37,9 +37,9 @@ - - - + + + @@ -341,9 +341,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/crosshatch.svg b/tests/testthat/_snaps/geometry-patterns/crosshatch.svg index 72793d0..876f7a2 100644 --- a/tests/testthat/_snaps/geometry-patterns/crosshatch.svg +++ b/tests/testthat/_snaps/geometry-patterns/crosshatch.svg @@ -37,9 +37,9 @@ - - - + + + @@ -127,9 +127,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/none.svg b/tests/testthat/_snaps/geometry-patterns/none.svg index 3402e32..1cbb05e 100644 --- a/tests/testthat/_snaps/geometry-patterns/none.svg +++ b/tests/testthat/_snaps/geometry-patterns/none.svg @@ -37,12 +37,12 @@ - - - - - - + + + + + + diff --git a/tests/testthat/_snaps/geometry-patterns/pch.svg b/tests/testthat/_snaps/geometry-patterns/pch.svg index 971fde9..b330aa4 100644 --- a/tests/testthat/_snaps/geometry-patterns/pch.svg +++ b/tests/testthat/_snaps/geometry-patterns/pch.svg @@ -37,9 +37,9 @@ - - - + + + @@ -341,9 +341,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/polygon-tiling.svg b/tests/testthat/_snaps/geometry-patterns/polygon-tiling.svg index 085db2b..06fea02 100644 --- a/tests/testthat/_snaps/geometry-patterns/polygon-tiling.svg +++ b/tests/testthat/_snaps/geometry-patterns/polygon-tiling.svg @@ -37,9 +37,9 @@ - - - + + + @@ -419,9 +419,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/regular-polygon.svg b/tests/testthat/_snaps/geometry-patterns/regular-polygon.svg index a57073c..8461a25 100644 --- a/tests/testthat/_snaps/geometry-patterns/regular-polygon.svg +++ b/tests/testthat/_snaps/geometry-patterns/regular-polygon.svg @@ -37,9 +37,9 @@ - - - + + + @@ -341,9 +341,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/stripe.svg b/tests/testthat/_snaps/geometry-patterns/stripe.svg index 436fd4e..decacdc 100644 --- a/tests/testthat/_snaps/geometry-patterns/stripe.svg +++ b/tests/testthat/_snaps/geometry-patterns/stripe.svg @@ -37,9 +37,9 @@ - - - + + + @@ -87,9 +87,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geometry-patterns/weave.svg b/tests/testthat/_snaps/geometry-patterns/weave.svg index 8b05c34..499127b 100644 --- a/tests/testthat/_snaps/geometry-patterns/weave.svg +++ b/tests/testthat/_snaps/geometry-patterns/weave.svg @@ -37,9 +37,9 @@ - - - + + + @@ -424,9 +424,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/scales/fill-brewer-fill2-grey.svg b/tests/testthat/_snaps/scales/fill-brewer-fill2-grey.svg index 5a2921f..9a997d9 100644 --- a/tests/testthat/_snaps/scales/fill-brewer-fill2-grey.svg +++ b/tests/testthat/_snaps/scales/fill-brewer-fill2-grey.svg @@ -37,9 +37,9 @@ - - - + + + @@ -127,9 +127,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/scales/fill2-brewer-fill-grey.svg b/tests/testthat/_snaps/scales/fill2-brewer-fill-grey.svg index 5c226fc..48c51e8 100644 --- a/tests/testthat/_snaps/scales/fill2-brewer-fill-grey.svg +++ b/tests/testthat/_snaps/scales/fill2-brewer-fill-grey.svg @@ -37,9 +37,9 @@ - - - + + + @@ -127,9 +127,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/scales/missing-pattern.svg b/tests/testthat/_snaps/scales/missing-pattern.svg index 97a0aba..3f59d8d 100644 --- a/tests/testthat/_snaps/scales/missing-pattern.svg +++ b/tests/testthat/_snaps/scales/missing-pattern.svg @@ -43,8 +43,8 @@ - - + + @@ -179,8 +179,8 @@ - - + + diff --git a/tests/testthat/_snaps/scales/shape.svg b/tests/testthat/_snaps/scales/shape.svg index bc62e22..5d37b04 100644 --- a/tests/testthat/_snaps/scales/shape.svg +++ b/tests/testthat/_snaps/scales/shape.svg @@ -37,9 +37,9 @@ - - - + + + @@ -365,9 +365,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/scales/viridis-d.svg b/tests/testthat/_snaps/scales/viridis-d.svg index c462b1e..e60bf1b 100644 --- a/tests/testthat/_snaps/scales/viridis-d.svg +++ b/tests/testthat/_snaps/scales/viridis-d.svg @@ -37,9 +37,9 @@ - - - + + + @@ -127,9 +127,9 @@ - - - + + + diff --git a/tests/testthat/test-geom.R b/tests/testthat/test-geom.R index 3132169..424d9a3 100644 --- a/tests/testthat/test-geom.R +++ b/tests/testthat/test-geom.R @@ -189,7 +189,6 @@ test_that("geometry patterns work as expected", { theme(legend.key.size = unit(1.5, 'cm')) }) - suppressWarnings( # outline.type = "legacy" is only for backward-compatibility... expect_doppelganger("ribbon", { huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron)) @@ -205,11 +204,11 @@ test_that("geometry patterns work as expected", { pattern_spacing = 0.03, pattern_density = 0.5, pattern_angle = 30, - outline.type = 'legacy' + outline.type = 'full' ) + theme_bw(18) + labs(title = "ggpattern::geom_ribbon_pattern()") - })) + }) expect_doppelganger("tile", { df <- data.frame( diff --git a/vignettes/geom-gallery-array.Rmd b/vignettes/geom-gallery-array.Rmd index e5b3076..f22fbb3 100644 --- a/vignettes/geom-gallery-array.Rmd +++ b/vignettes/geom-gallery-array.Rmd @@ -486,7 +486,7 @@ p <- ggplot(huron, aes(year)) + pattern = 'image', pattern_type = 'tile', pattern_filename = system.file('img', 'seamless2.jpg', package = 'ggpattern'), - outline.type = 'legacy' + outline.type = 'full' ) + theme_bw(18) + labs( diff --git a/vignettes/geom-gallery-array.Rmd.orig b/vignettes/geom-gallery-array.Rmd.orig index 5aebdb7..9d54e48 100644 --- a/vignettes/geom-gallery-array.Rmd.orig +++ b/vignettes/geom-gallery-array.Rmd.orig @@ -455,7 +455,7 @@ p <- ggplot(huron, aes(year)) + pattern = 'image', pattern_type = 'tile', pattern_filename = system.file('img', 'seamless2.jpg', package = 'ggpattern'), - outline.type = 'legacy' + outline.type = 'full' ) + theme_bw(18) + labs( diff --git a/vignettes/geom-gallery-geometry.Rmd b/vignettes/geom-gallery-geometry.Rmd index 9e99406..b873ba7 100644 --- a/vignettes/geom-gallery-geometry.Rmd +++ b/vignettes/geom-gallery-geometry.Rmd @@ -383,7 +383,7 @@ p <- ggplot(huron, aes(year)) + pattern_spacing = 0.03, pattern_density = 0.5, pattern_angle = 30, - outline.type = 'legacy' + outline.type = 'full' ) + theme_bw(18) + labs(title = "ggpattern::geom_ribbon_pattern()") diff --git a/vignettes/geom-gallery-geometry.Rmd.orig b/vignettes/geom-gallery-geometry.Rmd.orig index b2a9ce0..60e58d8 100644 --- a/vignettes/geom-gallery-geometry.Rmd.orig +++ b/vignettes/geom-gallery-geometry.Rmd.orig @@ -352,7 +352,7 @@ p <- ggplot(huron, aes(year)) + pattern_spacing = 0.03, pattern_density = 0.5, pattern_angle = 30, - outline.type = 'legacy' + outline.type = 'full' ) + theme_bw(18) + labs(title = "ggpattern::geom_ribbon_pattern()")