From 7758dc5cc6816fedd347f4af5cdc4df6f84688bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 8 Sep 2025 16:30:59 +0200 Subject: [PATCH] Reformat code with air Had to fix one test case, ggsave:144. --- .Rbuildignore | 2 + .vscode/extensions.json | 5 + .vscode/settings.json | 10 + R/aes-evaluation.R | 32 +- R/aes.R | 51 +- R/all-classes.R | 74 +- R/annotation-borders.R | 19 +- R/annotation-custom.R | 51 +- R/annotation-logticks.R | 180 +++- R/annotation-map.R | 31 +- R/annotation-raster.R | 50 +- R/annotation.R | 28 +- R/autolayer.R | 4 +- R/autoplot.R | 1 - R/axis-secondary.R | 113 +- R/backports.R | 22 +- R/bin.R | 77 +- R/compat-plyr.R | 35 +- R/coord-.R | 61 +- R/coord-cartesian-.R | 63 +- R/coord-fixed.R | 4 +- R/coord-flip.R | 12 +- R/coord-map.R | 122 ++- R/coord-munch.R | 55 +- R/coord-polar.R | 178 ++-- R/coord-quickmap.R | 15 +- R/coord-radial.R | 174 +-- R/coord-sf.R | 231 ++-- R/coord-transform.R | 110 +- R/facet-.R | 261 +++-- R/facet-grid-.R | 249 +++-- R/facet-null.R | 81 +- R/facet-wrap.R | 249 +++-- R/fortify-map.R | 17 +- R/fortify-models.R | 23 +- R/fortify-spatial.R | 26 +- R/fortify.R | 3 +- R/geom-.R | 63 +- R/geom-abline.R | 55 +- R/geom-bar.R | 25 +- R/geom-blank.R | 18 +- R/geom-boxplot.R | 238 +++-- R/geom-contour.R | 17 +- R/geom-crossbar.R | 143 ++- R/geom-curve.R | 42 +- R/geom-defaults.R | 15 +- R/geom-density.R | 18 +- R/geom-density2d.R | 47 +- R/geom-dotplot.R | 148 ++- R/geom-errorbar.R | 64 +- R/geom-freqpoly.R | 17 +- R/geom-function.R | 32 +- R/geom-hex.R | 49 +- R/geom-histogram.R | 8 +- R/geom-hline.R | 39 +- R/geom-jitter.R | 20 +- R/geom-label.R | 129 ++- R/geom-linerange.R | 38 +- R/geom-map.R | 54 +- R/geom-path.R | 108 +- R/geom-point.R | 64 +- R/geom-pointrange.R | 62 +- R/geom-polygon.R | 34 +- R/geom-quantile.R | 13 +- R/geom-raster.R | 27 +- R/geom-rect.R | 94 +- R/geom-ribbon.R | 89 +- R/geom-rug.R | 46 +- R/geom-segment.R | 70 +- R/geom-sf.R | 173 ++- R/geom-smooth.R | 68 +- R/geom-spoke.R | 10 +- R/geom-text.R | 41 +- R/geom-tile.R | 37 +- R/geom-violin.R | 77 +- R/geom-vline.R | 39 +- R/ggplot-global.R | 98 +- R/ggproto.R | 78 +- R/grob-absolute.R | 30 +- R/grob-dotstack.R | 66 +- R/grouping.R | 4 +- R/guide-.R | 117 ++- R/guide-axis-logticks.R | 80 +- R/guide-axis-stack.R | 124 ++- R/guide-axis-theta.R | 122 ++- R/guide-axis.R | 198 ++-- R/guide-bins.R | 148 ++- R/guide-colorbar.R | 108 +- R/guide-colorsteps.R | 92 +- R/guide-custom.R | 53 +- R/guide-legend.R | 338 +++--- R/guide-none.R | 3 +- R/guide-old.R | 32 +- R/guides-.R | 242 +++-- R/guides-grid.R | 10 +- R/hexbin.R | 22 +- R/labeller.R | 144 ++- R/labels.R | 69 +- R/layer-sf.R | 55 +- R/layer.R | 241 ++++- R/layout.R | 81 +- R/legend-draw.R | 116 +- R/make-constructor.R | 76 +- R/margins.R | 87 +- R/performance.R | 8 +- R/plot-build.R | 323 ++++-- R/plot-construction.R | 34 +- R/plot.R | 55 +- R/position-.R | 11 +- R/position-collide.R | 40 +- R/position-dodge.R | 32 +- R/position-dodge2.R | 27 +- R/position-identity.R | 4 +- R/position-jitter.R | 15 +- R/position-jitterdodge.R | 28 +- R/position-nudge.R | 9 +- R/position-stack.R | 31 +- R/properties.R | 5 +- R/quick-plot.R | 70 +- R/reshape-add-margins.R | 22 +- R/save.R | 156 ++- R/scale-.R | 311 ++++-- R/scale-alpha.R | 49 +- R/scale-binned.R | 105 +- R/scale-brewer.R | 123 ++- R/scale-colour.R | 199 +++- R/scale-continuous.R | 92 +- R/scale-date.R | 249 +++-- R/scale-discrete-.R | 94 +- R/scale-expansion.R | 117 ++- R/scale-gradient.R | 151 ++- R/scale-grey.R | 32 +- R/scale-hue.R | 85 +- R/scale-identity.R | 153 ++- R/scale-linetype.R | 12 +- R/scale-linewidth.R | 104 +- R/scale-manual.R | 91 +- R/scale-shape.R | 14 +- R/scale-size.R | 142 ++- R/scale-steps.R | 134 ++- R/scale-type.R | 8 +- R/scale-view.R | 58 +- R/scale-viridis.R | 124 ++- R/scales-.R | 99 +- R/stat-.R | 90 +- R/stat-align.R | 40 +- R/stat-bin.R | 52 +- R/stat-bin2d.R | 29 +- R/stat-bindot.R | 218 ++-- R/stat-binhex.R | 12 +- R/stat-boxplot.R | 50 +- R/stat-connect.R | 38 +- R/stat-contour.R | 65 +- R/stat-count.R | 32 +- R/stat-density-2d.R | 77 +- R/stat-density.R | 125 ++- R/stat-ecdf.R | 43 +- R/stat-ellipse.R | 34 +- R/stat-function.R | 20 +- R/stat-identity.R | 3 +- R/stat-manual.R | 3 +- R/stat-qq-line.R | 38 +- R/stat-qq.R | 20 +- R/stat-quantilemethods.R | 39 +- R/stat-sf-coordinates.R | 32 +- R/stat-sf.R | 38 +- R/stat-smooth.R | 35 +- R/stat-sum.R | 12 +- R/stat-summary-2d.R | 41 +- R/stat-summary-bin.R | 108 +- R/stat-summary-hex.R | 25 +- R/stat-summary.R | 63 +- R/stat-unique.R | 3 +- R/stat-ydensity.R | 92 +- R/summarise-plot.R | 4 +- R/summary.R | 26 +- R/theme-current.R | 1 - R/theme-defaults.R | 993 +++++++++++------- R/theme-elements.R | 939 +++++++++++------ R/theme-sub.R | 183 +++- R/theme.R | 419 ++++---- R/utilities-break.R | 25 +- R/utilities-checks.R | 184 ++-- R/utilities-help.R | 101 +- R/utilities-patterns.R | 2 - R/utilities.R | 155 ++- R/zxx.R | 95 +- R/zzz.R | 4 +- air.toml | 0 data-raw/diamonds.R | 10 +- data-raw/economics.R | 4 +- data-raw/tx-housing.R | 60 +- icons/icons.R | 393 ++++--- tests/testthat/helper-density.R | 4 +- tests/testthat/helper-facet.R | 1 - tests/testthat/helper-plot-data.R | 8 +- tests/testthat/helper-vdiffr.R | 5 +- tests/testthat/test-aes-calculated.R | 44 +- tests/testthat/test-aes-setting.R | 10 +- tests/testthat/test-aes.R | 24 +- tests/testthat/test-annotate.R | 54 +- tests/testthat/test-build.R | 12 +- tests/testthat/test-coord-.R | 24 +- tests/testthat/test-coord-cartesian.R | 73 +- tests/testthat/test-coord-flip.R | 11 +- tests/testthat/test-coord-map.R | 8 +- tests/testthat/test-coord-polar.R | 93 +- tests/testthat/test-coord-train.R | 29 +- tests/testthat/test-coord-transform.R | 15 +- tests/testthat/test-coord_sf.R | 102 +- tests/testthat/test-draw-key.R | 61 +- tests/testthat/test-empty-data.R | 13 +- tests/testthat/test-facet-.R | 181 +++- tests/testthat/test-facet-labels.R | 62 +- tests/testthat/test-facet-layout.R | 52 +- tests/testthat/test-facet-map.R | 107 +- tests/testthat/test-facet-strips.R | 11 +- tests/testthat/test-fortify.R | 50 +- tests/testthat/test-function-args.R | 62 +- tests/testthat/test-geom-.R | 12 +- tests/testthat/test-geom-bar.R | 10 +- tests/testthat/test-geom-boxplot.R | 22 +- tests/testthat/test-geom-col.R | 2 +- tests/testthat/test-geom-curve.R | 2 - tests/testthat/test-geom-dotplot.R | 321 ++++-- tests/testthat/test-geom-errorbar.R | 1 - tests/testthat/test-geom-hex.R | 10 +- tests/testthat/test-geom-hline-vline-abline.R | 12 +- tests/testthat/test-geom-label.R | 3 +- tests/testthat/test-geom-path.R | 65 +- tests/testthat/test-geom-polygon.R | 37 +- tests/testthat/test-geom-quantile.R | 5 +- tests/testthat/test-geom-raster.R | 66 +- tests/testthat/test-geom-rect.R | 13 +- tests/testthat/test-geom-ribbon.R | 42 +- tests/testthat/test-geom-rug.R | 28 +- tests/testthat/test-geom-sf.R | 212 ++-- tests/testthat/test-geom-smooth.R | 21 +- tests/testthat/test-geom-text.R | 66 +- tests/testthat/test-geom-tile.R | 14 +- tests/testthat/test-geom-violin.R | 83 +- tests/testthat/test-ggproto.R | 5 +- tests/testthat/test-ggsave.R | 8 +- tests/testthat/test-guide-.R | 14 +- tests/testthat/test-guide-axis.R | 185 ++-- tests/testthat/test-guide-colorbar.R | 35 +- tests/testthat/test-guide-legend.R | 63 +- tests/testthat/test-guides.R | 429 +++++--- tests/testthat/test-labellers.R | 6 +- tests/testthat/test-labels.R | 155 +-- tests/testthat/test-layer.R | 62 +- tests/testthat/test-legend-draw.R | 63 +- tests/testthat/test-munch.R | 94 +- tests/testthat/test-patterns.R | 26 +- tests/testthat/test-plot-summary-api.R | 22 +- tests/testthat/test-plot.R | 2 +- tests/testthat/test-position-dodge2.R | 5 +- tests/testthat/test-position-jitter.R | 5 +- tests/testthat/test-position-nudge.R | 15 +- tests/testthat/test-position-stack.R | 8 +- tests/testthat/test-position_dodge.R | 24 +- tests/testthat/test-prohibited-functions.R | 22 +- tests/testthat/test-qplot.R | 1 - tests/testthat/test-scale-binned.R | 10 +- tests/testthat/test-scale-colour.R | 8 +- tests/testthat/test-scale-date.R | 5 +- tests/testthat/test-scale-discrete.R | 44 +- tests/testthat/test-scale-expansion.R | 114 +- tests/testthat/test-scale-gradient.R | 1 - tests/testthat/test-scale-manual.R | 92 +- tests/testthat/test-scale_date.R | 32 +- tests/testthat/test-scales-breaks-labels.R | 125 ++- tests/testthat/test-scales.R | 149 ++- tests/testthat/test-sec-axis.R | 162 ++- tests/testthat/test-stat-align.R | 3 +- tests/testthat/test-stat-bin.R | 93 +- tests/testthat/test-stat-bin2d.R | 17 +- tests/testthat/test-stat-boxplot.R | 1 - tests/testthat/test-stat-connect.R | 7 +- tests/testthat/test-stat-contour.R | 16 +- tests/testthat/test-stat-count.R | 4 +- tests/testthat/test-stat-density.R | 10 +- tests/testthat/test-stat-ecdf.R | 6 +- tests/testthat/test-stat-ellipsis.R | 6 +- tests/testthat/test-stat-function.R | 29 +- tests/testthat/test-stat-manual.R | 1 - tests/testthat/test-stat-sf-coordinates.R | 32 +- tests/testthat/test-stat-sum.R | 9 +- tests/testthat/test-stat-summary.R | 26 +- tests/testthat/test-stat-ydensity.R | 18 +- tests/testthat/test-stats.R | 37 +- tests/testthat/test-summarise-plot.R | 2 - tests/testthat/test-theme.R | 438 +++++--- tests/testthat/test-utilities-checks.R | 3 - tests/testthat/test-utilities.R | 81 +- 295 files changed, 14471 insertions(+), 6897 deletions(-) create mode 100644 .vscode/extensions.json create mode 100644 .vscode/settings.json create mode 100644 air.toml diff --git a/.Rbuildignore b/.Rbuildignore index 9de8b2991c..810f62e5fa 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -29,3 +29,5 @@ visual_test ^vignettes/articles$ ^CRAN-SUBMISSION$ ^docs$ +^[.]?air[.]toml$ +^\.vscode$ diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 0000000000..344f76eba3 --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000000..a9f69fe419 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,10 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + }, + "[quarto]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "quarto.quarto" + } +} diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index e29d0c5d25..a5d04cf359 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -218,7 +218,11 @@ from_theme <- function(x) { stage <- function(start = NULL, after_stat = NULL, after_scale = NULL) { start } -stage_calculated <- function(start = NULL, after_stat = NULL, after_scale = NULL) { +stage_calculated <- function( + start = NULL, + after_stat = NULL, + after_scale = NULL +) { after_stat } stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) { @@ -304,13 +308,19 @@ strip_dots <- function(expr, env, strip_pronoun = FALSE) { } else if (is_quosure(expr)) { # strip dots from quosure and reconstruct the quosure new_quosure( - strip_dots(quo_get_expr(expr), env = quo_get_env(expr), strip_pronoun = strip_pronoun), + strip_dots( + quo_get_expr(expr), + env = quo_get_env(expr), + strip_pronoun = strip_pronoun + ), quo_get_env(expr) ) } else if (is.call(expr)) { if (strip_pronoun && is_call(expr, "$") && is_symbol(expr[[2]], ".data")) { strip_dots(expr[[3]], env, strip_pronoun = strip_pronoun) - } else if (strip_pronoun && is_call(expr, "[[") && is_symbol(expr[[2]], ".data")) { + } else if ( + strip_pronoun && is_call(expr, "[[") && is_symbol(expr[[2]], ".data") + ) { tryCatch( sym(eval(expr[[3]], env)), error = function(e) expr[[3]] @@ -318,12 +328,22 @@ strip_dots <- function(expr, env, strip_pronoun = FALSE) { } else if (is_call(expr, "stat")) { strip_dots(expr[[2]], env, strip_pronoun = strip_pronoun) } else { - expr[-1] <- lapply(expr[-1], strip_dots, env = env, strip_pronoun = strip_pronoun) + expr[-1] <- lapply( + expr[-1], + strip_dots, + env = env, + strip_pronoun = strip_pronoun + ) expr } } else if (is.pairlist(expr)) { # In the unlikely event of an anonymous function - as.pairlist(lapply(expr, strip_dots, env = env, strip_pronoun = strip_pronoun)) + as.pairlist(lapply( + expr, + strip_dots, + env = env, + strip_pronoun = strip_pronoun + )) } else if (is.list(expr)) { # For list of aesthetics lapply(expr, strip_dots, env = env, strip_pronoun = strip_pronoun) @@ -367,7 +387,6 @@ make_labels <- function(mapping) { } eval_aesthetics <- function(aesthetics, data, mask = NULL) { - env <- child_env(base_env()) # Here we mask functions, often to replace `stage()` with context appropriate @@ -400,4 +419,3 @@ mask_function <- function(x, mask) { } } } - diff --git a/R/aes.R b/R/aes.R index 208053bf52..10ad548293 100644 --- a/R/aes.R +++ b/R/aes.R @@ -140,7 +140,13 @@ local({ cat("\n") } else { values <- vapply(x, quo_label, character(1)) - bullets <- paste0("* ", format(paste0("`", names(x), "`")), " -> ", values, "\n") + bullets <- paste0( + "* ", + format(paste0("`", names(x), "`")), + " -> ", + values, + "\n" + ) cat(bullets, sep = "") } @@ -195,7 +201,9 @@ rename_aes <- function(x) { names(x) <- standardise_aes_names(names(x)) duplicated_names <- names(x)[duplicated(names(x))] if (length(duplicated_names) > 0L) { - cli::cli_warn("Duplicated aesthetics after name standardisation: {.field {unique0(duplicated_names)}}") + cli::cli_warn( + "Duplicated aesthetics after name standardisation: {.field {unique0(duplicated_names)}}" + ) } x } @@ -289,8 +297,12 @@ aes_ <- function(x, y, ...) { details = "Please use tidy evaluation idioms with `aes()`" ) mapping <- list(...) - if (!missing(x)) mapping["x"] <- list(x) - if (!missing(y)) mapping["y"] <- list(y) + if (!missing(x)) { + mapping["x"] <- list(x) + } + if (!missing(y)) { + mapping["y"] <- list(y) + } caller_env <- parent.frame() @@ -300,7 +312,9 @@ aes_ <- function(x, y, ...) { } else if (is.null(x) || is.call(x) || is.name(x) || is.atomic(x)) { new_aesthetic(x, caller_env) } else { - cli::cli_abort("Aesthetic must be a one-sided formula, call, name, or constant.") + cli::cli_abort( + "Aesthetic must be a one-sided formula, call, name, or constant." + ) } } mapping <- lapply(mapping, as_quosure_aes) @@ -319,8 +333,12 @@ aes_string <- function(x, y, ...) { ) ) mapping <- list(...) - if (!missing(x)) mapping["x"] <- list(x) - if (!missing(y)) mapping["y"] <- list(y) + if (!missing(x)) { + mapping["x"] <- list(x) + } + if (!missing(y)) { + mapping["y"] <- list(y) + } caller_env <- parent.frame() mapping <- lapply(mapping, function(x) { @@ -351,7 +369,9 @@ aes_all <- function(vars) { # Quosure the symbols in the empty environment because they can only # refer to the data mask - x <- class_mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) + x <- class_mapping(lapply(vars, function(x) { + new_quosure(as.name(x), emptyenv()) + })) class(x) <- union("unlabelled", class(x)) x } @@ -423,10 +443,13 @@ extract_target_is_likely_data <- function(x, data, env) { return(FALSE) } - tryCatch({ - data_eval <- eval_tidy(x[[2]], data, env) - identical(unrowname(data_eval), unrowname(data)) - }, error = function(err) FALSE) + tryCatch( + { + data_eval <- eval_tidy(x[[2]], data, env) + identical(unrowname(data_eval), unrowname(data)) + }, + error = function(err) FALSE + ) } # Takes a quosure and returns a named list of quosures, expanding @@ -438,7 +461,9 @@ arg_enquos <- function(name, frame = caller_env()) { expr <- quo_get_expr(quo) is_triple_bang <- !is_missing(expr) && - is_bang(expr) && is_bang(expr[[2]]) && is_bang(expr[[c(2, 2)]]) + is_bang(expr) && + is_bang(expr[[2]]) && + is_bang(expr[[c(2, 2)]]) if (is_triple_bang) { # Evaluate `!!!` operand and create a list of quosures env <- quo_get_env(quo) diff --git a/R/all-classes.R b/R/all-classes.R index 9f0f0ad44c..3398eae138 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -99,7 +99,7 @@ class_guides <- S7::new_S3_class("Guides") #' @export #' @format NULL #' @usage NULL -class_guide <- S7::new_S3_class("Guide") +class_guide <- S7::new_S3_class("Guide") #' @rdname class_definitions #' @section ggproto classes: @@ -108,7 +108,7 @@ class_guide <- S7::new_S3_class("Guide") #' @export #' @format NULL #' @usage NULL -class_coord <- S7::new_S3_class("Coord") +class_coord <- S7::new_S3_class("Coord") #' @rdname class_definitions @@ -118,7 +118,7 @@ class_coord <- S7::new_S3_class("Coord") #' @export #' @format NULL #' @usage NULL -class_facet <- S7::new_S3_class("Facet") +class_facet <- S7::new_S3_class("Facet") #' @rdname class_definitions #' @section ggproto classes: @@ -128,7 +128,7 @@ class_facet <- S7::new_S3_class("Facet") #' @export #' @format NULL #' @usage NULL -class_layer <- S7::new_S3_class("Layer") +class_layer <- S7::new_S3_class("Layer") #' @rdname class_definitions #' @section ggproto classes: @@ -213,12 +213,18 @@ class_derive <- S7::new_S3_class("derive") #' @keywords internal #' @export class_theme <- S7::new_class( - "theme", class_S3_gg, + "theme", + class_S3_gg, properties = list( complete = S7::class_logical, validate = S7::class_logical ), - constructor = function(elements = list(), ..., complete = FALSE, validate = TRUE) { + constructor = function( + elements = list(), + ..., + complete = FALSE, + validate = TRUE + ) { warn_dots_empty() S7::new_object( elements, @@ -246,7 +252,8 @@ class_theme <- S7::new_class( #' @keywords internal #' @export class_labels <- S7::new_class( - "labels", parent = class_S3_gg, + "labels", + parent = class_S3_gg, constructor = function(labels = list(), ...) { warn_dots_empty() S7::new_object(labels) @@ -282,7 +289,8 @@ class_labels <- S7::new_class( #' @keywords internal #' @export class_mapping <- S7::new_class( - "mapping", parent = class_S3_gg, + "mapping", + parent = class_S3_gg, constructor = function(x = list(), ..., env = globalenv()) { warn_dots_empty() check_object(x, is.list, "a {.cls list}") @@ -320,19 +328,20 @@ class_mapping <- S7::new_class( #' @keywords internal #' @export class_ggplot <- S7::new_class( - name = "ggplot", parent = class_gg, + name = "ggplot", + parent = class_gg, properties = list( - data = S7::class_any, - layers = S7::class_list, - scales = class_scales_list, - guides = class_guides, + data = S7::class_any, + layers = S7::class_list, + scales = class_scales_list, + guides = class_guides, mapping = class_mapping, - theme = class_theme, + theme = class_theme, coordinates = class_coord, - facet = class_facet, - layout = class_layout, - labels = class_labels, - meta = S7::class_list, + facet = class_facet, + layout = class_layout, + labels = class_labels, + meta = S7::class_list, plot_env = S7::class_environment ), constructor = function( @@ -353,18 +362,18 @@ class_ggplot <- S7::new_class( warn_dots_empty() S7::new_object( S7::S7_object(), - data = data, - layers = layers, - scales = scales %||% scales_list(), - guides = guides %||% guides_list(), - mapping = mapping, - theme = theme %||% theme(), + data = data, + layers = layers, + scales = scales %||% scales_list(), + guides = guides %||% guides_list(), + mapping = mapping, + theme = theme %||% theme(), coordinates = coordinates, - facet = facet, - layout = layout %||% ggproto(NULL, Layout), - labels = labels, - meta = meta, - plot_env = plot_env + facet = facet, + layout = layout %||% ggproto(NULL, Layout), + labels = labels, + meta = meta, + plot_env = plot_env ) } ) @@ -387,11 +396,12 @@ class_ggplot <- S7::new_class( #' @keywords internal #' @export class_ggplot_built <- S7::new_class( - "ggplot_built", parent = class_gg, + "ggplot_built", + parent = class_gg, properties = list( - data = S7::class_list, + data = S7::class_list, layout = class_layout, - plot = class_ggplot + plot = class_ggplot ), constructor = function(..., data = NULL, layout = NULL, plot = NULL) { warn_dots_empty() diff --git a/R/annotation-borders.R b/R/annotation-borders.R index 5f725d80a1..1ed9aae986 100644 --- a/R/annotation-borders.R +++ b/R/annotation-borders.R @@ -32,13 +32,24 @@ #' scale_size_area() + #' coord_quickmap() #' } -annotation_borders <- function(database = "world", regions = ".", fill = NA, - colour = "grey50", xlim = NULL, ylim = NULL, ...) { +annotation_borders <- function( + database = "world", + regions = ".", + fill = NA, + colour = "grey50", + xlim = NULL, + ylim = NULL, + ... +) { df <- map_data(database, regions, xlim = xlim, ylim = ylim) annotate( geom = "polygon", - x = df$long, y = df$lat, group = df$group, - fill = fill, colour = colour, ... + x = df$long, + y = df$lat, + group = df$group, + fill = fill, + colour = colour, + ... ) } diff --git a/R/annotation-custom.R b/R/annotation-custom.R index e727b48f1e..a2c6b8f062 100644 --- a/R/annotation-custom.R +++ b/R/annotation-custom.R @@ -41,7 +41,13 @@ NULL #' theme(plot.background = element_rect(colour = "black"))) #' base + #' annotation_custom(grob = g, xmin = 1, xmax = 10, ymin = 8, ymax = 10) -annotation_custom <- function(grob, xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf) { +annotation_custom <- function( + grob, + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = Inf +) { layer( data = dummy_data(), stat = StatIdentity, @@ -62,21 +68,40 @@ annotation_custom <- function(grob, xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = #' @format NULL #' @usage NULL #' @export -GeomCustomAnn <- ggproto("GeomCustomAnn", Geom, +GeomCustomAnn <- ggproto( + "GeomCustomAnn", + Geom, extra_params = "", handle_na = function(data, params) { data }, - draw_panel = function(data, panel_params, coord, grob, xmin, xmax, - ymin, ymax) { + draw_panel = function( + data, + panel_params, + coord, + grob, + xmin, + xmax, + ymin, + ymax + ) { range <- ranges_annotation( - coord, panel_params, xmin, xmax, ymin, ymax, + coord, + panel_params, + xmin, + xmax, + ymin, + ymax, fun = "annotation_custom" ) - vp <- viewport(x = mean(range$x), y = mean(range$y), - width = diff(range$x), height = diff(range$y), - just = c("center","center")) + vp <- viewport( + x = mean(range$x), + y = mean(range$y), + width = diff(range$x), + height = diff(range$y), + just = c("center", "center") + ) editGrob(grob, vp = vp, name = paste(grob$name, annotation_id())) }, @@ -91,7 +116,15 @@ annotation_id <- local({ } }) -ranges_annotation <- function(coord, panel_params, xmin, xmax, ymin, ymax, fun) { +ranges_annotation <- function( + coord, + panel_params, + xmin, + xmax, + ymin, + ymax, + fun +) { if (!inherits(coord, "CoordCartesian")) { cli::cli_abort("{.fn {fun}} only works with {.fn coord_cartesian}.") } diff --git a/R/annotation-logticks.R b/R/annotation-logticks.R index 7fa69aa843..830e6aa5aa 100644 --- a/R/annotation-logticks.R +++ b/R/annotation-logticks.R @@ -85,18 +85,38 @@ #' mid = unit(3,"mm"), #' long = unit(4,"mm") #' ) -annotation_logticks <- function(base = 10, sides = "bl", outside = FALSE, scaled = TRUE, - short = unit(0.1, "cm"), mid = unit(0.2, "cm"), long = unit(0.3, "cm"), - colour = "black", linewidth = 0.5, linetype = 1, alpha = 1, color = NULL, ..., - size = deprecated()) -{ - if (!is.null(color)) +annotation_logticks <- function( + base = 10, + sides = "bl", + outside = FALSE, + scaled = TRUE, + short = unit(0.1, "cm"), + mid = unit(0.2, "cm"), + long = unit(0.3, "cm"), + colour = "black", + linewidth = 0.5, + linetype = 1, + alpha = 1, + color = NULL, + ..., + size = deprecated() +) { + if (!is.null(color)) { colour <- color + } - lifecycle::signal_stage("superseded", "annotation_logticks()", "guide_axis_logticks()") + lifecycle::signal_stage( + "superseded", + "annotation_logticks()", + "guide_axis_logticks()" + ) if (lifecycle::is_present(size)) { - deprecate_soft0("3.5.0", I("Using the `size` aesthetic in this geom"), I("`linewidth`")) + deprecate_soft0( + "3.5.0", + I("Using the `size` aesthetic in this geom"), + I("`linewidth`") + ) linewidth <- linewidth %||% size } @@ -129,16 +149,26 @@ annotation_logticks <- function(base = 10, sides = "bl", outside = FALSE, scaled #' @format NULL #' @usage NULL #' @export -GeomLogticks <- ggproto("GeomLogticks", Geom, +GeomLogticks <- ggproto( + "GeomLogticks", + Geom, extra_params = "", handle_na = function(data, params) { data }, - draw_panel = function(data, panel_params, coord, base = 10, sides = "bl", - outside = FALSE, scaled = TRUE, short = unit(0.1, "cm"), - mid = unit(0.2, "cm"), long = unit(0.3, "cm")) - { + draw_panel = function( + data, + panel_params, + coord, + base = 10, + sides = "bl", + outside = FALSE, + scaled = TRUE, + short = unit(0.1, "cm"), + mid = unit(0.2, "cm"), + long = unit(0.3, "cm") + ) { ticks <- list() flipped <- inherits(coord, "CoordFlip") x_name <- if (flipped) "y" else "x" @@ -146,11 +176,10 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, # Convert these units to numbers so that they can be put in data frames short <- convertUnit(short, "cm", valueOnly = TRUE) - mid <- convertUnit(mid, "cm", valueOnly = TRUE) - long <- convertUnit(long, "cm", valueOnly = TRUE) + mid <- convertUnit(mid, "cm", valueOnly = TRUE) + long <- convertUnit(long, "cm", valueOnly = TRUE) if (grepl("[b|t]", sides) && all(is.finite(panel_params$x.range))) { - # Get positions of x tick marks xticks <- calc_logticks( base = base, @@ -162,30 +191,50 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, longend = long ) - if (scaled) + if (scaled) { xticks$value <- log(xticks$value, base) + } - names(xticks)[names(xticks) == "value"] <- x_name # Rename to 'x' for coordinates$transform + names(xticks)[names(xticks) == "value"] <- x_name # Rename to 'x' for coordinates$transform xticks <- coord$transform(xticks, panel_params) - xticks <- xticks[xticks$x <= 1 & xticks$x >= 0,] + xticks <- xticks[xticks$x <= 1 & xticks$x >= 0, ] - if (outside) + if (outside) { xticks$end = -xticks$end + } # Make the grobs if (grepl("b", sides) && nrow(xticks) > 0) { - ticks$x_b <- with(data, segmentsGrob( - x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"), - y0 = unit(xticks$start, "cm"), y1 = unit(xticks$end, "cm"), - gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) - )) + ticks$x_b <- with( + data, + segmentsGrob( + x0 = unit(xticks$x, "native"), + x1 = unit(xticks$x, "native"), + y0 = unit(xticks$start, "cm"), + y1 = unit(xticks$end, "cm"), + gp = gg_par( + col = alpha(colour, alpha), + lty = linetype, + lwd = linewidth + ) + ) + ) } if (grepl("t", sides) && nrow(xticks) > 0) { - ticks$x_t <- with(data, segmentsGrob( - x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"), - y0 = unit(1, "npc") - unit(xticks$start, "cm"), y1 = unit(1, "npc") - unit(xticks$end, "cm"), - gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) - )) + ticks$x_t <- with( + data, + segmentsGrob( + x0 = unit(xticks$x, "native"), + x1 = unit(xticks$x, "native"), + y0 = unit(1, "npc") - unit(xticks$start, "cm"), + y1 = unit(1, "npc") - unit(xticks$end, "cm"), + gp = gg_par( + col = alpha(colour, alpha), + lty = linetype, + lwd = linewidth + ) + ) + ) } } @@ -200,30 +249,50 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, longend = long ) - if (scaled) + if (scaled) { yticks$value <- log(yticks$value, base) + } - names(yticks)[names(yticks) == "value"] <- y_name # Rename to 'y' for coordinates$transform + names(yticks)[names(yticks) == "value"] <- y_name # Rename to 'y' for coordinates$transform yticks <- coord$transform(yticks, panel_params) - yticks <- yticks[yticks$y <= 1 & yticks$y >= 0,] + yticks <- yticks[yticks$y <= 1 & yticks$y >= 0, ] - if (outside) + if (outside) { yticks$end = -yticks$end + } # Make the grobs if (grepl("l", sides) && nrow(yticks) > 0) { - ticks$y_l <- with(data, segmentsGrob( - y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"), - x0 = unit(yticks$start, "cm"), x1 = unit(yticks$end, "cm"), - gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) - )) + ticks$y_l <- with( + data, + segmentsGrob( + y0 = unit(yticks$y, "native"), + y1 = unit(yticks$y, "native"), + x0 = unit(yticks$start, "cm"), + x1 = unit(yticks$end, "cm"), + gp = gg_par( + col = alpha(colour, alpha), + lty = linetype, + lwd = linewidth + ) + ) + ) } if (grepl("r", sides) && nrow(yticks) > 0) { - ticks$y_r <- with(data, segmentsGrob( - y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"), - x0 = unit(1, "npc") - unit(yticks$start, "cm"), x1 = unit(1, "npc") - unit(yticks$end, "cm"), - gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) - )) + ticks$y_r <- with( + data, + segmentsGrob( + y0 = unit(yticks$y, "native"), + y1 = unit(yticks$y, "native"), + x0 = unit(1, "npc") - unit(yticks$start, "cm"), + x1 = unit(1, "npc") - unit(yticks$end, "cm"), + gp = gg_par( + col = alpha(colour, alpha), + lty = linetype, + lwd = linewidth + ) + ) + ) } } @@ -244,20 +313,27 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, # - value: the position of the log tick on the data axis, for example 1, 2, ..., 9, 10, 20, ... # - start: on the other axis, start position of the line (usually 0) # - end: on the other axis, end position of the line (for example, .1, .2, or .3) -calc_logticks <- function(base = 10, ticks_per_base = base - 1, - minpow = 0, maxpow = minpow + 1, start = 0, shortend = 0.1, midend = 0.2, longend = 0.3) { - +calc_logticks <- function( + base = 10, + ticks_per_base = base - 1, + minpow = 0, + maxpow = minpow + 1, + start = 0, + shortend = 0.1, + midend = 0.2, + longend = 0.3 +) { # Number of blocks of tick marks reps <- maxpow - minpow # For base 10: 1, 2, 3, ..., 7, 8, 9, 1, 2, ... - ticknums <- rep(seq(1, base - 1, length.out = ticks_per_base), reps) + ticknums <- rep(seq(1, base - 1, length.out = ticks_per_base), reps) # For base 10: 1, 1, 1, ..., 1, 1, 1, 2, 2, ... (for example) powers <- rep(seq(minpow, maxpow - 1), each = ticks_per_base) - ticks <- ticknums * base ^ powers - ticks <- c(ticks, base ^ maxpow) # Add the last tick mark + ticks <- ticknums * base^powers + ticks <- c(ticks, base^maxpow) # Add the last tick mark # Set all of the ticks short tickend <- rep(shortend, length(ticks)) @@ -270,8 +346,8 @@ calc_logticks <- function(base = 10, ticks_per_base = base - 1, # Where to place the longer tick marks that are between each base # For base 10, this will be at each 5 - longtick_after_base <- floor(ticks_per_base/2) - tickend[ cycleIdx == longtick_after_base ] <- midend + longtick_after_base <- floor(ticks_per_base / 2) + tickend[cycleIdx == longtick_after_base] <- midend tickdf <- data_frame0( value = ticks, diff --git a/R/annotation-map.R b/R/annotation-map.R index 0c9353d1b2..76c364890d 100644 --- a/R/annotation-map.R +++ b/R/annotation-map.R @@ -59,11 +59,19 @@ NULL annotation_map <- function(map, ...) { # Get map input into correct form check_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 (!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))) { - cli::cli_abort("{.arg map} must have the columns {.col x}, {.col y}, and {.col id}.") + cli::cli_abort( + "{.arg map} must have the columns {.col x}, {.col y}, and {.col id}." + ) } layer( @@ -80,7 +88,9 @@ annotation_map <- function(map, ...) { #' @format NULL #' @usage NULL #' @export -GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap, +GeomAnnotationMap <- ggproto( + "GeomAnnotationMap", + GeomMap, extra_params = "", handle_na = function(data, params) { data @@ -93,12 +103,17 @@ GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap, coords$group <- coords$group %||% coords$id grob_id <- match(coords$group, unique0(coords$group)) - polygonGrob(coords$x, coords$y, default.units = "native", + polygonGrob( + coords$x, + coords$y, + default.units = "native", id = grob_id, gp = gg_par( - col = data$colour, fill = alpha(data$fill, data$alpha), - lwd = data$linewidth) + col = data$colour, + fill = alpha(data$fill, data$alpha), + lwd = data$linewidth ) + ) }, required_aes = c() diff --git a/R/annotation-raster.R b/R/annotation-raster.R index 594e30d557..ec8bddd461 100644 --- a/R/annotation-raster.R +++ b/R/annotation-raster.R @@ -37,10 +37,17 @@ NULL #' ggplot(mtcars, aes(mpg, wt)) + #' annotation_raster(rainbow2, -Inf, Inf, -Inf, Inf, interpolate = TRUE) + #' geom_point() -annotation_raster <- function(raster, xmin, xmax, ymin, ymax, - interpolate = FALSE) { - if (!inherits(raster, 'nativeRaster')) +annotation_raster <- function( + raster, + xmin, + xmax, + ymin, + ymax, + interpolate = FALSE +) { + if (!inherits(raster, 'nativeRaster')) { raster <- grDevices::as.raster(raster) + } layer( data = dummy_data(), @@ -58,28 +65,49 @@ annotation_raster <- function(raster, xmin, xmax, ymin, ymax, interpolate = interpolate ) ) - } #' @rdname Geom #' @format NULL #' @usage NULL #' @export -GeomRasterAnn <- ggproto("GeomRasterAnn", Geom, +GeomRasterAnn <- ggproto( + "GeomRasterAnn", + Geom, extra_params = "", handle_na = function(data, params) { data }, - draw_panel = function(data, panel_params, coord, raster, xmin, xmax, - ymin, ymax, interpolate = FALSE) { + draw_panel = function( + data, + panel_params, + coord, + raster, + xmin, + xmax, + ymin, + ymax, + interpolate = FALSE + ) { range <- ranges_annotation( - coord, panel_params, xmin, xmax, ymin, ymax, + coord, + panel_params, + xmin, + xmax, + ymin, + ymax, fun = "annotation_raster" ) - rasterGrob(raster, range$x[1], range$y[1], - diff(range$x), diff(range$y), default.units = "native", - just = c("left","bottom"), interpolate = interpolate + rasterGrob( + raster, + range$x[1], + range$y[1], + diff(range$x), + diff(range$y), + default.units = "native", + just = c("left", "bottom"), + interpolate = interpolate ) } ) diff --git a/R/annotation.R b/R/annotation.R index f56494c43c..fdbc85f3b0 100644 --- a/R/annotation.R +++ b/R/annotation.R @@ -40,10 +40,19 @@ #' parse = TRUE) #' p + annotate("text", x = 4, y = 25, #' label = "paste(italic(R) ^ 2, \" = .75\")", parse = TRUE) -annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, - ymin = NULL, ymax = NULL, xend = NULL, yend = NULL, ..., - na.rm = FALSE) { - +annotate <- function( + geom, + x = NULL, + y = NULL, + xmin = NULL, + xmax = NULL, + ymin = NULL, + ymax = NULL, + xend = NULL, + yend = NULL, + ..., + na.rm = FALSE +) { if (is_string(geom, c("abline", "hline", "vline"))) { cli::cli_warn(c( "{.arg geom} must not be {.val {geom}}.", @@ -52,8 +61,14 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, } position <- compact(list( - x = x, xmin = xmin, xmax = xmax, xend = xend, - y = y, ymin = ymin, ymax = ymax, yend = yend + x = x, + xmin = xmin, + xmax = xmax, + xend = xend, + y = y, + ymin = ymin, + ymax = ymax, + yend = yend )) aesthetics <- c(position, list(...)) @@ -95,4 +110,3 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, show.legend = FALSE ) } - diff --git a/R/autolayer.R b/R/autolayer.R index 3256968f94..e83c9f4e0f 100644 --- a/R/autolayer.R +++ b/R/autolayer.R @@ -15,5 +15,7 @@ autolayer <- function(object, ...) { #' @export autolayer.default <- function(object, ...) { - cli::cli_abort("No autolayer method available for {.cls {class(object)[1]}} objects.") + cli::cli_abort( + "No autolayer method available for {.cls {class(object)[1]}} objects." + ) } diff --git a/R/autoplot.R b/R/autoplot.R index cfcdc662b2..78d471cdd8 100644 --- a/R/autoplot.R +++ b/R/autoplot.R @@ -132,4 +132,3 @@ autoplot.default <- function(object, ...) { "i" = "Have you loaded the required package?" )) } - diff --git a/R/axis-secondary.R b/R/axis-secondary.R index d694cf3a47..eb6a382c28 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -96,19 +96,28 @@ #' ) #' #' @export -sec_axis <- function(transform = NULL, - name = waiver(), breaks = waiver(), labels = waiver(), - guide = waiver(), trans = deprecated()) { +sec_axis <- function( + transform = NULL, + name = waiver(), + breaks = waiver(), + labels = waiver(), + guide = waiver(), + trans = deprecated() +) { if (lifecycle::is_present(trans)) { deprecate_soft0("3.5.0", "sec_axis(trans)", "sec_axis(transform)") transform <- trans } # sec_axis() historically accepted two-sided formula, so be permissive. - if (length(transform) > 2) transform <- transform[c(1,3)] + if (length(transform) > 2) { + transform <- transform[c(1, 3)] + } transform <- as_function(transform) - ggproto(NULL, AxisSecondary, + ggproto( + NULL, + AxisSecondary, trans = transform, name = name, breaks = breaks, @@ -119,8 +128,14 @@ sec_axis <- function(transform = NULL, #' @rdname sec_axis #' #' @export -dup_axis <- function(transform = identity, name = derive(), breaks = derive(), - labels = derive(), guide = derive(), trans = deprecated()) { +dup_axis <- function( + transform = identity, + name = derive(), + breaks = derive(), + labels = derive(), + guide = derive(), + trans = deprecated() +) { sec_axis(transform, trans = trans, name, breaks, labels, guide) } @@ -132,10 +147,14 @@ set_sec_axis <- function(sec.axis, scale) { if (!is_waiver(sec.axis)) { if (scale$is_discrete()) { if (!identical(.subset2(sec.axis, "trans"), identity)) { - cli::cli_abort("Discrete secondary axes must have the {.fn identity} transformation.") + cli::cli_abort( + "Discrete secondary axes must have the {.fn identity} transformation." + ) } } - if (is_formula(sec.axis)) sec.axis <- sec_axis(sec.axis) + if (is_formula(sec.axis)) { + sec.axis <- sec_axis(sec.axis) + } if (!is_sec_axis(sec.axis)) { cli::cli_abort("Secondary axes must be specified using {.fn sec_axis}.") } @@ -157,7 +176,9 @@ is_derived <- function(x) { #' @format NULL #' @usage NULL #' @export -AxisSecondary <- ggproto("AxisSecondary", NULL, +AxisSecondary <- ggproto( + "AxisSecondary", + NULL, trans = NULL, axis = NULL, name = waiver(), @@ -182,8 +203,12 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, if (!is.function(transform)) { cli::cli_abort("Transformation for secondary axes must be a function.") } - if (is_derived(self$name) && !is_waiver(scale$name)) self$name <- scale$name - if (is_derived(self$breaks)) self$breaks <- scale$breaks + if (is_derived(self$name) && !is_waiver(scale$name)) { + self$name <- scale$name + } + if (is_derived(self$breaks)) { + self$breaks <- scale$breaks + } if (is_waiver(self$breaks)) { if (scale$is_discrete()) { self$breaks <- setNames(nm = scale$get_breaks()) @@ -197,7 +222,9 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, } } } - if (is_derived(self$labels)) self$labels <- scale$labels + if (is_derived(self$labels)) { + self$labels <- scale$labels + } if (is_derived(self$guide)) self$guide <- scale$guide }, @@ -205,7 +232,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, self$trans(range) }, - mono_test = function(self, scale){ + mono_test = function(self, scale) { range <- scale$range$range # Check if plot is empty @@ -221,14 +248,17 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, full_range <- self$transform_range(old_range) # Test for monotonicity - if (!is_unique(sign(diff(full_range)))) + if (!is_unique(sign(diff(full_range)))) { cli::cli_abort( "Transformation for secondary axes must be strictly monotonic." ) + } }, break_info = function(self, range, scale) { - if (self$empty()) return() + if (self$empty()) { + return() + } # Test for monotonicity on unexpanded range if (!scale$is_discrete()) { @@ -250,8 +280,8 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, # the transformation is non-monotonic in the expansion. The split ensures # the middle duplicated are kept duplicates <- c( - !duplicated(full_range[seq_len(self$detail/2)], fromLast = TRUE), - !duplicated(full_range[-seq_len(self$detail/2)]) + !duplicated(full_range[seq_len(self$detail / 2)], fromLast = TRUE), + !duplicated(full_range[-seq_len(self$detail / 2)]) ) old_range <- old_range[duplicates] full_range <- full_range[duplicates] @@ -262,17 +292,28 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, # patch for date and datetime scales just to maintain functionality # works only for linear secondary transforms that respect the time or date transform if (transformation$name %in% c("date", "time")) { - temp_scale <- self$create_scale(new_range, transformation = transformation) + temp_scale <- self$create_scale( + new_range, + transformation = transformation + ) range_info <- temp_scale$break_info() old_val_trans <- rescale(range_info$major, from = c(0, 1), to = range) - old_val_minor_trans <- rescale(range_info$minor, from = c(0, 1), to = range) + old_val_minor_trans <- rescale( + range_info$minor, + from = c(0, 1), + to = range + ) } else { temp_scale <- self$create_scale(new_range, breaks = breaks) range_info <- temp_scale$break_info() # Map the break values back to their correct position on the primary scale if (length(range_info$major_source) > 0) { - old_val <- stats::approx(full_range, old_range, range_info$major_source)$y + old_val <- stats::approx( + full_range, + old_range, + range_info$major_source + )$y old_val_trans <- transformation$transform(old_val) # rescale values from 0 to 1 @@ -288,7 +329,11 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, } if (length(range_info$minor_source) > 0) { - old_val_minor <- stats::approx(full_range, old_range, range_info$minor_source)$y + old_val_minor <- stats::approx( + full_range, + old_range, + range_info$minor_source + )$y old_val_minor_trans <- transformation$transform(old_val_minor) range_info$minor[] <- round( @@ -316,15 +361,21 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, }, # Temporary scale for the purpose of calling break_info() - create_scale = function(self, range, transformation = transform_identity(), - breaks = self$breaks) { - scale <- ggproto(NULL, ScaleContinuousPosition, - name = self$name, - breaks = breaks, - labels = self$labels, - limits = range, - expand = c(0, 0), - trans = transformation + create_scale = function( + self, + range, + transformation = transform_identity(), + breaks = self$breaks + ) { + scale <- ggproto( + NULL, + ScaleContinuousPosition, + name = self$name, + breaks = breaks, + labels = self$labels, + limits = range, + expand = c(0, 0), + trans = transformation ) scale$train(range) scale diff --git a/R/backports.R b/R/backports.R index 53ab2a6f7e..ddca4a01dd 100644 --- a/R/backports.R +++ b/R/backports.R @@ -3,13 +3,23 @@ if (getRversion() < "3.3") { absolute.units <- utils::getFromNamespace("absolute.units", "grid") absolute.units.unit <- utils::getFromNamespace("absolute.units.unit", "grid") - absolute.units.unit.list <- utils::getFromNamespace("absolute.units.unit.list", "grid") - absolute.units.unit.arithmetic <- utils::getFromNamespace("absolute.units.unit.arithmetic", "grid") + absolute.units.unit.list <- utils::getFromNamespace( + "absolute.units.unit.list", + "grid" + ) + absolute.units.unit.arithmetic <- utils::getFromNamespace( + "absolute.units.unit.arithmetic", + "grid" + ) backport_unit_methods <- function() { registerS3method("absolute.units", "unit", absolute.units.unit) registerS3method("absolute.units", "unit.list", absolute.units.unit.list) - registerS3method("absolute.units", "unit.arithmetic", absolute.units.unit.arithmetic) + registerS3method( + "absolute.units", + "unit.arithmetic", + absolute.units.unit.arithmetic + ) } } else { backport_unit_methods <- function() {} @@ -44,7 +54,7 @@ on_load({ # isFALSE() and isTRUE() are available on R (>=3.5) if (getRversion() < "3.5") { isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x - isTRUE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && x + isTRUE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && x } version_unavailable <- function(...) { @@ -54,8 +64,8 @@ version_unavailable <- function(...) { # Ignore mask argument if on lower R version (<= 4.1) viewport <- function(..., mask) grid::viewport(...) -pattern <- version_unavailable -as.mask <- version_unavailable +pattern <- version_unavailable +as.mask <- version_unavailable # Unavailable prior to R 4.1.0 linearGradient <- version_unavailable diff --git a/R/bin.R b/R/bin.R index 1318a180e0..355e8937ad 100644 --- a/R/bin.R +++ b/R/bin.R @@ -1,12 +1,12 @@ -bins <- function(breaks, closed = "right", - fuzz = NULL) { +bins <- function(breaks, closed = "right", fuzz = NULL) { check_numeric(breaks) closed <- arg_match0(closed, c("right", "left")) breaks <- sort(breaks) # Adapted base::hist - this protects from floating point rounding errors fuzz <- fuzz %||% 1e-08 * stats::median(diff(breaks[is.finite(breaks)])) - if (!is.finite(fuzz)) { # happens when 0 or 1 finite breaks are given + if (!is.finite(fuzz)) { + # happens when 0 or 1 finite breaks are given fuzz <- .Machine$double.eps * 1e3 } if (closed == "right") { @@ -52,9 +52,13 @@ bin_breaks <- function(breaks, closed = c("right", "left")) { bins(breaks, closed) } -bin_breaks_width <- function(x_range, width = NULL, center = NULL, - boundary = NULL, closed = c("right", "left")) { - +bin_breaks_width <- function( + x_range, + width = NULL, + center = NULL, + boundary = NULL, + closed = c("right", "left") +) { if (is.null(boundary)) { if (is.null(center)) { # If neither edge nor center given, compute both using tile layer's @@ -92,9 +96,13 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, bin_breaks(breaks, closed = closed) } -bin_breaks_bins <- function(x_range, bins = 30, center = NULL, - boundary = NULL, closed = c("right", "left")) { - +bin_breaks_bins <- function( + x_range, + bins = 30, + center = NULL, + boundary = NULL, + closed = c("right", "left") +) { if (zero_range(x_range)) { # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data width <- 0.1 @@ -109,17 +117,28 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL, } } - bin_breaks_width(x_range, width, boundary = boundary, center = center, - closed = closed) + bin_breaks_width( + x_range, + width, + boundary = boundary, + center = center, + closed = closed + ) } # Compute bins ------------------------------------------------------------ -compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = NULL, - center = NULL, boundary = NULL, - closed = c("right", "left")) { - +compute_bins <- function( + x, + scale = NULL, + breaks = NULL, + binwidth = NULL, + bins = NULL, + center = NULL, + boundary = NULL, + closed = c("right", "left") +) { range <- if (is_scale(scale)) scale$dimension() else range(x) check_length(range, 2L) @@ -139,7 +158,9 @@ compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = check_number_decimal(boundary, allow_infinite = FALSE, allow_null = TRUE) check_number_decimal(center, allow_infinite = FALSE, allow_null = TRUE) if (!is.null(boundary) && !is.null(center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.") + cli::cli_abort( + "Only one of {.arg boundary} and {.arg center} may be specified." + ) } if (!is.null(binwidth)) { @@ -149,8 +170,11 @@ compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = } check_number_decimal(binwidth, min = 0, allow_infinite = FALSE) bins <- bin_breaks_width( - range, binwidth, - center = center, boundary = boundary, closed = closed + range, + binwidth, + center = center, + boundary = boundary, + closed = closed ) return(bins) } @@ -161,8 +185,11 @@ compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = } check_number_whole(bins, min = 1, allow_infinite = FALSE) bin_breaks_bins( - range, bins, - center = center, boundary = boundary, closed = closed + range, + bins, + center = center, + boundary = boundary, + closed = closed ) } @@ -211,8 +238,13 @@ bin_cut <- function(x, bins) { cut(x, bins$fuzzy, right = bins$right_closed, include.lowest = TRUE) } -bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), - xmin = x - width / 2, xmax = x + width / 2) { +bin_out <- function( + count = integer(0), + x = numeric(0), + width = numeric(0), + xmin = x - width / 2, + xmax = x + width / 2 +) { density <- count / width / sum(abs(count)) data_frame0( @@ -241,7 +273,6 @@ bin_loc <- function(x, id) { } fix_bin_params <- function(params, fun, version) { - if (package_version(version) < "3.0.0") { deprecate <- lifecycle::deprecate_stop } else { diff --git a/R/compat-plyr.R b/R/compat-plyr.R index 580af44fc0..6b41309854 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -119,16 +119,14 @@ id <- function(.variables, drop = FALSE) { if (n > 2^31) { char_id <- inject(paste(!!!ids, sep = "\r")) res <- match(char_id, unique0(char_id)) - } - else { + } else { combs <- c(1, cumprod(ndistinct[-p])) mat <- inject(cbind(!!!ids)) res <- c((mat - 1L) %*% combs + 1L) } if (drop) { id_var(res, drop = TRUE) - } - else { + } else { res <- as.integer(res) attr(res, "n") <- n res @@ -173,14 +171,17 @@ join_keys <- function(x, y, by) { keys <- id(joint, drop = TRUE) n_x <- nrow(x) n_y <- nrow(y) - list(x = keys[seq_len(n_x)], y = keys[n_x + seq_len(n_y)], - n = attr(keys, "n")) + list( + x = keys[seq_len(n_x)], + y = keys[n_x + seq_len(n_y)], + n = attr(keys, "n") + ) } # round a number to a given precision round_any <- function(x, accuracy, f = round) { check_numeric(x) - f(x/accuracy) * accuracy + f(x / accuracy) * accuracy } #' Apply function to unique subsets of a data.frame @@ -207,12 +208,22 @@ dapply <- function(df, by, fun, ..., drop = TRUE) { fallback_order <- unique0(c(by, names(df))) apply_fun <- function(x) { res <- fun(x, ...) - if (is.null(res)) return(res) - if (length(res) == 0) return(data_frame0()) + if (is.null(res)) { + return(res) + } + if (length(res) == 0) { + return(data_frame0()) + } vars <- lapply(setNames(by, by), function(col) .subset2(x, col)[1]) - if (is.matrix(res)) res <- split_matrix(res) - if (is.null(names(res))) names(res) <- paste0("V", seq_along(res)) - if (all(by %in% names(res))) return(data_frame0(!!!unclass(res))) + if (is.matrix(res)) { + res <- split_matrix(res) + } + if (is.null(names(res))) { + names(res) <- paste0("V", seq_along(res)) + } + if (all(by %in% names(res))) { + return(data_frame0(!!!unclass(res))) + } res <- modify_list(unclass(vars), unclass(res)) res <- res[intersect(c(fallback_order, names(res)), names(res))] data_frame0(!!!res) diff --git a/R/coord-.R b/R/coord-.R index b14d95584c..3ead232247 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -70,7 +70,8 @@ #' ggplot(mpg, aes(drv, displ)) + #' geom_boxplot() + #' coord_jitter() -Coord <- ggproto("Coord", +Coord <- ggproto( + "Coord", # Fields ------------------------------------------------------------------ @@ -266,7 +267,8 @@ Coord <- ggproto("Coord", # Do guide setup guides <- guides$setup( - scales, aesthetics, + scales, + aesthetics, default = params$guide_default %||% guide_axis(), missing = params$guide_missing %||% guide_none() ) @@ -281,12 +283,14 @@ Coord <- ggproto("Coord", scale = scale_position[!is_sec] ) opposite <- c( - "top" = "bottom", "bottom" = "top", - "left" = "right", "right" = "left" + "top" = "bottom", + "bottom" = "top", + "left" = "right", + "right" = "left" ) guide_position[is_sec] <- Map( function(sec, prim) sec %|W|% unname(opposite[prim]), - sec = guide_position[is_sec], + sec = guide_position[is_sec], prim = guide_position[!is_sec] ) guide_params <- Map( @@ -295,7 +299,7 @@ Coord <- ggproto("Coord", params }, params = guide_params, - pos = guide_position + pos = guide_position ) # Update positions @@ -330,7 +334,6 @@ Coord <- ggproto("Coord", #' The `panel_params` object, but with trained and transformed `guides` #' parameter. train_panel_guides = function(self, panel_params, layers, params = list()) { - aesthetics <- c("x", "y", "x.sec", "y.sec") # If the panel_params doesn't contain the scale, there's no guide for the aesthetic @@ -338,7 +341,7 @@ Coord <- ggproto("Coord", names(aesthetics) <- aesthetics guides <- panel_params$guides$get_guide(aesthetics) - empty <- vapply(guides, inherits, logical(1), "GuideNone") + empty <- vapply(guides, inherits, logical(1), "GuideNone") guide_params <- panel_params$guides$get_params(aesthetics) aesthetics <- aesthetics[!empty] @@ -440,7 +443,9 @@ Coord <- ggproto("Coord", #' #' A list containing numeric ranges for `x` and `y` in data coordinates. backtransform_range = function(self, panel_params) { - cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn backtransform_range} method.") + cli::cli_abort( + "{.fn {snake_class(self)}} has not implemented a {.fn backtransform_range} method." + ) }, # return range stored in panel_params @@ -465,7 +470,9 @@ Coord <- ggproto("Coord", #' #' A list containing numeric ranges for `x` and `y`. range = function(self, panel_params) { - cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn range} method.") + cli::cli_abort( + "{.fn {snake_class(self)}} has not implemented a {.fn range} method." + ) }, ## render ----------------------------------------------------------------- @@ -555,7 +562,9 @@ Coord <- ggproto("Coord", #' #' A grob with panel background. render_bg = function(self, panel_params, theme) { - cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_bg} method.") + cli::cli_abort( + "{.fn {snake_class(self)}} has not implemented a {.fn render_bg} method." + ) }, #' @field labels @@ -638,11 +647,15 @@ Coord <- ggproto("Coord", #' `"right"` are grobs with an axis. These grobs should be [`zeroGrob()`] #' when no axes should be rendered. render_axis_h = function(self, panel_params, theme) { - cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_axis_h} method.") + cli::cli_abort( + "{.fn {snake_class(self)}} has not implemented a {.fn render_axis_h} method." + ) }, render_axis_v = function(self, panel_params, theme) { - cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_axis_v} method.") + cli::cli_abort( + "{.fn {snake_class(self)}} has not implemented a {.fn render_axis_v} method." + ) }, ## Utilities -------------------------------------------------------------- @@ -704,9 +717,21 @@ is.Coord <- function(x) { # generated render_axis <- function(panel_params, axis, scale, position, theme) { if (axis == "primary") { - draw_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme) - } else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) { - draw_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme) + draw_axis( + panel_params[[paste0(scale, ".major")]], + panel_params[[paste0(scale, ".labels")]], + position, + theme + ) + } else if ( + axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]]) + ) { + draw_axis( + panel_params[[paste0(scale, ".sec.major")]], + panel_params[[paste0(scale, ".sec.labels")]], + position, + theme + ) } else { zeroGrob() } @@ -737,7 +762,9 @@ parse_coord_expand <- function(expand) { # Utility function to check coord limits check_coord_limits <- function( - limits, arg = caller_arg(limits), call = caller_env() + limits, + arg = caller_arg(limits), + call = caller_env() ) { if (is.null(limits)) { return(invisible(NULL)) diff --git a/R/coord-cartesian-.R b/R/coord-cartesian-.R index eee2d4b061..099932d7c2 100644 --- a/R/coord-cartesian-.R +++ b/R/coord-cartesian-.R @@ -75,13 +75,21 @@ #' # When zooming the coordinate system, we see a subset of original 50 bins, #' # displayed bigger #' d + coord_cartesian(xlim = c(0, 1)) -coord_cartesian <- function(xlim = NULL, ylim = NULL, expand = TRUE, - default = FALSE, clip = "on", reverse = "none", - ratio = NULL) { +coord_cartesian <- function( + xlim = NULL, + ylim = NULL, + expand = TRUE, + default = FALSE, + clip = "on", + reverse = "none", + ratio = NULL +) { check_coord_limits(xlim) check_coord_limits(ylim) check_number_decimal(ratio, allow_infinite = FALSE, allow_null = TRUE) - ggproto(NULL, CoordCartesian, + ggproto( + NULL, + CoordCartesian, limits = list(x = xlim, y = ylim), reverse = reverse, expand = expand, @@ -95,7 +103,9 @@ coord_cartesian <- function(xlim = NULL, ylim = NULL, expand = TRUE, #' @format NULL #' @usage NULL #' @export -CoordCartesian <- ggproto("CoordCartesian", Coord, +CoordCartesian <- ggproto( + "CoordCartesian", + Coord, is_linear = function() { TRUE @@ -113,7 +123,10 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, }, distance = function(x, y, panel_params) { - max_dist <- dist_euclidean(panel_params$x$dimension(), panel_params$y$dimension()) + max_dist <- dist_euclidean( + panel_params$x$dimension(), + panel_params$y$dimension() + ) dist_euclidean(x, y) / max_dist }, @@ -148,12 +161,16 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, render_axis_h = function(panel_params, theme) { list( top = panel_guides_grob( - panel_params$guides, position = "top", - theme = theme, labels = panel_params$draw_labels$top + panel_params$guides, + position = "top", + theme = theme, + labels = panel_params$draw_labels$top ), bottom = panel_guides_grob( - panel_params$guides, position = "bottom", - theme = theme, labels = panel_params$draw_labels$bottom + panel_params$guides, + position = "bottom", + theme = theme, + labels = panel_params$draw_labels$bottom ) ) }, @@ -161,12 +178,16 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, render_axis_v = function(panel_params, theme) { list( left = panel_guides_grob( - panel_params$guides, position = "left", - theme = theme, labels = panel_params$draw_labels$left - ), + panel_params$guides, + position = "left", + theme = theme, + labels = panel_params$draw_labels$left + ), right = panel_guides_grob( - panel_params$guides, position = "right", - theme = theme, labels = panel_params$draw_labels$right + panel_params$guides, + position = "right", + theme = theme, + labels = panel_params$draw_labels$right ) ) } @@ -175,7 +196,12 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { expansion <- default_expansion(scale, expand = expand) limits <- scale$get_limits() - continuous_range <- expand_limits_scale(scale, expansion, limits, coord_limits = coord_limits) + continuous_range <- expand_limits_scale( + scale, + expansion, + limits, + coord_limits = coord_limits + ) aesthetic <- scale$aesthetics[1] view_scales <- list( @@ -183,7 +209,10 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { sec = view_scale_secondary(scale, limits, continuous_range), range = continuous_range ) - names(view_scales) <- c(aesthetic, paste0(aesthetic, ".", names(view_scales)[-1])) + names(view_scales) <- c( + aesthetic, + paste0(aesthetic, ".", names(view_scales)[-1]) + ) view_scales } diff --git a/R/coord-fixed.R b/R/coord-fixed.R index f35e3d8cbb..fb7ffa663c 100644 --- a/R/coord-fixed.R +++ b/R/coord-fixed.R @@ -36,7 +36,9 @@ coord_equal <- coord_fixed #' @format NULL #' @usage NULL #' @export -CoordFixed <- ggproto("CoordFixed", CoordCartesian, +CoordFixed <- ggproto( + "CoordFixed", + CoordCartesian, is_free = function() { FALSE }, diff --git a/R/coord-flip.R b/R/coord-flip.R index 3ea68a8273..b8f2d2fd97 100644 --- a/R/coord-flip.R +++ b/R/coord-flip.R @@ -60,7 +60,9 @@ coord_flip <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") { lifecycle::signal_stage("superseded", "coord_flip()") check_coord_limits(xlim) check_coord_limits(ylim) - ggproto(NULL, CoordFlip, + ggproto( + NULL, + CoordFlip, limits = list(x = xlim, y = ylim), expand = expand, clip = clip @@ -71,7 +73,9 @@ coord_flip <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") { #' @format NULL #' @usage NULL #' @export -CoordFlip <- ggproto("CoordFlip", CoordCartesian, +CoordFlip <- ggproto( + "CoordFlip", + CoordCartesian, transform = function(data, panel_params) { data <- flip_axis_labels(data) @@ -111,12 +115,12 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, lapply(scales_x, scale_flip_axis) lapply(scales_y, scale_flip_axis) } - ) # In-place modification of a scale position to swap axes scale_flip_axis <- function(scale) { - scale$position <- switch(scale$position, + scale$position <- switch( + scale$position, top = "right", bottom = "left", left = "bottom", diff --git a/R/coord-map.R b/R/coord-map.R index b23ca8abad..1ef0ce8c48 100644 --- a/R/coord-map.R +++ b/R/coord-map.R @@ -130,7 +130,15 @@ #' worldmap + coord_map("ortho", orientation = c(41, -74, 0)) #' } #' } -coord_map <- function(projection="mercator", ..., parameters = NULL, orientation = NULL, xlim = NULL, ylim = NULL, clip = "on") { +coord_map <- function( + projection = "mercator", + ..., + parameters = NULL, + orientation = NULL, + xlim = NULL, + ylim = NULL, + clip = "on" +) { if (is.null(parameters)) { params <- list(...) } else { @@ -140,7 +148,9 @@ coord_map <- function(projection="mercator", ..., parameters = NULL, orientation check_coord_limits(xlim) check_coord_limits(ylim) - ggproto(NULL, CoordMap, + ggproto( + NULL, + CoordMap, projection = projection, orientation = orientation, limits = list(x = xlim, y = ylim), @@ -153,7 +163,9 @@ coord_map <- function(projection="mercator", ..., parameters = NULL, orientation #' @format NULL #' @usage NULL #' @export -CoordMap <- ggproto("CoordMap", Coord, +CoordMap <- ggproto( + "CoordMap", + Coord, transform = function(self, data, panel_params) { trans <- mproject(self, data$x, data$y, panel_params$orientation) @@ -191,13 +203,16 @@ CoordMap <- ggproto("CoordMap", Coord, }, setup_panel_params = function(self, scale_x, scale_y, params = list()) { - # range in scale ranges <- list() for (n in c("x", "y")) { scale <- get(paste0("scale_", n)) limits <- self$limits[[n]] - range <- expand_limits_scale(scale, default_expansion(scale), coord_limits = limits) + range <- expand_limits_scale( + scale, + default_expansion(scale), + coord_limits = limits + ) ranges[[n]] <- range } @@ -226,11 +241,18 @@ CoordMap <- ggproto("CoordMap", Coord, details <- list( orientation = orientation, - x.range = ret$x$range, y.range = ret$y$range, - x.proj = ret$x$proj, y.proj = ret$y$proj, - x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels, - y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels, - x.arrange = scale_x$axis_order(), y.arrange = scale_y$axis_order() + x.range = ret$x$range, + y.range = ret$y$range, + x.proj = ret$x$proj, + y.proj = ret$y$proj, + x.major = ret$x$major, + x.minor = ret$x$minor, + x.labels = ret$x$labels, + y.major = ret$y$major, + y.minor = ret$y$minor, + y.labels = ret$y$labels, + x.arrange = scale_x$axis_order(), + y.arrange = scale_y$axis_order() ) details }, @@ -265,22 +287,31 @@ CoordMap <- ggproto("CoordMap", Coord, yrange[yrange < ymid - 90] <- ymid - 90 yrange[yrange > ymid + 90] <- ymid + 90 - xgrid <- with(panel_params, expand.grid( - y = c(seq(yrange[1], yrange[2], length.out = 50), NA), - x = x.major - )) - ygrid <- with(panel_params, expand.grid( - x = c(seq(xrange[1], xrange[2], length.out = 50), NA), - y = y.major - )) + xgrid <- with( + panel_params, + expand.grid( + y = c(seq(yrange[1], yrange[2], length.out = 50), NA), + x = x.major + ) + ) + ygrid <- with( + panel_params, + expand.grid( + x = c(seq(xrange[1], xrange[2], length.out = 50), NA), + y = y.major + ) + ) xlines <- self$transform(xgrid, panel_params) ylines <- self$transform(ygrid, panel_params) if (nrow(xlines) > 0) { grob.xlines <- element_render( - theme, "panel.grid.major.x", - xlines$x, xlines$y, default.units = "native" + theme, + "panel.grid.major.x", + xlines$x, + xlines$y, + default.units = "native" ) } else { grob.xlines <- zeroGrob() @@ -288,17 +319,24 @@ CoordMap <- ggproto("CoordMap", Coord, if (nrow(ylines) > 0) { grob.ylines <- element_render( - theme, "panel.grid.major.y", - ylines$x, ylines$y, default.units = "native" + theme, + "panel.grid.major.y", + ylines$x, + ylines$y, + default.units = "native" ) } else { grob.ylines <- zeroGrob() } - ggname("grill", grobTree( - element_render(theme, "panel.background"), - grob.xlines, grob.ylines - )) + ggname( + "grill", + grobTree( + element_render(theme, "panel.background"), + grob.xlines, + grob.ylines + ) + ) }, render_axis_h = function(self, panel_params, theme) { @@ -311,11 +349,14 @@ CoordMap <- ggproto("CoordMap", Coord, )) } - x_intercept <- with(panel_params, data_frame0( - x = x.major, - y = y.range[1], - .size = length(x.major) - )) + x_intercept <- with( + panel_params, + data_frame0( + x = x.major, + y = y.range[1], + .size = length(x.major) + ) + ) pos <- self$transform(x_intercept, panel_params) axes <- list( @@ -336,11 +377,14 @@ CoordMap <- ggproto("CoordMap", Coord, )) } - x_intercept <- with(panel_params, data_frame0( - x = x.range[1], - y = y.major, - .size = length(y.major) - )) + x_intercept <- with( + panel_params, + data_frame0( + x = x.range[1], + y = y.major, + .size = length(y.major) + ) + ) pos <- self$transform(x_intercept, panel_params) axes <- list( @@ -355,9 +399,11 @@ CoordMap <- ggproto("CoordMap", Coord, mproject <- function(coord, x, y, orientation) { check_installed("mapproj", reason = "for `coord_map()`.") - suppressWarnings(mapproj::mapproject(x, y, + suppressWarnings(mapproj::mapproject( + x, + y, projection = coord$projection, - parameters = coord$params, + parameters = coord$params, orientation = orientation )) } diff --git a/R/coord-munch.R b/R/coord-munch.R index 9c314ffc59..5889e85e67 100644 --- a/R/coord-munch.R +++ b/R/coord-munch.R @@ -12,8 +12,16 @@ #' @param is_closed Whether data should be considered as a closed polygon. #' @keywords internal #' @export -coord_munch <- function(coord, data, range, segment_length = 0.01, is_closed = FALSE) { - if (coord$is_linear()) return(coord$transform(data, range)) +coord_munch <- function( + coord, + data, + range, + segment_length = 0.01, + is_closed = FALSE +) { + if (coord$is_linear()) { + return(coord$transform(data, range)) + } if (is_closed) { data <- close_poly(data) @@ -26,9 +34,9 @@ coord_munch <- function(coord, data, range, segment_length = 0.01, is_closed = F # Only need to work with x and y because for munching, those are the # only position aesthetics that are transformed data$x[data$x == -Inf] <- ranges$x[1] - data$x[data$x == Inf] <- ranges$x[2] + data$x[data$x == Inf] <- ranges$x[2] data$y[data$y == -Inf] <- ranges$y[1] - data$y[data$y == Inf] <- ranges$y[2] + data$y[data$y == Inf] <- ranges$y[2] # Calculate distances using coord distance metric dist <- coord$distance(data$x, data$y, range) @@ -65,8 +73,14 @@ munch_data <- function(data, dist = NULL, segment_length = 0.01) { extra[is.na(extra)] <- 1 # Generate extra pieces for x and y values # The final point must be manually inserted at the end - x <- c(unlist(mapply(interp, data$x[-n], data$x[-1], extra, SIMPLIFY = FALSE)), data$x[n]) - y <- c(unlist(mapply(interp, data$y[-n], data$y[-1], extra, SIMPLIFY = FALSE)), data$y[n]) + x <- c( + unlist(mapply(interp, data$x[-n], data$x[-1], extra, SIMPLIFY = FALSE)), + data$x[n] + ) + y <- c( + unlist(mapply(interp, data$y[-n], data$y[-1], extra, SIMPLIFY = FALSE)), + data$y[n] + ) # Replicate other aesthetics: defined by start point but also # must include final point @@ -80,7 +94,9 @@ munch_data <- function(data, dist = NULL, segment_length = 0.01) { # Interpolate n-1 evenly spaced steps (n points) from start to # (end - (end - start) / n). end is never included in sequence. interp <- function(start, end, n) { - if (n == 1) return(start) + if (n == 1) { + return(start) + } start + seq(0, 1, length.out = n + 1)[-(n + 1)] * (end - start) } @@ -89,7 +105,7 @@ interp <- function(start, end, n) { dist_euclidean <- function(x, y) { n <- length(x) - sqrt((x[-n] - x[-1]) ^ 2 + (y[-n] - y[-1]) ^ 2) + sqrt((x[-n] - x[-1])^2 + (y[-n] - y[-1])^2) } # Compute central angle between two points. @@ -101,7 +117,7 @@ dist_central_angle <- function(lon, lat) { lat <- lat * pi / 180 lon <- lon * pi / 180 - hav <- function(x) sin(x / 2) ^ 2 + hav <- function(x) sin(x / 2)^2 ahav <- function(x) 2 * asin(x) n <- length(lat) @@ -116,7 +132,6 @@ dist_central_angle <- function(lon, lat) { # warped into polar space. These lines are all spiral arcs, circular # arcs, or segments of rays. dist_polar <- function(r, theta) { - # Pretending that theta is x and r is y, find the slope and intercepts # for each line segment. # This is just like finding the x-intercept of a line in cartesian coordinates. @@ -125,8 +140,17 @@ dist_polar <- function(r, theta) { # Rename x and y columns to r and t, since we're working in polar # Note that 'slope' actually means the spiral slope, 'a' in the spiral # formula r = a * theta - lf <- rename(lf, c(x1 = "t1", x2 = "t2", y1 = "r1", y2 = "r2", - yintercept = "r_int", xintercept = "t_int")) + lf <- rename( + lf, + c( + x1 = "t1", + x2 = "t2", + y1 = "r1", + y2 = "r2", + yintercept = "r_int", + xintercept = "t_int" + ) + ) # Re-normalize the theta values so that intercept for each is 0 # This is necessary for calculating spiral arc length. @@ -210,9 +234,10 @@ find_line_formula <- function(x, y) { spiral_arc_length <- function(a, theta1, theta2) { # Archimedes' spiral arc length formula from # http://mathworld.wolfram.com/ArchimedesSpiral.html - 0.5 * a * ( - (theta1 * sqrt(1 + theta1 * theta1) + asinh(theta1)) - - (theta2 * sqrt(1 + theta2 * theta2) + asinh(theta2))) + 0.5 * + a * + ((theta1 * sqrt(1 + theta1 * theta1) + asinh(theta1)) - + (theta2 * sqrt(1 + theta2 * theta2) + asinh(theta2))) } # Closes a polygon type data structure by repeating the first-in-group after diff --git a/R/coord-polar.R b/R/coord-polar.R index 107cbf0f74..74e1707580 100644 --- a/R/coord-polar.R +++ b/R/coord-polar.R @@ -5,7 +5,9 @@ coord_polar <- function(theta = "x", start = 0, direction = 1, clip = "on") { r <- if (theta == "x") "y" else "x" lifecycle::signal_stage("superseded", "coord_polar()", "coord_radial()") - ggproto(NULL, CoordPolar, + ggproto( + NULL, + CoordPolar, theta = theta, r = r, start = start, @@ -18,7 +20,9 @@ coord_polar <- function(theta = "x", start = 0, direction = 1, clip = "on") { #' @format NULL #' @usage NULL #' @export -CoordPolar <- ggproto("CoordPolar", Coord, +CoordPolar <- ggproto( + "CoordPolar", + Coord, aspect = function(details) { 1 @@ -56,17 +60,15 @@ CoordPolar <- ggproto("CoordPolar", Coord, }, setup_panel_params = function(self, scale_x, scale_y, params = list()) { - ret <- list(x = list(), y = list()) for (n in c("x", "y")) { - scale <- get(paste0("scale_", n)) limits <- self$limits[[n]] if (self$theta == n) { expansion <- default_expansion(scale, c(0, 0.5), c(0, 0)) } else { - expansion <- default_expansion(scale, c(0, 0), c(0, 0)) + expansion <- default_expansion(scale, c(0, 0), c(0, 0)) } range <- expand_limits_scale(scale, expansion, coord_limits = limits) @@ -82,14 +84,22 @@ CoordPolar <- ggproto("CoordPolar", Coord, } details <- list( - x.range = ret$x$range, y.range = ret$y$range, - x.major = ret$x$major, y.major = ret$y$major, - x.minor = ret$x$minor, y.minor = ret$y$minor, - x.labels = ret$x$labels, y.labels = ret$y$labels, - x.sec.range = ret$x$sec.range, y.sec.range = ret$y$sec.range, - x.sec.major = ret$x$sec.major, y.sec.major = ret$y$sec.major, - x.sec.minor = ret$x$sec.minor, y.sec.minor = ret$y$sec.minor, - x.sec.labels = ret$x$sec.labels, y.sec.labels = ret$y$sec.labels + x.range = ret$x$range, + y.range = ret$y$range, + x.major = ret$x$major, + y.major = ret$y$major, + x.minor = ret$x$minor, + y.minor = ret$y$minor, + x.labels = ret$x$labels, + y.labels = ret$y$labels, + x.sec.range = ret$x$sec.range, + y.sec.range = ret$y$sec.range, + x.sec.major = ret$x$sec.major, + y.sec.major = ret$y$sec.major, + x.sec.minor = ret$x$sec.minor, + y.sec.minor = ret$y$sec.minor, + x.sec.labels = ret$x$sec.labels, + y.sec.labels = ret$y$sec.labels ) if (self$theta == "y") { @@ -119,7 +129,13 @@ CoordPolar <- ggproto("CoordPolar", Coord, panel_params }, - train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + train_panel_guides = function( + self, + panel_params, + layers, + default_mapping, + params = list() + ) { panel_params }, @@ -128,11 +144,11 @@ CoordPolar <- ggproto("CoordPolar", Coord, return(data) } - arc <- self$start + c(0, 2 * pi) - dir <- self$direction + arc <- self$start + c(0, 2 * pi) + dir <- self$direction data <- rename_data(self, data) - data$r <- r_rescale(data$r, panel_params$r.range) + data$r <- r_rescale(data$r, panel_params$r.range) data$theta <- theta_rescale(data$theta, panel_params$theta.range, arc, dir) data$x <- data$r * sin(data$theta) + 0.5 data$y <- data$r * cos(data$theta) + 0.5 @@ -149,7 +165,8 @@ CoordPolar <- ggproto("CoordPolar", Coord, panel_params$r.sec.major <- r_rescale( panel_params$r.sec.major, panel_params$r.sec.range - ) + 0.5 + ) + + 0.5 } list( @@ -170,10 +187,22 @@ CoordPolar <- ggproto("CoordPolar", Coord, arc <- self$start + c(0, 2 * pi) dir <- self$direction - theta <- if (length(panel_params$theta.major) > 0) - theta_rescale(panel_params$theta.major, panel_params$theta.range, arc, dir) - thetamin <- if (length(panel_params$theta.minor) > 0) - theta_rescale(panel_params$theta.minor, panel_params$theta.range, arc, dir) + theta <- if (length(panel_params$theta.major) > 0) { + theta_rescale( + panel_params$theta.major, + panel_params$theta.range, + arc, + dir + ) + } + thetamin <- if (length(panel_params$theta.minor) > 0) { + theta_rescale( + panel_params$theta.minor, + panel_params$theta.range, + arc, + dir + ) + } thetafine <- seq(0, 2 * pi, length.out = 100) rfine <- c(r_rescale(panel_params$r.major, panel_params$r.range), 0.45) @@ -182,33 +211,50 @@ CoordPolar <- ggproto("CoordPolar", Coord, # panel.grid.major.x or .y majortheta <- paste("panel.grid.major.", self$theta, sep = "") minortheta <- paste("panel.grid.minor.", self$theta, sep = "") - majorr <- paste("panel.grid.major.", self$r, sep = "") - - ggname("grill", grobTree( - element_render(theme, "panel.background"), - if (length(theta) > 0) element_render( - theme, majortheta, name = "angle", - x = vec_interleave(0, 0.45 * sin(theta)) + 0.5, - y = vec_interleave(0, 0.45 * cos(theta)) + 0.5, - id.lengths = rep(2, length(theta)), - default.units = "native" - ), - if (length(thetamin) > 0) element_render( - theme, minortheta, name = "angle", - x = vec_interleave(0, 0.45 * sin(thetamin)) + 0.5, - y = vec_interleave(0, 0.45 * cos(thetamin)) + 0.5, - id.lengths = rep(2, length(thetamin)), - default.units = "native" - ), - - element_render( - theme, majorr, name = "radius", - x = rep(rfine, each = length(thetafine)) * rep(sin(thetafine), length(rfine)) + 0.5, - y = rep(rfine, each = length(thetafine)) * rep(cos(thetafine), length(rfine)) + 0.5, - id.lengths = rep(length(thetafine), length(rfine)), - default.units = "native" + majorr <- paste("panel.grid.major.", self$r, sep = "") + + ggname( + "grill", + grobTree( + element_render(theme, "panel.background"), + if (length(theta) > 0) { + element_render( + theme, + majortheta, + name = "angle", + x = vec_interleave(0, 0.45 * sin(theta)) + 0.5, + y = vec_interleave(0, 0.45 * cos(theta)) + 0.5, + id.lengths = rep(2, length(theta)), + default.units = "native" + ) + }, + if (length(thetamin) > 0) { + element_render( + theme, + minortheta, + name = "angle", + x = vec_interleave(0, 0.45 * sin(thetamin)) + 0.5, + y = vec_interleave(0, 0.45 * cos(thetamin)) + 0.5, + id.lengths = rep(2, length(thetamin)), + default.units = "native" + ) + }, + + element_render( + theme, + majorr, + name = "radius", + x = rep(rfine, each = length(thetafine)) * + rep(sin(thetafine), length(rfine)) + + 0.5, + y = rep(rfine, each = length(thetafine)) * + rep(cos(thetafine), length(rfine)) + + 0.5, + id.lengths = rep(length(thetafine), length(rfine)), + default.units = "native" + ) ) - )) + ) }, render_fg = function(self, panel_params, theme) { @@ -218,17 +264,24 @@ CoordPolar <- ggproto("CoordPolar", Coord, arc <- self$start + c(0, 2 * pi) dir <- self$direction - theta <- theta_rescale(panel_params$theta.major, panel_params$theta.range, arc, dir) + theta <- theta_rescale( + panel_params$theta.major, + panel_params$theta.range, + arc, + dir + ) labels <- panel_params$theta.labels # Combine the two ends of the scale if they are close theta <- theta[!is.na(theta)] - ends_apart <- (theta[length(theta)] - theta[1]) %% (2*pi) + ends_apart <- (theta[length(theta)] - theta[1]) %% (2 * pi) if (length(theta) > 0 && ends_apart < 0.05 && !is.null(labels)) { n <- length(labels) if (is.expression(labels)) { - combined <- substitute(paste(a, "/", b), - list(a = labels[[1]], b = labels[[n]])) + combined <- substitute( + paste(a, "/", b), + list(a = labels[[1]], b = labels[[n]]) + ) } else { combined <- paste(labels[1], labels[n], sep = "/") } @@ -238,13 +291,17 @@ CoordPolar <- ggproto("CoordPolar", Coord, } grobTree( - if (length(labels) > 0) element_render( - theme, "axis.text.x", - labels, - unit(0.45 * sin(theta) + 0.5, "native"), - unit(0.45 * cos(theta) + 0.5, "native"), - hjust = 0.5, vjust = 0.5 - ), + if (length(labels) > 0) { + element_render( + theme, + "axis.text.x", + labels, + unit(0.45 * sin(theta) + 0.5, "native"), + unit(0.45 * cos(theta) + 0.5, "native"), + hjust = 0.5, + vjust = 0.5 + ) + }, element_render(theme, "panel.border", fill = NA) ) }, @@ -258,8 +315,9 @@ CoordPolar <- ggproto("CoordPolar", Coord, }, modify_scales = function(self, scales_x, scales_y) { - if (self$theta != "y") + if (self$theta != "y") { return() + } lapply(scales_x, scale_flip_position) lapply(scales_y, scale_flip_position) diff --git a/R/coord-quickmap.R b/R/coord-quickmap.R index aec97f1472..01bbbd88e0 100644 --- a/R/coord-quickmap.R +++ b/R/coord-quickmap.R @@ -1,10 +1,17 @@ #' @inheritParams coord_cartesian #' @export #' @rdname coord_map -coord_quickmap <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") { +coord_quickmap <- function( + xlim = NULL, + ylim = NULL, + expand = TRUE, + clip = "on" +) { check_coord_limits(xlim) check_coord_limits(ylim) - ggproto(NULL, CoordQuickmap, + ggproto( + NULL, + CoordQuickmap, limits = list(x = xlim, y = ylim), expand = expand, clip = clip @@ -15,7 +22,9 @@ coord_quickmap <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") #' @format NULL #' @usage NULL #' @export -CoordQuickmap <- ggproto("CoordQuickmap", CoordCartesian, +CoordQuickmap <- ggproto( + "CoordQuickmap", + CoordCartesian, aspect = function(ranges) { # compute coordinates of center point of map diff --git a/R/coord-radial.R b/R/coord-radial.R index 32dd33599e..63566efd9d 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -110,33 +110,43 @@ #' thetalim = c(200, 300), #' rlim = c(15, 30), #' ) -coord_radial <- function(theta = "x", - start = 0, end = NULL, - thetalim = NULL, rlim = NULL, expand = TRUE, - direction = deprecated(), - clip = "off", - r.axis.inside = NULL, - rotate.angle = FALSE, - inner.radius = 0, - reverse = "none", - r_axis_inside = deprecated(), - rotate_angle = deprecated()) { - +coord_radial <- function( + theta = "x", + start = 0, + end = NULL, + thetalim = NULL, + rlim = NULL, + expand = TRUE, + direction = deprecated(), + clip = "off", + r.axis.inside = NULL, + rotate.angle = FALSE, + inner.radius = 0, + reverse = "none", + r_axis_inside = deprecated(), + rotate_angle = deprecated() +) { if (lifecycle::is_present(r_axis_inside)) { deprecate_warn0( - "3.5.1", "coord_radial(r_axis_inside)", "coord_radial(r.axis.inside)" + "3.5.1", + "coord_radial(r_axis_inside)", + "coord_radial(r.axis.inside)" ) r.axis.inside <- r_axis_inside } if (lifecycle::is_present(rotate_angle)) { deprecate_warn0( - "3.5.1", "coord_radial(rotate_angle)", "coord_radial(rotate.angle)" + "3.5.1", + "coord_radial(rotate_angle)", + "coord_radial(rotate.angle)" ) rotate.angle <- rotate_angle } if (lifecycle::is_present(direction)) { deprecate_warn0( - "4.0.0", "coord_radial(direction)", "coord_radial(reverse)" + "4.0.0", + "coord_radial(direction)", + "coord_radial(reverse)" ) reverse <- switch(reverse, "r" = "thetar", "theta") } @@ -175,7 +185,9 @@ coord_radial <- function(theta = "x", inner.radius <- c(inner.radius, 1) * 0.4 inner.radius <- switch(reverse, thetar = , r = rev, identity)(inner.radius) - ggproto(NULL, CoordRadial, + ggproto( + NULL, + CoordRadial, limits = list(theta = thetalim, r = rlim), theta = theta, r = r, @@ -193,7 +205,9 @@ coord_radial <- function(theta = "x", #' @format NULL #' @usage NULL #' @export -CoordRadial <- ggproto("CoordRadial", Coord, +CoordRadial <- ggproto( + "CoordRadial", + Coord, aspect = function(details) { diff(details$bbox$y) / diff(details$bbox$x) @@ -238,14 +252,23 @@ CoordRadial <- ggproto("CoordRadial", Coord, ylimits <- self$limits$theta } params <- c( - view_scales_polar(scale_x, self$theta, xlimits, + view_scales_polar( + scale_x, + self$theta, + xlimits, expand = params$expand[c(4, 2)] ), - view_scales_polar(scale_y, self$theta, ylimits, + view_scales_polar( + scale_y, + self$theta, + ylimits, expand = params$expand[c(3, 1)] ), - list(bbox = polar_bbox(self$arc, inner_radius = self$inner_radius), - arc = self$arc, inner_radius = self$inner_radius) + list( + bbox = polar_bbox(self$arc, inner_radius = self$inner_radius), + arc = self$arc, + inner_radius = self$inner_radius + ) ) axis_rotation <- self$r_axis_inside @@ -254,8 +277,10 @@ CoordRadial <- ggproto("CoordRadial", Coord, axis_rotation <- theta_scale$transform(axis_rotation) axis_rotation <- oob_squish(axis_rotation, params$theta.range) axis_rotation <- theta_rescale( - axis_rotation, params$theta.range, - params$arc, 1 + axis_rotation, + params$theta.range, + params$arc, + 1 ) params$axis_rotation <- rep_len(axis_rotation, length.out = 2) } else { @@ -266,17 +291,18 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, setup_panel_guides = function(self, panel_params, guides, params = list()) { - aesthetics <- c("r", "theta", "r.sec", "theta.sec") names(aesthetics) <- aesthetics is_sec <- grepl("sec$", aesthetics) scales <- panel_params[aesthetics] # Fill in theta guide default - panel_params$theta$guide <- panel_params$theta$guide %|W|% guide_axis_theta() + panel_params$theta$guide <- panel_params$theta$guide %|W|% + guide_axis_theta() guides <- guides$setup( - scales, aesthetics, + scales, + aesthetics, default = params$guide_default %||% guide_axis(), missing = params$guide_missing %||% guide_none() ) @@ -291,7 +317,7 @@ CoordRadial <- ggproto("CoordRadial", Coord, names(guide_params) <- aesthetics # Set guide positions - guide_params[["theta"]]$position <- "theta" + guide_params[["theta"]]$position <- "theta" guide_params[["theta.sec"]]$position <- "theta.sec" if (self$theta == "x") { @@ -301,7 +327,6 @@ CoordRadial <- ggproto("CoordRadial", Coord, } if (!isFALSE(self$r_axis_inside)) { - r_position <- c("left", "right") # If both opposite direction and opposite position, don't flip if (xor(self$reverse %in% c("thetar", "theta"), opposite_r)) { @@ -312,15 +337,16 @@ CoordRadial <- ggproto("CoordRadial", Coord, arc <- rev(arc) } # Set guide text angles - guide_params[["r"]]$angle <- guide_params[["r"]]$angle %|W|% arc[1] - guide_params[["r.sec"]]$angle <- guide_params[["r.sec"]]$angle %|W|% arc[2] + guide_params[["r"]]$angle <- guide_params[["r"]]$angle %|W|% arc[1] + guide_params[["r.sec"]]$angle <- guide_params[["r.sec"]]$angle %|W|% + arc[2] } else { r_position <- c(params$r_axis, opposite_position(params$r_axis)) if (opposite_r) { r_position <- rev(r_position) } } - guide_params[["r"]]$position <- r_position[1] + guide_params[["r"]]$position <- r_position[1] guide_params[["r.sec"]]$position <- r_position[2] guide_params[drop_guides] <- list(NULL) @@ -331,14 +357,13 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, train_panel_guides = function(self, panel_params, layers, params = list()) { - aesthetics <- c("r", "theta", "r.sec", "theta.sec") aesthetics <- intersect(aesthetics, names(panel_params$guides$aesthetics)) names(aesthetics) <- aesthetics guides <- panel_params$guides$get_guide(aesthetics) names(guides) <- aesthetics - empty <- vapply(guides, inherits, logical(1), "GuideNone") + empty <- vapply(guides, inherits, logical(1), "GuideNone") gdefs <- panel_params$guides$get_params(aesthetics) names(gdefs) <- aesthetics @@ -393,9 +418,9 @@ CoordRadial <- ggproto("CoordRadial", Coord, data <- rename_data(self, data) bbox <- panel_params$bbox %||% list(x = c(0, 1), y = c(0, 1)) - arc <- panel_params$arc %||% c(0, 2 * pi) + arc <- panel_params$arc %||% c(0, 2 * pi) - data$r <- r_rescale(data$r, panel_params$r.range, panel_params$inner_radius) + data$r <- r_rescale(data$r, panel_params$r.range, panel_params$inner_radius) data$theta <- theta_rescale(data$theta, panel_params$theta.range, arc) data$x <- rescale(data$r * sin(data$theta) + 0.5, from = bbox$x) data$y <- rescale(data$r * cos(data$theta) + 0.5, from = bbox$y) @@ -431,7 +456,6 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, render_fg = function(self, panel_params, theme) { - border <- element_render(theme, "panel.border", fill = NA) if (isFALSE(self$r_axis_inside)) { @@ -444,10 +468,10 @@ CoordRadial <- ggproto("CoordRadial", Coord, } bbox <- panel_params$bbox - dir <- self$direction - rot <- panel_params$axis_rotation - rot <- switch(self$reverse, thetar = , theta = rev(rot), rot) - rot <- rad2deg(-rot) + dir <- self$direction + rot <- panel_params$axis_rotation + rot <- switch(self$reverse, thetar = , theta = rev(rot), rot) + rot <- rad2deg(-rot) left <- panel_guides_grob(panel_params$guides, position = "left", theme) left <- rotate_r_axis(left, rot[1], bbox, "left") @@ -458,12 +482,12 @@ CoordRadial <- ggproto("CoordRadial", Coord, grobTree( panel_guides_grob(panel_params$guides, "theta", theme), panel_guides_grob(panel_params$guides, "theta.sec", theme), - left, right, + left, + right, border ) }, - draw_panel = function(self, panel, params, theme) { clip_support <- check_device("clippingPaths", "test", maybe = TRUE) if (self$clip == "on" && !isFALSE(clip_support)) { @@ -494,8 +518,8 @@ CoordRadial <- ggproto("CoordRadial", Coord, if (self$theta == "y") { # Need to use single brackets for labels to avoid deleting an element by # assigning NULL - labels$y['primary'] <- list(titles[[1]] %|W|% labels$y$primary) - labels$x['primary'] <- list(titles[[2]] %|W|% labels$x$primary) + labels$y['primary'] <- list(titles[[1]] %|W|% labels$y$primary) + labels$x['primary'] <- list(titles[[2]] %|W|% labels$x$primary) labels$x['secondary'] <- list(titles[[3]] %|W|% labels$x$secondary) if (any(in_arc(c(0, 1) * pi, panel_params$arc))) { labels <- list(x = labels$y, y = labels$x) @@ -503,8 +527,8 @@ CoordRadial <- ggproto("CoordRadial", Coord, labels <- list(x = rev(labels$x), y = rev(labels$y)) } } else { - labels$x['primary'] <- list(titles[[1]] %|W|% labels$x$primary) - labels$y['primary'] <- list(titles[[2]] %|W|% labels$y$primary) + labels$x['primary'] <- list(titles[[1]] %|W|% labels$x$primary) + labels$y['primary'] <- list(titles[[2]] %|W|% labels$y$primary) labels$y['secondary'] <- list(titles[[3]] %|W|% labels$y$secondary) if (!any(in_arc(c(0, 1) * pi, panel_params$arc))) { @@ -515,8 +539,9 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, modify_scales = function(self, scales_x, scales_y) { - if (self$theta != "y") + if (self$theta != "y") { return() + } lapply(scales_x, scale_flip_position) lapply(scales_y, scale_flip_position) @@ -526,27 +551,36 @@ CoordRadial <- ggproto("CoordRadial", Coord, params <- ggproto_parent(Coord, self)$setup_params(data) if (isFALSE(self$r_axis_inside)) { place <- in_arc(c(0, 0.5, 1, 1.5) * pi, self$arc) - params$r_axis <- if (any(place[c(1, 3)])) "left" else "bottom" + params$r_axis <- if (any(place[c(1, 3)])) "left" else "bottom" params$fake_arc <- switch( which(place[c(1, 3, 2, 4)])[1], - c(0, 2), c(1, 3), c(0.5, 2.5), c(1.5, 3.5) - ) * pi + c(0, 2), + c(1, 3), + c(0.5, 2.5), + c(1.5, 3.5) + ) * + pi } params } ) -view_scales_polar <- function(scale, theta = "x", coord_limits = NULL, - expand = TRUE) { - +view_scales_polar <- function( + scale, + theta = "x", + coord_limits = NULL, + expand = TRUE +) { aesthetic <- scale$aesthetics[1] - is_theta <- theta == aesthetic + is_theta <- theta == aesthetic name <- if (is_theta) "theta" else "r" expansion <- default_expansion(scale, expand = expand) limits <- scale$get_limits() continuous_range <- expand_limits_scale( - scale, expansion, limits, + scale, + expansion, + limits, coord_limits ) @@ -577,9 +611,11 @@ view_scales_polar <- function(scale, theta = "x", coord_limits = NULL, #' @noRd #' @examples #' polar_bbox(c(0, 1) * pi) -polar_bbox <- function(arc, margin = c(0.05, 0.05, 0.05, 0.05), - inner_radius = c(0, 0.4)) { - +polar_bbox <- function( + arc, + margin = c(0.05, 0.05, 0.05, 0.05), + inner_radius = c(0, 0.4) +) { # Early exit if we have full circle or more if (abs(diff(arc)) >= 2 * pi) { return(list(x = c(0, 1), y = c(0, 1))) @@ -607,11 +643,14 @@ polar_bbox <- function(arc, margin = c(0.05, 0.05, 0.05, 0.05), bounds <- ifelse( in_sector, c(1, 1, 0, 0), - c(max(ymax, margin[1]), max(xmax, margin[2]), - min(ymax, margin[3]), min(xmax, margin[4])) + c( + max(ymax, margin[1]), + max(xmax, margin[2]), + min(ymax, margin[3]), + min(xmax, margin[4]) + ) ) - list(x = c(bounds[4], bounds[2]), - y = c(bounds[3], bounds[1])) + list(x = c(bounds[4], bounds[2]), y = c(bounds[3], bounds[1])) } # For any `theta` in [0, 2 * pi), test if theta is inside the span @@ -636,7 +675,6 @@ deg2rad <- function(deg) deg * pi / 180 # Function to rotate a radius axis through viewport rotate_r_axis <- function(axis, angle, bbox, position = "left") { - if (is_zero(axis)) { return(axis) } @@ -665,7 +703,7 @@ flip_data_text_angle <- function(data) { return(data) } angle <- (data$angle - rad2deg(data$theta)) %% 360 - flip <- angle > 90 & angle < 270 + flip <- angle > 90 & angle < 270 angle[flip] <- angle[flip] + 180 data$angle <- angle if ("hjust" %in% names(data)) { @@ -678,8 +716,12 @@ flip_data_text_angle <- function(data) { } -theta_grid <- function(theta, element, inner_radius = c(0, 0.4), - bbox = list(x = c(0, 1), y = c(0, 1))) { +theta_grid <- function( + theta, + element, + inner_radius = c(0, 0.4), + bbox = list(x = c(0, 1), y = c(0, 1)) +) { n <- length(theta) if (n < 1) { return(NULL) diff --git a/R/coord-sf.R b/R/coord-sf.R index 51e0bfe17c..f60d5369af 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -2,7 +2,9 @@ #' @rdname ggsf #' @usage NULL #' @format NULL -CoordSf <- ggproto("CoordSf", CoordCartesian, +CoordSf <- ggproto( + "CoordSf", + CoordCartesian, # CoordSf needs to keep track of some parameters # internally as the plot is built. These are stored @@ -37,12 +39,14 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, for (layer_data in data) { if (is_sf(layer_data)) { geometry <- sf::st_geometry(layer_data) - } else + } else { next + } crs <- sf::st_crs(geometry) - if (is.na(crs)) + if (is.na(crs)) { next + } return(crs) } @@ -52,16 +56,21 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # Transform all layers to common CRS (if provided) setup_data = function(data, params) { - if (is.null(params$crs)) + if (is.null(params$crs)) { return(data) + } lapply(data, function(layer_data) { - if (! is_sf(layer_data)) { + if (!is_sf(layer_data)) { return(layer_data) } idx <- vapply(layer_data, inherits, what = "sfc", FUN.VALUE = logical(1L)) - layer_data[idx] <- lapply(layer_data[idx], sf::st_transform, crs = params$crs) + layer_data[idx] <- lapply( + layer_data[idx], + sf::st_transform, + crs = params$crs + ) layer_data }) }, @@ -91,9 +100,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, y_range <- switch(reverse, xy = , y = rev, identity)(panel_params$y_range) # normalize geometry data, it should already be in the correct crs here - data[[ geom_column(data) ]] <- sf_rescale01( - data[[ geom_column(data) ]], - x_range, y_range + data[[geom_column(data)]] <- sf_rescale01( + data[[geom_column(data)]], + x_range, + y_range ) # transform and normalize regular position data @@ -106,10 +116,15 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, transform_position(data, squish_infinite, squish_infinite) }, - # internal function used by setup_panel_params, # overrides the graticule labels based on scale settings if necessary - fixup_graticule_labels = function(self, graticule, scale_x, scale_y, params = list()) { + fixup_graticule_labels = function( + self, + graticule, + scale_x, + scale_y, + params = list() + ) { needs_parsing <- rep(FALSE, nrow(graticule)) needs_autoparsing <- rep(FALSE, nrow(graticule)) @@ -128,16 +143,18 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # all labels need to be temporarily stored as character vectors, # but expressions need to be parsed afterwards - needs_parsing[graticule$type == "E"] <- !(is.character(x_labels) || is.factor(x_labels)) + needs_parsing[graticule$type == "E"] <- !(is.character(x_labels) || + is.factor(x_labels)) x_labels <- as.character(x_labels) } if (length(x_labels) != length(x_breaks)) { - cli::cli_abort("{.arg breaks} and {.arg labels} along {.code x} direction have different lengths.") + cli::cli_abort( + "{.arg breaks} and {.arg labels} along {.code x} direction have different lengths." + ) } graticule$degree_label[graticule$type == "E"] <- x_labels - y_breaks <- graticule$degree[graticule$type == "N"] if (is.null(scale_y$labels)) { y_labels <- rep(NA, length(y_breaks)) @@ -153,12 +170,15 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # all labels need to be temporarily stored as character vectors, # but expressions need to be parsed afterwards - needs_parsing[graticule$type == "N"] <- !(is.character(y_labels) || is.factor(y_labels)) + needs_parsing[graticule$type == "N"] <- !(is.character(y_labels) || + is.factor(y_labels)) y_labels <- as.character(y_labels) } if (length(y_labels) != length(y_breaks)) { - cli::cli_abort("{.arg breaks} and {.arg labels} along {.code y} direction have different lengths.") + cli::cli_abort( + "{.arg breaks} and {.arg labels} along {.code y} direction have different lengths." + ) } graticule$degree_label[graticule$type == "N"] <- y_labels @@ -195,20 +215,36 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # box scales_bbox <- calc_limits_bbox( self$lims_method, - scale_xlim, scale_ylim, - params$crs, params$default_crs + scale_xlim, + scale_ylim, + params$crs, + params$default_crs ) # merge coord bbox into scale limits if scale limits not explicitly set - if (is.null(self$limits$x) && is.null(self$limits$y) && - is.null(scale_x$limits) && is.null(scale_y$limits)) { + if ( + is.null(self$limits$x) && + is.null(self$limits$y) && + is.null(scale_x$limits) && + is.null(scale_y$limits) + ) { coord_bbox <- self$params$bbox - scales_xrange <- range(scales_bbox$x, coord_bbox$xmin, coord_bbox$xmax, na.rm = TRUE) - scales_yrange <- range(scales_bbox$y, coord_bbox$ymin, coord_bbox$ymax, na.rm = TRUE) + scales_xrange <- range( + scales_bbox$x, + coord_bbox$xmin, + coord_bbox$xmax, + na.rm = TRUE + ) + scales_yrange <- range( + scales_bbox$y, + coord_bbox$ymin, + coord_bbox$ymax, + na.rm = TRUE + ) } else if (any(!is.finite(scales_bbox$x) | !is.finite(scales_bbox$y))) { if (self$lims_method != "geometry_bbox") { cli::cli_warn(c( - "Projection of {.field x} or {.field y} limits failed in {.fn coord_sf}.", + "Projection of {.field x} or {.field y} limits failed in {.fn coord_sf}.", "i" = "Consider setting {.code lims_method = {.val geometry_bbox}} or {.code default_crs = NULL}." )) } @@ -224,8 +260,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, x_range <- expand_limits_continuous(scales_xrange, expansion_x) y_range <- expand_limits_continuous(scales_yrange, expansion_y) bbox <- c( - x_range[1], y_range[1], - x_range[2], y_range[2] + x_range[1], + y_range[1], + x_range[2], + y_range[2] ) breaks <- sf_breaks(scale_x, scale_y, bbox, params$crs) @@ -248,7 +286,12 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, } # override graticule labels provided by sf::st_graticule() if necessary - graticule <- self$fixup_graticule_labels(graticule, scale_x, scale_y, params) + graticule <- self$fixup_graticule_labels( + graticule, + scale_x, + scale_y, + params + ) # Convert graticule to viewscales for axis guides viewscales <- Map( @@ -282,7 +325,8 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # CRS to prevent a double transformation. panel_params$guides <- ggproto_parent(Coord, self)$train_panel_guides( vec_assign(panel_params, "default_crs", panel_params["crs"]), - layers, params + layers, + params )$guides panel_params }, @@ -351,7 +395,11 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, ) grobs <- c( list(element_render(theme, "panel.background")), - lapply(sf::st_geometry(panel_params$graticule), sf::st_as_grob, gp = line_gp) + lapply( + sf::st_geometry(panel_params$graticule), + sf::st_as_grob, + gp = line_gp + ) ) } ggname("grill", inject(grobTree(!!!grobs))) @@ -389,19 +437,31 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, #' } #' @keywords internal #' @export -sf_transform_xy <- function(data, target_crs, source_crs, authority_compliant = FALSE) { - if (identical(target_crs, source_crs) || - is.null(target_crs) || is.null(source_crs) || is.null(data) || - is.na(target_crs) || is.na(source_crs) || - !all(c("x", "y") %in% names(data))) { +sf_transform_xy <- function( + data, + target_crs, + source_crs, + authority_compliant = FALSE +) { + if ( + identical(target_crs, source_crs) || + is.null(target_crs) || + is.null(source_crs) || + is.null(data) || + is.na(target_crs) || + is.na(source_crs) || + !all(c("x", "y") %in% names(data)) + ) { return(data) } sf_data <- cbind(data$x, data$y) out <- sf::sf_project( - sf::st_crs(source_crs), sf::st_crs(target_crs), + sf::st_crs(source_crs), + sf::st_crs(target_crs), sf_data, - keep = TRUE, warn = FALSE, + keep = TRUE, + warn = FALSE, authority_compliant = authority_compliant ) out <- ifelse(is.finite(out), out, NA) # replace any infinites with NA @@ -441,7 +501,7 @@ sf_rescale01 <- function(x, x_range, y_range) { calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) { if (!all(is.finite(c(xlim, ylim))) && method != "geometry_bbox") { cli::cli_abort(c( - "Scale limits cannot be mapped onto spatial coordinates in {.fn coord_sf}.", + "Scale limits cannot be mapped onto spatial coordinates in {.fn coord_sf}.", "i" = "Consider setting {.code lims_method = \"geometry_bbox\"} or {.code default_crs = NULL}." )) } @@ -453,12 +513,16 @@ calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) { # better cover the respective area under non-linear transformation box = list( x = c( - rep(xlim[1], 20), seq(xlim[1], xlim[2], length.out = 20), - rep(xlim[2], 20), seq(xlim[2], xlim[1], length.out = 20) + rep(xlim[1], 20), + seq(xlim[1], xlim[2], length.out = 20), + rep(xlim[2], 20), + seq(xlim[2], xlim[1], length.out = 20) ), y = c( - seq(ylim[1], ylim[2], length.out = 20), rep(ylim[2], 20), - seq(ylim[2], ylim[1], length.out = 20), rep(ylim[1], 20) + seq(ylim[1], ylim[2], length.out = 20), + rep(ylim[2], 20), + seq(ylim[2], ylim[1], length.out = 20), + rep(ylim[1], 20) ) ), # For method "geometry_bbox" we ignore all limits info provided here @@ -476,7 +540,7 @@ calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) { # rotated in projected space # # Method "cross" is also the default - cross =, + cross = , list( x = c(rep(mean(xlim), 20), seq(xlim[1], xlim[2], length.out = 20)), y = c(seq(ylim[1], ylim[2], length.out = 20), rep(mean(ylim), 20)) @@ -552,14 +616,21 @@ calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) { #' @inheritParams coord_cartesian #' @export #' @rdname ggsf -coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, - crs = NULL, default_crs = NULL, - datum = sf::st_crs(4326), - label_graticule = waiver(), - label_axes = waiver(), lims_method = "cross", - ndiscr = 100, default = FALSE, clip = "on", - reverse = "none") { - +coord_sf <- function( + xlim = NULL, + ylim = NULL, + expand = TRUE, + crs = NULL, + default_crs = NULL, + datum = sf::st_crs(4326), + label_graticule = waiver(), + label_axes = waiver(), + lims_method = "cross", + ndiscr = 100, + default = FALSE, + clip = "on", + reverse = "none" +) { if (is_waiver(label_graticule) && is_waiver(label_axes)) { # if both `label_graticule` and `label_axes` are set to waive then we # use the default of labels on the left and at the bottom @@ -583,13 +654,18 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, if (is.null(default_crs) && is_missing(lims_method)) { lims_method <- "orthogonal" } else { - lims_method <- arg_match0(lims_method, c("cross", "box", "orthogonal", "geometry_bbox")) + lims_method <- arg_match0( + lims_method, + c("cross", "box", "orthogonal", "geometry_bbox") + ) } check_coord_limits(xlim) check_coord_limits(ylim) - ggproto(NULL, CoordSf, + ggproto( + NULL, + CoordSf, limits = list(x = xlim, y = ylim), lims_method = lims_method, datum = datum, @@ -621,14 +697,12 @@ parse_axes_labeling <- function(x, call = caller_env()) { # 2. It discards non-finite breaks because they are invalid input to the # graticule. This may cause atomic `labels` to be out-of-sync. sf_breaks <- function(scale_x, scale_y, bbox, crs) { - has_x <- !is.null(scale_x$breaks) || !is.null(scale_x$n.breaks) has_y <- !is.null(scale_y$breaks) || !is.null(scale_y$n.breaks) x_breaks <- if (has_x) waiver() else NULL y_breaks <- if (has_y) waiver() else NULL - if (has_x || has_y) { if (!is.null(crs)) { # Atomic breaks input are assumed to be in long/lat coordinates. @@ -682,8 +756,14 @@ sf_breaks <- function(scale_x, scale_y, bbox, crs) { #' @return A `ViewScale` object. #' @noRd #' @keywords internal -view_scales_from_graticule <- function(graticule, scale, aesthetic, - label, label_graticule, bbox) { +view_scales_from_graticule <- function( + graticule, + scale, + aesthetic, + label, + label_graticule, + bbox +) { if (empty(graticule)) { return(ggproto(NULL, ViewScale)) } @@ -693,28 +773,28 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, # left/right doesn't necessarily mean to label the parallels. position <- switch( arg_match0(aesthetic, c("x", "x.sec", "y", "y.sec")), - "x" = "bottom", + "x" = "bottom", "x.sec" = "top", - "y" = "left", + "y" = "left", "y.sec" = "right" ) axis <- gsub("\\.sec$", "", aesthetic) if (axis == "x") { - orth <- "y" - thres <- bbox[c(2, 4)] # To determine graticule is close to axis + orth <- "y" + thres <- bbox[c(2, 4)] # To determine graticule is close to axis limits <- bbox[c(1, 3)] # To use as scale limits } else { - orth <- "x" - thres <- bbox[c(1, 3)] + orth <- "x" + thres <- bbox[c(1, 3)] limits <- bbox[c(2, 4)] } # Determine what columns in the graticule contain the starts and ends of the # axis direction and the orthogonal direction. axis_start <- paste0(axis, "_start") - axis_end <- paste0(axis, "_end") + axis_end <- paste0(axis, "_end") orth_start <- paste0(orth, "_start") - orth_end <- paste0(orth, "_end") + orth_end <- paste0(orth, "_end") # Find the start and endpoints in the graticule that are in close proximity # to the axis position to generate 'accepted' starts and ends. Close proximity @@ -722,18 +802,18 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, if (position %in% c("top", "right")) { thres <- thres[1] + 0.999 * diff(thres) accept_start <- graticule[[orth_start]] > thres - accept_end <- graticule[[orth_end]] > thres + accept_end <- graticule[[orth_end]] > thres } else { thres <- thres[1] + 0.001 * diff(thres) accept_start <- graticule[[orth_start]] < thres - accept_end <- graticule[[orth_end]] < thres + accept_end <- graticule[[orth_end]] < thres } if (!any(accept_start | accept_end)) { eps <- sqrt(.Machine$double.xmin) subtract <- switch(position, top = , bottom = 90, 0) straight <- abs(graticule$angle_start - subtract) < eps & - abs(graticule$angle_end - subtract) < eps + abs(graticule$angle_end - subtract) < eps accept_start <- straight } @@ -742,7 +822,7 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, type <- graticule$type idx_start <- idx_end <- integer(0) idx_start <- c(idx_start, which(type == label & accept_start)) - idx_end <- c(idx_end, which(type == label & accept_end)) + idx_end <- c(idx_end, which(type == label & accept_end)) # Parsing the information of the `label_graticule` argument. Because # geometry can be rotated, not all meridians are guaranteed to intersect the @@ -752,25 +832,25 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, idx_start <- c(idx_start, which(type == "E" & accept_start)) } if ("N" %in% label_graticule) { - idx_end <- c(idx_end, which(type == "E" & accept_end)) + idx_end <- c(idx_end, which(type == "E" & accept_end)) } if ("W" %in% label_graticule) { idx_start <- c(idx_start, which(type == "N" & accept_start)) } if ("E" %in% label_graticule) { - idx_end <- c(idx_end, which(type == "N" & accept_end)) + idx_end <- c(idx_end, which(type == "N" & accept_end)) } # Combine start and end positions for tick marks and labels tick_start <- vec_slice(graticule, unique0(idx_start)) - tick_end <- vec_slice(graticule, unique0(idx_end)) - positions <- c(field(tick_start, axis_start), field(tick_end, axis_end)) - labels <- c(tick_start$degree_label, tick_end$degree_label) + tick_end <- vec_slice(graticule, unique0(idx_end)) + positions <- c(field(tick_start, axis_start), field(tick_end, axis_end)) + labels <- c(tick_start$degree_label, tick_end$degree_label) # The positions/labels need to be ordered for axis dodging - ord <- order(positions) + ord <- order(positions) positions <- positions[ord] - labels <- labels[ord] + labels <- labels[ord] # Find out if the scale has defined guides if (scale$position != position) { @@ -790,7 +870,8 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, } ggproto( - NULL, ViewScale, + NULL, + ViewScale, scale = scale, guide = guide, position = position, diff --git a/R/coord-transform.R b/R/coord-transform.R index 89922b09c6..60e1729245 100644 --- a/R/coord-transform.R +++ b/R/coord-transform.R @@ -80,9 +80,17 @@ #' plot + coord_transform(x = "log10") #' plot + coord_transform(x = "sqrt") #' } -coord_transform <- function(x = "identity", y = "identity", xlim = NULL, ylim = NULL, - limx = deprecated(), limy = deprecated(), clip = "on", - expand = TRUE, reverse = "none") { +coord_transform <- function( + x = "identity", + y = "identity", + xlim = NULL, + ylim = NULL, + limx = deprecated(), + limy = deprecated(), + clip = "on", + expand = TRUE, + reverse = "none" +) { if (lifecycle::is_present(limx)) { deprecate_warn0("3.3.0", "coord_transform(limx)", "coord_transform(xlim)") xlim <- limx @@ -96,11 +104,16 @@ coord_transform <- function(x = "identity", y = "identity", xlim = NULL, ylim = check_coord_limits(ylim) # resolve transformers - if (is.character(x)) x <- as.transform(x) - if (is.character(y)) y <- as.transform(y) + if (is.character(x)) { + x <- as.transform(x) + } + if (is.character(y)) { + y <- as.transform(y) + } ggproto( - NULL, CoordTransform, + NULL, + CoordTransform, trans = list(x = x, y = y), limits = list(x = xlim, y = ylim), expand = expand, @@ -125,7 +138,8 @@ coord_trans <- function(...) { #' @usage NULL #' @export CoordTransform <- ggproto( - "CoordTransform", Coord, + "CoordTransform", + Coord, is_free = function() { TRUE @@ -133,7 +147,8 @@ CoordTransform <- ggproto( distance = function(self, x, y, panel_params) { max_dist <- dist_euclidean(panel_params$x.range, panel_params$y.range) - dist_euclidean(self$trans$x$transform(x), self$trans$y$transform(y)) / max_dist + dist_euclidean(self$trans$x$transform(x), self$trans$y$transform(y)) / + max_dist }, backtransform_range = function(self, panel_params) { @@ -177,8 +192,18 @@ CoordTransform <- ggproto( setup_panel_params = function(self, scale_x, scale_y, params = list()) { c( - view_scales_from_scale_with_coord_trans(scale_x, self$limits$x, self$trans$x, params$expand[c(4, 2)]), - view_scales_from_scale_with_coord_trans(scale_y, self$limits$y, self$trans$y, params$expand[c(3, 1)]), + view_scales_from_scale_with_coord_trans( + scale_x, + self$limits$x, + self$trans$x, + params$expand[c(4, 2)] + ), + view_scales_from_scale_with_coord_trans( + scale_y, + self$limits$y, + self$trans$y, + params$expand[c(3, 1)] + ), reverse = self$reverse %||% "none" ) }, @@ -189,15 +214,31 @@ CoordTransform <- ggproto( render_axis_h = function(panel_params, theme) { list( - top = panel_guides_grob(panel_params$guides, position = "top", theme = theme), - bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme) + top = panel_guides_grob( + panel_params$guides, + position = "top", + theme = theme + ), + bottom = panel_guides_grob( + panel_params$guides, + position = "bottom", + theme = theme + ) ) }, render_axis_v = function(panel_params, theme) { list( - left = panel_guides_grob(panel_params$guides, position = "left", theme = theme), - right = panel_guides_grob(panel_params$guides, position = "right", theme = theme) + left = panel_guides_grob( + panel_params$guides, + position = "left", + theme = theme + ), + right = panel_guides_grob( + panel_params$guides, + position = "right", + theme = theme + ) ) } ) @@ -210,13 +251,19 @@ CoordTransform <- ggproto( CoordTrans <- ggproto("CoordTrans", CoordTransform) transform_value <- function(trans, value, range) { - if (is.null(value)) + if (is.null(value)) { return(value) + } rescale(trans$transform(value), 0:1, range) } # TODO: can we merge this with view_scales_from_scale()? -view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, expand = TRUE) { +view_scales_from_scale_with_coord_trans <- function( + scale, + coord_limits, + trans, + expand = TRUE +) { expansion <- default_expansion(scale, expand = expand) transformation <- scale$get_transformation() %||% transform_identity() coord_limits <- coord_limits %||% transformation$inverse(c(NA, NA)) @@ -251,14 +298,26 @@ view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, # major and minor values in coordinate data out$major_source <- transform_value(trans, out$major_source, out$range) out$minor_source <- transform_value(trans, out$minor_source, out$range) - out$sec.major_source <- transform_value(trans, out$sec.major_source, out$range) - out$sec.minor_source <- transform_value(trans, out$sec.minor_source, out$range) + out$sec.major_source <- transform_value( + trans, + out$sec.major_source, + out$range + ) + out$sec.minor_source <- transform_value( + trans, + out$sec.minor_source, + out$range + ) out <- list( # Note that a ViewScale requires a limit and a range that are before the # Coord's transformation, so we pass `continuous_range`, not `continuous_range_coord`. view_scale_primary(scale, scale_limits, continuous_ranges$continuous_range), - sec = view_scale_secondary(scale, scale_limits, continuous_ranges$continuous_range), + sec = view_scale_secondary( + scale, + scale_limits, + continuous_ranges$continuous_range + ), range = out$range, labels = out$labels, major = out$major_source, @@ -279,9 +338,16 @@ view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, #' @param new_values A vector of post-transformation values. #' @param axis Which axis the values originate from (e.g. x, y). #' @noRd -warn_new_infinites <- function(old_values, new_values, axis, call = caller_env()) { +warn_new_infinites <- function( + old_values, + new_values, + axis, + call = caller_env() +) { if (any(is.finite(old_values) & !is.finite(new_values))) { - cli::cli_warn("Transformation introduced infinite values in {axis}-axis", call = call) + cli::cli_warn( + "Transformation introduced infinite values in {axis}-axis", + call = call + ) } } - diff --git a/R/facet-.R b/R/facet-.R index e4a010d612..ce46b6daf0 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -63,7 +63,9 @@ NULL #' @examples #' # Please see extension vignette #' NULL -Facet <- ggproto("Facet", NULL, +Facet <- ggproto( + "Facet", + NULL, # Fields ------------------------------------------------------------------ @@ -225,10 +227,14 @@ Facet <- ggproto("Facet", NULL, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { scales <- list() if (!is.null(x_scale)) { - scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) + scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) { + x_scale$clone() + }) } if (!is.null(y_scale)) { - scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) y_scale$clone()) + scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) { + y_scale$clone() + }) } scales }, @@ -389,8 +395,19 @@ Facet <- ggproto("Facet", NULL, #' #' A list of grobs, one for each level of the `PANEL` layout variable. Grob #' can be `zeroGrob()` to draw nothing. - draw_panel_content = function(self, panels, layout, x_scales, y_scales, - ranges, coord, data, theme, params, ...) { + draw_panel_content = function( + self, + panels, + layout, + x_scales, + y_scales, + ranges, + coord, + data, + theme, + params, + ... + ) { facet_bg <- self$draw_back( data, layout, @@ -498,10 +515,19 @@ Facet <- ggproto("Facet", NULL, #' **Value** #' #' A [`gtable`][gtable::gtable()] object. - draw_panels = function(self, panels, layout, x_scales = NULL, y_scales = NULL, - ranges, coord, data = NULL, theme, params) { - - free <- params$free %||% list(x = FALSE, y = FALSE) + draw_panels = function( + self, + panels, + layout, + x_scales = NULL, + y_scales = NULL, + ranges, + coord, + data = NULL, + theme, + params + ) { + free <- params$free %||% list(x = FALSE, y = FALSE) space <- params$space_free %||% list(x = FALSE, y = FALSE) aspect_ratio <- theme$aspect.ratio @@ -513,8 +539,10 @@ Facet <- ggproto("Facet", NULL, if (space$x && space$y) { aspect_ratio <- aspect_ratio %||% coord$ratio } else if (free$x || free$y) { - msg <- paste0("{.fn {snake_class(self)}} can't use free scales with ", - "{.fn {snake_class(coord)}}") + msg <- paste0( + "{.fn {snake_class(self)}} can't use free scales with ", + "{.fn {snake_class(coord)}}" + ) if (!is.null(coord$ratio)) { msg <- paste0(msg, " with a fixed {.arg ratio} argument") } @@ -523,7 +551,11 @@ Facet <- ggproto("Facet", NULL, } table <- self$init_gtable( - panels, layout, theme, ranges, params, + panels, + layout, + theme, + ranges, + params, aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]]) ) @@ -559,22 +591,27 @@ Facet <- ggproto("Facet", NULL, #' #' A [`gtable`][gtable::gtable()] object containing panel grobs prefixed with #' `"panel"`. - init_gtable = function(panels, layout, theme, ranges, params, - aspect_ratio = NULL) { - + init_gtable = function( + panels, + layout, + theme, + ranges, + params, + aspect_ratio = NULL + ) { # Initialise matrix of panels - dim <- c(max(layout$ROW), max(layout$COL)) + dim <- c(max(layout$ROW), max(layout$COL)) table <- matrix(list(zeroGrob()), dim[1], dim[2]) table[cbind(layout$ROW, layout$COL)] <- panels # Set initial sizes - widths <- unit(rep(1, dim[2]), "null") + widths <- unit(rep(1, dim[2]), "null") heights <- unit(rep(1 * abs(aspect_ratio %||% 1), dim[1]), "null") # When space are free, let panel parameter limits determine size of panel space <- params$space_free %||% list(x = FALSE, y = FALSE) if (space$x) { - idx <- layout$PANEL[layout$ROW == 1] + idx <- layout$PANEL[layout$ROW == 1] widths <- vapply(idx, function(i) diff(ranges[[i]]$x.range), numeric(1)) widths <- unit(widths, "null") } @@ -587,10 +624,13 @@ Facet <- ggproto("Facet", NULL, # Build gtable table <- gtable_matrix( - "layout", table, - widths = widths, heights = heights, + "layout", + table, + widths = widths, + heights = heights, respect = !is.null(aspect_ratio), - clip = "off", z = matrix(1, dim[1], dim[2]) + clip = "off", + z = matrix(1, dim[1], dim[2]) ) # Set panel names @@ -604,7 +644,8 @@ Facet <- ggproto("Facet", NULL, # Add spacing between panels spacing <- lapply( c(x = "panel.spacing.x", y = "panel.spacing.y"), - calc_element, theme = theme + calc_element, + theme = theme ) table <- gtable_add_col_space(table, spacing$x) @@ -723,8 +764,7 @@ Facet <- ggproto("Facet", NULL, #' The `table` object, optionally with different `widths` and `heights` #' properties. set_panel_size = function(table, theme) { - - new_widths <- calc_element("panel.widths", theme) + new_widths <- calc_element("panel.widths", theme) new_heights <- calc_element("panel.heights", theme) if (is.null(new_widths) && is.null(new_heights)) { @@ -748,7 +788,7 @@ Facet <- ggproto("Facet", NULL, extra <- setdiff(seq(min(cols$l), max(cols$r)), union(cols$l, cols$r)) extra <- unit(sum(width_cm(table$widths[extra])), "cm") # Distribute width proportionally - relative <- as.numeric(table$widths[cols$l]) # assumed to be simple units + relative <- as.numeric(table$widths[cols$l]) # assumed to be simple units new_widths <- (new_widths - extra) * (relative / sum(relative)) } if (!is.null(new_widths)) { @@ -760,7 +800,7 @@ Facet <- ggproto("Facet", NULL, extra <- setdiff(seq(min(rows$t), max(rows$t)), union(rows$t, rows$b)) extra <- unit(sum(height_cm(table$heights[extra])), "cm") # Distribute height proportionally - relative <- as.numeric(table$heights[rows$t]) # assumed to be simple units + relative <- as.numeric(table$heights[rows$t]) # assumed to be simple units new_heights <- (new_heights - extra) * (relative / sum(relative)) } if (!is.null(new_heights)) { @@ -815,30 +855,69 @@ Facet <- ggproto("Facet", NULL, #' **Value** #' #' A [`gtable`][gtable::gtable()] object. - draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { - panel_dim <- find_panel(panels) + draw_labels = function( + panels, + layout, + x_scales, + y_scales, + ranges, + coord, + data, + theme, + labels, + params + ) { + panel_dim <- find_panel(panels) xlab_height_top <- grobHeight(labels$x[[1]]) panels <- gtable_add_rows(panels, xlab_height_top, pos = 0) - panels <- gtable_add_grob(panels, labels$x[[1]], name = "xlab-t", - l = panel_dim$l, r = panel_dim$r, t = 1, clip = "off") + panels <- gtable_add_grob( + panels, + labels$x[[1]], + name = "xlab-t", + l = panel_dim$l, + r = panel_dim$r, + t = 1, + clip = "off" + ) xlab_height_bottom <- grobHeight(labels$x[[2]]) panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1) - panels <- gtable_add_grob(panels, labels$x[[2]], name = "xlab-b", - l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off") + panels <- gtable_add_grob( + panels, + labels$x[[2]], + name = "xlab-b", + l = panel_dim$l, + r = panel_dim$r, + t = -1, + clip = "off" + ) - panel_dim <- find_panel(panels) + panel_dim <- find_panel(panels) ylab_width_left <- grobWidth(labels$y[[1]]) panels <- gtable_add_cols(panels, ylab_width_left, pos = 0) - panels <- gtable_add_grob(panels, labels$y[[1]], name = "ylab-l", - l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off") + panels <- gtable_add_grob( + panels, + labels$y[[1]], + name = "ylab-l", + l = 1, + b = panel_dim$b, + t = panel_dim$t, + clip = "off" + ) ylab_width_right <- grobWidth(labels$y[[2]]) panels <- gtable_add_cols(panels, ylab_width_right, pos = -1) - panels <- gtable_add_grob(panels, labels$y[[2]], name = "ylab-r", - l = -1, b = panel_dim$b, t = panel_dim$t, clip = "off") + panels <- gtable_add_grob( + panels, + labels$y[[2]], + name = "ylab-r", + l = -1, + b = panel_dim$b, + t = panel_dim$t, + clip = "off" + ) panels }, @@ -957,7 +1036,7 @@ is.facet <- function(x) { #' get_strip_labels(p + facet_wrap(year ~ cyl)) #' get_strip_labels(p + facet_grid(year ~ cyl)) get_strip_labels <- function(plot = get_last_plot()) { - plot <- ggplot_build(plot) + plot <- ggplot_build(plot) layout <- plot@layout$layout params <- plot@layout$facet_params plot@plot@facet$format_strip_labels(layout, params) @@ -968,16 +1047,25 @@ get_strip_labels <- function(plot = get_last_plot()) { NO_PANEL <- -1L unique_combs <- function(df) { - if (length(df) == 0) return() + if (length(df) == 0) { + return() + } unique_values <- lapply(df, ulevels) - rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = TRUE)) + rev(expand.grid( + rev(unique_values), + stringsAsFactors = FALSE, + KEEP.OUT.ATTRS = TRUE + )) } df.grid <- function(a, b) { - if (is.null(a) || nrow(a) == 0) return(b) - if (is.null(b) || nrow(b) == 0) return(a) + if (is.null(a) || nrow(a) == 0) { + return(b) + } + if (is.null(b) || nrow(b) == 0) { + return(a) + } indexes <- expand.grid( i_a = seq_len(nrow(a)), @@ -1064,14 +1152,18 @@ check_vars <- function(x) { # Flatten a list of quosures objects to a quosures object, and compact it compact_facets <- function(x) { x <- as_facets_list(x) - proxy <- vec_proxy(x) + proxy <- vec_proxy(x) is_list <- vapply(proxy, vec_is_list, logical(1)) - proxy[is_list] <- lapply(proxy[is_list], unclass) + proxy[is_list] <- lapply(proxy[is_list], unclass) proxy[!is_list] <- lapply(proxy[!is_list], list) new <- list_unchop(proxy, ptype = list(), name_spec = "{outer}_{inner}") x <- vec_restore(new, x) - null_or_missing <- vapply(x, function(x) quo_is_null(x) || quo_is_missing(x), logical(1)) + null_or_missing <- vapply( + x, + function(x) quo_is_null(x) || quo_is_missing(x), + logical(1) + ) new_quosures(x[!null_or_missing]) } @@ -1099,7 +1191,9 @@ simplify <- function(x) { if (length(x) < 3) { return(list(x)) } - op <- x[[1]]; a <- x[[2]]; b <- x[[3]] + op <- x[[1]] + a <- x[[2]] + b <- x[[3]] if (is_symbol(op, c("+", "*", "~"))) { c(simplify(a), simplify(b)) @@ -1111,7 +1205,8 @@ simplify <- function(x) { } as_facets <- function(x) { - is_facets <- is.list(x) && length(x) > 0 && + is_facets <- is.list(x) && + length(x) > 0 && all(vapply(x, is_quosure, logical(1))) if (is_facets) { return(x) @@ -1150,7 +1245,12 @@ f_as_facets <- function(f) { # mean you can't have background data when faceting by an expression, # but that seems like a reasonable tradeoff. eval_facets <- function(facets, data, possible_columns = NULL) { - vars <- compact(lapply(facets, eval_facet, data, possible_columns = possible_columns)) + vars <- compact(lapply( + facets, + eval_facet, + data, + possible_columns = possible_columns + )) data_frame0(!!!vars) } eval_facet <- function(facet, data, possible_columns = NULL) { @@ -1171,7 +1271,9 @@ eval_facet <- function(facet, data, possible_columns = NULL) { # but present in others raise a custom error env <- new_environment(data) missing_columns <- setdiff(possible_columns, names(data)) - undefined_error <- function(e) cli::cli_abort("", class = "ggplot2_missing_facet_var") + undefined_error <- function(e) { + cli::cli_abort("", class = "ggplot2_missing_facet_var") + } bindings <- rep_named(missing_columns, list(undefined_error)) env_bind_active(env, !!!bindings) @@ -1202,7 +1304,9 @@ check_layout <- function(x) { return() } - cli::cli_abort("Facet layout has a bad format. It must contain columns {.col PANEL}, {.col SCALE_X}, and {.col SCALE_Y}.") + cli::cli_abort( + "Facet layout has a bad format. It must contain columns {.col PANEL}, {.col SCALE_X}, and {.col SCALE_Y}." + ) } check_facet_vars <- function(..., name) { @@ -1210,10 +1314,13 @@ check_facet_vars <- function(..., name) { reserved_names <- c("PANEL", "ROW", "COL", "SCALE_X", "SCALE_Y") problems <- intersect(vars_names, reserved_names) if (length(problems) != 0) { - cli::cli_abort(c( - "{.val {problems}} {?is/are} not {?an/} allowed name{?/s} for faceting variables.", - "i" = "Change the name of your data columns to not be {.or {.str {reserved_names}}}." - ), call = call2(name)) + cli::cli_abort( + c( + "{.val {problems}} {?is/are} not {?an/} allowed name{?/s} for faceting variables.", + "i" = "Change the name of your data columns to not be {.or {.str {reserved_names}}}." + ), + call = call2(name) + ) } } @@ -1230,14 +1337,18 @@ check_facet_vars <- function(..., name) { #' @export max_height <- function(grobs, value_only = FALSE) { height <- max(unlist(lapply(grobs, height_cm))) - if (!value_only) height <- unit(height, "cm") + if (!value_only) { + height <- unit(height, "cm") + } height } #' @rdname max_height #' @export max_width <- function(grobs, value_only = FALSE) { width <- max(unlist(lapply(grobs, width_cm))) - if (!value_only) width <- unit(width, "cm") + if (!value_only) { + width <- unit(width, "cm") + } width } #' Find panels in a gtable @@ -1293,10 +1404,17 @@ panel_rows <- function(table) { #' @export combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { possible_columns <- unique0(unlist(lapply(data, names))) - if (length(vars) == 0) return(data_frame0()) + if (length(vars) == 0) { + return(data_frame0()) + } # For each layer, compute the facet values - values <- compact(lapply(data, eval_facets, facets = vars, possible_columns = possible_columns)) + values <- compact(lapply( + data, + eval_facets, + facets = vars, + possible_columns = possible_columns + )) # Form the base data.frame which contains all combinations of faceting # variables that appear in the data @@ -1305,7 +1423,9 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { missing <- lapply(values, function(x) setdiff(names(vars), names(x))) missing_vars <- paste0( c("Plot", paste0("Layer ", seq_len(length(data) - 1))), - " is missing {.var ", missing[seq_along(data)], "}" + " is missing {.var ", + missing[seq_along(data)], + "}" ) names(missing_vars) <- rep("x", length(data)) @@ -1322,7 +1442,9 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { # Systematically add on missing combinations for (value in values[!has_all]) { - if (empty(value)) next; + if (empty(value)) { + next + } old <- base[setdiff(names(base), names(value))] new <- unique0(value[intersect(names(base), names(value))]) @@ -1410,7 +1532,9 @@ censor_labels <- function(ranges, layout, labels) { return(ranges) } draw <- matrix( - TRUE, length(ranges), 4, + TRUE, + length(ranges), + 4, dimnames = list(NULL, c("top", "bottom", "left", "right")) ) @@ -1433,7 +1557,6 @@ censor_labels <- function(ranges, layout, labels) { } map_facet_data <- function(data, layout, params) { - if (empty(data)) { return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) } @@ -1458,13 +1581,16 @@ map_facet_data <- function(data, layout, params) { facet_vals <- eval_facets(vars, data, params$.possible_columns) include_margins <- !isFALSE(params$margins %||% FALSE) && - nrow(facet_vals) == nrow(data) && grid_layout + nrow(facet_vals) == nrow(data) && + grid_layout if (include_margins) { # Margins are computed on evaluated faceting values (#1864). facet_vals <- reshape_add_margins( vec_cbind(facet_vals, .index = seq_len(nrow(facet_vals))), - list(intersect(names(params$rows), names(facet_vals)), - intersect(names(params$cols), names(facet_vals))), + list( + intersect(names(params$rows), names(facet_vals)), + intersect(names(params$cols), names(facet_vals)) + ), params$margins %||% FALSE ) # Apply recycling on original data to fit margins @@ -1489,10 +1615,9 @@ map_facet_data <- function(data, layout, params) { # duplicating the data missing_facets <- setdiff(names(vars), names(facet_vals)) if (length(missing_facets) > 0) { - to_add <- unique0(layout[missing_facets]) - data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) + data_rep <- rep.int(seq_len(nrow(data)), nrow(to_add)) facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) data <- unrowname(data[data_rep, , drop = FALSE]) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 6f05fb0005..8c9d7ac642 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -137,12 +137,21 @@ NULL #' # a margin over "am". #' mg + facet_grid(vs + am ~ gear, margins = "vs") #' } -facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", - space = "fixed", shrink = TRUE, - labeller = "label_value", as.table = TRUE, - switch = NULL, drop = TRUE, margins = FALSE, - axes = "margins", axis.labels = "all", - facets = deprecated()) { +facet_grid <- function( + rows = NULL, + cols = NULL, + scales = "fixed", + space = "fixed", + shrink = TRUE, + labeller = "label_value", + as.table = TRUE, + switch = NULL, + drop = TRUE, + margins = FALSE, + axes = "margins", + axis.labels = "all", + facets = deprecated() +) { # `facets` is deprecated if (lifecycle::is_present(facets)) { lifecycle::deprecate_stop("2.2.0", "facet_grid(facets)", "facet_grid(rows)") @@ -154,13 +163,19 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", cols <- NULL } - scales <- arg_match0(scales %||% "fixed", c("fixed", "free_x", "free_y", "free")) + scales <- arg_match0( + scales %||% "fixed", + c("fixed", "free_x", "free_y", "free") + ) free <- list( x = any(scales %in% c("free_x", "free")), y = any(scales %in% c("free_y", "free")) ) - space <- arg_match0(space %||% "fixed", c("fixed", "free_x", "free_y", "free")) + space <- arg_match0( + space %||% "fixed", + c("fixed", "free_x", "free_y", "free") + ) space_free <- list( x = any(space %in% c("free_x", "free")), y = any(space %in% c("free_y", "free")) @@ -189,12 +204,23 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", # Check for deprecated labellers labeller <- validate_labeller(labeller) - ggproto(NULL, FacetGrid, + ggproto( + NULL, + FacetGrid, shrink = shrink, - params = list(rows = facets_list$rows, cols = facets_list$cols, margins = margins, - free = free, space_free = space_free, labeller = labeller, - as.table = as.table, switch = switch, drop = drop, - draw_axes = draw_axes, axis_labels = axis_labels) + params = list( + rows = facets_list$rows, + cols = facets_list$cols, + margins = margins, + free = free, + space_free = space_free, + labeller = labeller, + as.table = as.table, + switch = switch, + drop = drop, + draw_axes = draw_axes, + axis_labels = axis_labels + ) ) } @@ -217,7 +243,9 @@ grid_as_facets_list <- function(rows, cols) { # For backward-compatibility facets_list <- as_facets_list(rows) if (length(facets_list) > 2L) { - cli::cli_abort("A grid facet specification can't have more than two dimensions.") + cli::cli_abort( + "A grid facet specification can't have more than two dimensions." + ) } # Fill with empty quosures facets <- list(rows = quos(), cols = quos()) @@ -226,7 +254,12 @@ grid_as_facets_list <- function(rows, cols) { return(facets) } - check_object(cols, is_quosures, "a {.fn vars} specification", allow_null = TRUE) + check_object( + cols, + is_quosures, + "a {.fn vars} specification", + allow_null = TRUE + ) list( rows = compact_facets(rows), @@ -238,7 +271,9 @@ grid_as_facets_list <- function(rows, cols) { #' @format NULL #' @usage NULL #' @export -FacetGrid <- ggproto("FacetGrid", Facet, +FacetGrid <- ggproto( + "FacetGrid", + Facet, shrink = TRUE, compute_layout = function(self, data, params) { @@ -249,10 +284,13 @@ FacetGrid <- ggproto("FacetGrid", Facet, dups <- intersect(names(rows), names(cols)) if (length(dups) > 0) { - cli::cli_abort(c( - "Faceting variables can only appear in {.arg rows} or {.arg cols}, not both.", - "i" = "Duplicated variables: {.val {dups}}" - ), call = call2(snake_class(self))) + cli::cli_abort( + c( + "Faceting variables can only appear in {.arg rows} or {.arg cols}, not both.", + "i" = "Duplicated variables: {.val {dups}}" + ), + call = call2(snake_class(self)) + ) } base_rows <- combine_vars(data, params$plot_env, rows, drop = params$drop) @@ -274,15 +312,27 @@ FacetGrid <- ggproto("FacetGrid", Facet, } # Add margins - base <- reshape_add_margins(base, list(names(rows), names(cols)), params$margins) + base <- reshape_add_margins( + base, + list(names(rows), names(cols)), + params$margins + ) base <- unique0(base) # Create panel info dataset panel <- id(base, drop = TRUE) panel <- factor(panel, levels = seq_len(attr(panel, "n"))) - rows <- if (!length(names(rows))) rep(1L, length(panel)) else id(base[names(rows)], drop = TRUE) - cols <- if (!length(names(cols))) rep(1L, length(panel)) else id(base[names(cols)], drop = TRUE) + rows <- if (!length(names(rows))) { + rep(1L, length(panel)) + } else { + id(base[names(rows)], drop = TRUE) + } + cols <- if (!length(names(cols))) { + rep(1L, length(panel)) + } else { + id(base[names(cols)], drop = TRUE) + } panels <- data_frame0(PANEL = panel, ROW = rows, COL = cols, base) panels <- panels[order(panels$PANEL), , drop = FALSE] @@ -297,89 +347,143 @@ FacetGrid <- ggproto("FacetGrid", Facet, map_data = map_facet_data, attach_axes = function(table, layout, ranges, coord, theme, params) { - # Setup parameters - draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) - axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) + draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) + axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) dim <- c(max(layout$ROW), max(layout$COL)) if (!axis_labels$x) { - cols <- seq_len(nrow(layout)) + cols <- seq_len(nrow(layout)) x_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) } else { - cols <- which(layout$ROW == 1) + cols <- which(layout$ROW == 1) x_order <- layout$COL } if (!axis_labels$y) { - rows <- seq_len(nrow(layout)) + rows <- seq_len(nrow(layout)) y_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) } else { - rows <- which(layout$COL == 1) + rows <- which(layout$COL == 1) y_order <- layout$ROW } # Render individual axes ranges <- censor_labels(ranges, layout, axis_labels) - axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE) - mtx <- function(x, o) matrix(x[o], dim[1], dim[2], byrow = TRUE) + axes <- render_axes( + ranges[cols], + ranges[rows], + coord, + theme, + transpose = TRUE + ) + mtx <- function(x, o) matrix(x[o], dim[1], dim[2], byrow = TRUE) if (draw_axes$x) { table <- weave_axes(table, lapply(axes$x, mtx, o = x_order)) } else { - table <- seam_table(table, axes$x$top, side = "top", name = "axis-t", z = 3) - table <- seam_table(table, axes$x$bottom, side = "bottom", name = "axis-b", z = 3) + table <- seam_table( + table, + axes$x$top, + side = "top", + name = "axis-t", + z = 3 + ) + table <- seam_table( + table, + axes$x$bottom, + side = "bottom", + name = "axis-b", + z = 3 + ) } if (draw_axes$y) { table <- weave_axes(table, lapply(axes$y, mtx, o = y_order)) } else { - table <- seam_table(table, axes$y$left, side = "left", name = "axis-l", z = 3) - table <- seam_table(table, axes$y$right, side = "right", name = "axis-r", z = 3) + table <- seam_table( + table, + axes$y$left, + side = "left", + name = "axis-l", + z = 3 + ) + table <- seam_table( + table, + axes$y$right, + side = "right", + name = "axis-r", + z = 3 + ) } table }, attach_strips = function(self, table, layout, params, theme) { - strips <- self$format_strip_labels(layout, params) strips <- render_strips(strips$cols, strips$rows, theme = theme) padding <- convertUnit(calc_element("strip.switch.pad.grid", theme), "cm") switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x") - inside_x <- (calc_element("strip.placement.x", theme) %||% "inside") == "inside" - shift_x <- if (inside_x) 1 else 2 + inside_x <- (calc_element("strip.placement.x", theme) %||% "inside") == + "inside" + shift_x <- if (inside_x) 1 else 2 if (switch_x) { space <- if (!inside_x & table_has_grob(table, "axis-b")) padding table <- seam_table( - table, strips$x$bottom, side = "bottom", name = "strip-b", - shift = shift_x, z = 2, clip = "off", spacing = space + table, + strips$x$bottom, + side = "bottom", + name = "strip-b", + shift = shift_x, + z = 2, + clip = "off", + spacing = space ) } else { space <- if (!inside_x & table_has_grob(table, "axis-t")) padding table <- seam_table( - table, strips$x$top, side = "top", name = "strip-t", - shift = shift_x, z = 2, clip = "off", spacing = space + table, + strips$x$top, + side = "top", + name = "strip-t", + shift = shift_x, + z = 2, + clip = "off", + spacing = space ) } switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y") - inside_y <- (calc_element("strip.placement.y", theme) %||% "inside") == "inside" - shift_y <- if (inside_y) 1 else 2 + inside_y <- (calc_element("strip.placement.y", theme) %||% "inside") == + "inside" + shift_y <- if (inside_y) 1 else 2 if (switch_y) { space <- if (!inside_y & table_has_grob(table, "axis-l")) padding table <- seam_table( - table, strips$y$left, side = "left", name = "strip-l", - shift = shift_y, z = 2, clip = "off", spacing = space + table, + strips$y$left, + side = "left", + name = "strip-l", + shift = shift_y, + z = 2, + clip = "off", + spacing = space ) } else { space <- if (!inside_y & table_has_grob(table, "axis-r")) padding table <- seam_table( - table, strips$y$right, side = "right", name = "strip-r", - shift = shift_y, z = 2, clip = "off", spacing = space + table, + strips$y$right, + side = "right", + name = "strip-r", + shift = shift_y, + z = 2, + clip = "off", + spacing = space ) } table @@ -390,13 +494,12 @@ FacetGrid <- ggproto("FacetGrid", Facet, }, format_strip_labels = function(layout, params) { - labeller <- match.fun(params$labeller) cols <- intersect(names(layout), names(params$cols)) if (length(cols) > 0) { col_vars <- unique0(layout[cols]) - attr(col_vars, "type") <- "cols" + attr(col_vars, "type") <- "cols" attr(col_vars, "facet") <- "grid" cols <- data_frame0(!!!labeller(col_vars)) } else { @@ -406,7 +509,7 @@ FacetGrid <- ggproto("FacetGrid", Facet, rows <- intersect(names(layout), names(params$rows)) if (length(rows) > 0) { row_vars <- unique0(layout[rows]) - attr(row_vars, "type") <- "rows" + attr(row_vars, "type") <- "rows" attr(row_vars, "facet") <- "grid" rows <- data_frame0(!!!labeller(row_vars)) } else { @@ -433,8 +536,16 @@ table_has_grob <- function(table, pattern) { !all(vapply(grobs, is_zero, logical(1))) } -seam_table <- function(table, grobs = NULL, side, shift = 1, name, z = 1, - clip = "off", spacing = NULL) { +seam_table <- function( + table, + grobs = NULL, + side, + shift = 1, + name, + z = 1, + clip = "off", + spacing = NULL +) { if (is.null(grobs)) { return(table) } @@ -445,22 +556,24 @@ seam_table <- function(table, grobs = NULL, side, shift = 1, name, z = 1, row <- switch( side, bottom = max(panel_row$b) + shift - 1L, - top = min(panel_row$t) - shift, + top = min(panel_row$t) - shift, panel_row$t ) col <- switch( side, right = max(panel_col$r) + shift - 1L, - left = min(panel_col$l) - shift, + left = min(panel_col$l) - shift, panel_col$l ) if (!is.null(spacing)) { table <- switch( side, - bottom = , top = gtable_add_rows(table, spacing, row), - left = , right = gtable_add_cols(table, spacing, col) + bottom = , + top = gtable_add_rows(table, spacing, row), + left = , + right = gtable_add_cols(table, spacing, col) ) row <- row + as.numeric(side == "bottom") col <- col + as.numeric(side == "right") @@ -468,11 +581,21 @@ seam_table <- function(table, grobs = NULL, side, shift = 1, name, z = 1, table <- switch( side, - bottom = , top = gtable_add_rows(table, max_height(grobs), row), - left = , right = gtable_add_cols(table, max_width(grobs), col) + bottom = , + top = gtable_add_rows(table, max_height(grobs), row), + left = , + right = gtable_add_cols(table, max_width(grobs), col) ) name <- paste(name, seq_along(grobs), sep = "-") - row <- row + as.numeric(side %in% c("top", "bottom")) - col <- col + as.numeric(side %in% c("left", "right")) - gtable_add_grob(table, grobs, t = row, l = col, name = name, z = z, clip = clip) + row <- row + as.numeric(side %in% c("top", "bottom")) + col <- col + as.numeric(side %in% c("left", "right")) + gtable_add_grob( + table, + grobs, + t = row, + l = col, + name = name, + z = z, + clip = clip + ) } diff --git a/R/facet-null.R b/R/facet-null.R index 860e5f3b84..bedfad049a 100644 --- a/R/facet-null.R +++ b/R/facet-null.R @@ -14,16 +14,16 @@ NULL #' # don't override it with facet_grid or facet_wrap #' ggplot(mtcars, aes(mpg, wt)) + geom_point() facet_null <- function(shrink = TRUE) { - ggproto(NULL, FacetNull, - shrink = shrink - ) + ggproto(NULL, FacetNull, shrink = shrink) } #' @rdname Facet #' @format NULL #' @usage NULL #' @export -FacetNull <- ggproto("FacetNull", Facet, +FacetNull <- ggproto( + "FacetNull", + Facet, shrink = TRUE, compute_layout = function(data, params) { @@ -32,18 +32,29 @@ FacetNull <- ggproto("FacetNull", Facet, map_data = function(data, layout, params) { # Need the is_waiver check for special case where no data, but aesthetics # are mapped to vectors - if (is_waiver(data)) + if (is_waiver(data)) { return(data_frame0(PANEL = factor())) + } - if (empty(data)) + if (empty(data)) { return(data_frame0(data, PANEL = factor())) + } # Needs to be a factor to be consistent with other facet types data$PANEL <- factor(1) data }, - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { - + draw_panels = function( + panels, + layout, + x_scales, + y_scales, + ranges, + coord, + data, + theme, + params + ) { range <- ranges[[1]] # Figure out aspect ratio @@ -57,19 +68,51 @@ FacetNull <- ggproto("FacetNull", Facet, axis_h <- coord$render_axis_h(range, theme) axis_v <- coord$render_axis_v(range, theme) - all <- matrix(list( - zeroGrob(), axis_h$top, zeroGrob(), - axis_v$left, panels[[1]], axis_v$right, - zeroGrob(), axis_h$bottom, zeroGrob() - ), ncol = 3, byrow = TRUE) + all <- matrix( + list( + zeroGrob(), + axis_h$top, + zeroGrob(), + axis_v$left, + panels[[1]], + axis_v$right, + zeroGrob(), + axis_h$bottom, + zeroGrob() + ), + ncol = 3, + byrow = TRUE + ) z_matrix <- matrix(c(5, 6, 4, 7, 1, 8, 3, 9, 2), ncol = 3, byrow = TRUE) - grob_widths <- unit.c(grobWidth(axis_v$left), unit(1, "null"), grobWidth(axis_v$right)) - grob_heights <- unit.c(grobHeight(axis_h$top), unit(abs(aspect_ratio), "null"), grobHeight(axis_h$bottom)) - grob_names <- c("spacer", "axis-l", "spacer", "axis-t", "panel", "axis-b", "spacer", "axis-r", "spacer") + grob_widths <- unit.c( + grobWidth(axis_v$left), + unit(1, "null"), + grobWidth(axis_v$right) + ) + grob_heights <- unit.c( + grobHeight(axis_h$top), + unit(abs(aspect_ratio), "null"), + grobHeight(axis_h$bottom) + ) + grob_names <- c( + "spacer", + "axis-l", + "spacer", + "axis-t", + "panel", + "axis-b", + "spacer", + "axis-r", + "spacer" + ) - layout <- gtable_matrix("layout", all, - widths = grob_widths, heights = grob_heights, - respect = respect, clip = "off", + layout <- gtable_matrix( + "layout", + all, + widths = grob_widths, + heights = grob_heights, + respect = respect, + clip = "off", z = z_matrix ) layout$layout$name <- grob_names diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 51fccb37b7..30252565cf 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -128,13 +128,30 @@ NULL #' ggplot(mpg, aes(displ, hwy)) + #' geom_point() + #' facet_wrap(vars(class), dir = "tr") -facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", - space = "fixed", shrink = TRUE, labeller = "label_value", - as.table = TRUE, switch = deprecated(), drop = TRUE, - dir = "h", strip.position = 'top', axes = "margins", - axis.labels = "all") { - scales <- arg_match0(scales %||% "fixed", c("fixed", "free_x", "free_y", "free")) - dir <- arg_match0(dir, c("h", "v", "lt", "tl", "lb", "bl", "rt", "tr", "rb", "br")) +facet_wrap <- function( + facets, + nrow = NULL, + ncol = NULL, + scales = "fixed", + space = "fixed", + shrink = TRUE, + labeller = "label_value", + as.table = TRUE, + switch = deprecated(), + drop = TRUE, + dir = "h", + strip.position = 'top', + axes = "margins", + axis.labels = "all" +) { + scales <- arg_match0( + scales %||% "fixed", + c("fixed", "free_x", "free_y", "free") + ) + dir <- arg_match0( + dir, + c("h", "v", "lt", "tl", "lb", "bl", "rt", "tr", "rb", "br") + ) if (nchar(dir) == 1) { dir <- base::switch( dir, @@ -195,10 +212,15 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", if (lifecycle::is_present(switch) && !is.null(switch)) { lifecycle::deprecate_stop( - "2.2.0", "facet_wrap(switch)", "facet_wrap(strip.position)" + "2.2.0", + "facet_wrap(switch)", + "facet_wrap(strip.position)" ) } - strip.position <- arg_match0(strip.position, c("top", "bottom", "left", "right")) + strip.position <- arg_match0( + strip.position, + c("top", "bottom", "left", "right") + ) check_number_whole(ncol, allow_null = TRUE, min = 1) check_number_whole(nrow, allow_null = TRUE, min = 1) @@ -210,7 +232,9 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", nrow <- tmp } - ggproto(NULL, FacetWrap, + ggproto( + NULL, + FacetWrap, shrink = shrink, params = list( facets = facets, @@ -232,7 +256,9 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", #' @format NULL #' @usage NULL #' @export -FacetWrap <- ggproto("FacetWrap", Facet, +FacetWrap <- ggproto( + "FacetWrap", + Facet, shrink = TRUE, compute_layout = function(self, data, params) { @@ -265,14 +291,13 @@ FacetWrap <- ggproto("FacetWrap", Facet, map_data = map_facet_data, attach_axes = function(table, layout, ranges, coord, theme, params) { - # Setup parameters - draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) - axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) - free <- params$free %||% list(x = FALSE, y = FALSE) + draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) + axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) + free <- params$free %||% list(x = FALSE, y = FALSE) # Render individual axes - ranges <- censor_labels(ranges, layout, axis_labels) + ranges <- censor_labels(ranges, layout, axis_labels) original <- render_axes(ranges, ranges, coord, theme, transpose = TRUE) # Sort axes @@ -288,18 +313,18 @@ FacetWrap <- ggproto("FacetWrap", Facet, top <- bottom <- left <- right <- empty # Fill axis matrices - top[index] <- original$x$top + top[index] <- original$x$top bottom[index] <- original$x$bottom - left[index] <- original$y$left - right[index] <- original$y$right + left[index] <- original$y$left + right[index] <- original$y$right # Suppress interior axes if (!(free$x || draw_axes$x)) { - top[-1, ] <- list(zeroGrob()) + top[-1, ] <- list(zeroGrob()) bottom[-dim[1], ] <- list(zeroGrob()) } if (!(free$y || draw_axes$y)) { - left[, -1] <- list(zeroGrob()) + left[, -1] <- list(zeroGrob()) right[, -dim[2]] <- list(zeroGrob()) } @@ -318,20 +343,22 @@ FacetWrap <- ggproto("FacetWrap", Facet, ) # Figure out where axes should be added back - empty_bottom <- which( apply(empty, 2, function(x) c(diff(x) == 1, FALSE))) - empty_top <- which( apply(empty, 2, function(x) c(FALSE, diff(x) == -1))) - empty_right <- which(t(apply(empty, 1, function(x) c(diff(x) == 1, FALSE)))) - empty_left <- which(t(apply(empty, 1, function(x) c(FALSE, diff(x) == -1)))) + empty_bottom <- which(apply(empty, 2, function(x) c(diff(x) == 1, FALSE))) + empty_top <- which(apply(empty, 2, function(x) c(FALSE, diff(x) == -1))) + empty_right <- which(t(apply(empty, 1, function(x) c(diff(x) == 1, FALSE)))) + empty_left <- which(t(apply(empty, 1, function(x) c(FALSE, diff(x) == -1)))) # Keep track of potential clashes between strips and axes inside <- (theme$strip.placement %||% "inside") == "inside" - strip <- params$strip.position %||% "top" - clash <- c(top = FALSE, bottom = FALSE, left = FALSE, right = FALSE) + strip <- params$strip.position %||% "top" + clash <- c(top = FALSE, bottom = FALSE, left = FALSE, right = FALSE) # Go through every position and place back axes if (length(empty_bottom) > 0) { x_axes <- original$x$bottom[matched[empty_bottom]] - clash["bottom"] <- strip == "bottom" && !inside && !free$x && + clash["bottom"] <- strip == "bottom" && + !inside && + !free$x && !all(vapply(x_axes, is_zero, logical(1))) if (!clash["bottom"]) { bottom[empty_bottom] <- x_axes @@ -340,7 +367,9 @@ FacetWrap <- ggproto("FacetWrap", Facet, if (length(empty_top) > 0) { x_axes <- original$x$top[matched[empty_top]] - clash["top"] <- strip == "top" && !inside && !free$x && + clash["top"] <- strip == "top" && + !inside && + !free$x && !all(vapply(x_axes, is_zero, logical(1))) if (!clash["top"]) { top[empty_top] <- x_axes @@ -349,7 +378,9 @@ FacetWrap <- ggproto("FacetWrap", Facet, if (length(empty_right) > 0) { y_axes <- original$y$right[matched[empty_right]] - clash["right"] <- strip == "right" && !inside && !free$y && + clash["right"] <- strip == "right" && + !inside && + !free$y && !all(vapply(y_axes, is_zero, logical(1))) if (!clash["right"]) { right[empty_right] <- y_axes @@ -358,7 +389,9 @@ FacetWrap <- ggproto("FacetWrap", Facet, if (length(empty_left) > 0) { y_axes <- original$y$left[matched[empty_left]] - clash["left"] <- strip == "left" && !inside && !free$y && + clash["left"] <- strip == "left" && + !inside && + !free$y && !all(vapply(y_axes, is_zero, logical(1))) if (!clash["left"]) { left[empty_left] <- y_axes @@ -378,16 +411,15 @@ FacetWrap <- ggproto("FacetWrap", Facet, }, attach_strips = function(self, table, layout, params, theme) { - # Format labels strips <- self$format_strip_labels(layout, params) strips <- render_strips(strips$facets, strips$facets, theme = theme) # Set position invariant parameters - padding <- convertUnit(calc_element("strip.switch.pad.wrap", theme), "cm") + padding <- convertUnit(calc_element("strip.switch.pad.wrap", theme), "cm") position <- params$strip.position %||% "top" - pos <- substr(position, 1, 1) - prefix <- paste0("strip-", pos) + pos <- substr(position, 1, 1) + prefix <- paste0("strip-", pos) # Setup weaving table dim <- c(max(layout$ROW), max(layout$COL)) @@ -397,28 +429,28 @@ FacetWrap <- ggproto("FacetWrap", Facet, # Setup orientation dependent parameters if (position %in% c("top", "bottom")) { - inside <- "strip.placement.x" - size <- apply(mat, 1, max_height, value_only = TRUE) - weave <- weave_tables_row + inside <- "strip.placement.x" + size <- apply(mat, 1, max_height, value_only = TRUE) + weave <- weave_tables_row } else { - inside <- "strip.placement.y" - size <- apply(mat, 2, max_width, value_only = TRUE) - weave <- weave_tables_col + inside <- "strip.placement.y" + size <- apply(mat, 2, max_width, value_only = TRUE) + weave <- weave_tables_col } inside <- (calc_element(inside, theme) %||% "inside") == "inside" - shift <- switch(position, top = , left = c(-1, -2), c(0, 1)) - shift <- if (inside) shift[1] else shift[2] - size <- unit(size, "cm") + shift <- switch(position, top = , left = c(-1, -2), c(0, 1)) + shift <- if (inside) shift[1] else shift[2] + size <- unit(size, "cm") table <- weave(table, mat, shift, size, name = prefix, z = 2, clip = "off") if (!inside) { - axes <- grepl(paste0("axis-", pos), table$layout$name) + axes <- grepl(paste0("axis-", pos), table$layout$name) has_axes <- !vapply(table$grobs[axes], is_zero, logical(1)) has_axes <- split(has_axes, table$layout[[pos]][axes]) has_axes <- vapply(has_axes, sum, numeric(1)) > 0 - padding <- rep(padding, length(has_axes)) + padding <- rep(padding, length(has_axes)) padding[!has_axes] <- unit(0, "cm") table <- weave(table, , shift, padding) } @@ -426,7 +458,18 @@ FacetWrap <- ggproto("FacetWrap", Facet, table }, - draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { + draw_panels = function( + self, + panels, + layout, + x_scales, + y_scales, + ranges, + coord, + data, + theme, + params + ) { if (inherits(coord, "CoordFlip")) { # Switch the scales back layout[c("SCALE_X", "SCALE_Y")] <- layout[c("SCALE_Y", "SCALE_X")] @@ -437,9 +480,12 @@ FacetWrap <- ggproto("FacetWrap", Facet, panels <- panels[panel_order] ggproto_parent(Facet, self)$draw_panels( - panels = panels, layout = layout, - ranges = ranges, coord = coord, - theme = theme, params = params + panels = panels, + layout = layout, + ranges = ranges, + coord = coord, + theme = theme, + params = params ) }, vars = function(self) { @@ -456,7 +502,12 @@ FacetWrap <- ggproto("FacetWrap", Facet, return(NULL) } attr(labels, "facet") <- "wrap" - attr(labels, "type") <- switch(params$strip.position, left = , right = "rows", "cols") + attr(labels, "type") <- switch( + params$strip.position, + left = , + right = "rows", + "cols" + ) labeller <- match.fun(params$labeller) list(facets = data_frame0(!!!labeller(labels))) @@ -498,52 +549,94 @@ convertInd <- function(row, col, nrow) { (col - 1) * nrow + row } -weave_tables_col <- function(table, table2, col_shift, col_width, name, z = 1, clip = "off") { +weave_tables_col <- function( + table, + table2, + col_shift, + col_width, + name, + z = 1, + clip = "off" +) { panel_col <- panel_cols(table)$l panel_row <- panel_rows(table)$t for (i in rev(seq_along(panel_col))) { col_ind <- panel_col[i] + col_shift table <- gtable_add_cols(table, col_width[i], pos = col_ind) if (!missing(table2)) { - table <- gtable_add_grob(table, table2[, i], t = panel_row, l = col_ind + 1, clip = clip, name = paste0(name, "-", seq_along(panel_row), "-", i), z = z) + table <- gtable_add_grob( + table, + table2[, i], + t = panel_row, + l = col_ind + 1, + clip = clip, + name = paste0(name, "-", seq_along(panel_row), "-", i), + z = z + ) } } table } -weave_tables_row <- function(table, table2, row_shift, row_height, name, z = 1, clip = "off") { +weave_tables_row <- function( + table, + table2, + row_shift, + row_height, + name, + z = 1, + clip = "off" +) { panel_col <- panel_cols(table)$l panel_row <- panel_rows(table)$t for (i in rev(seq_along(panel_row))) { row_ind <- panel_row[i] + row_shift table <- gtable_add_rows(table, row_height[i], pos = row_ind) if (!missing(table2)) { - table <- gtable_add_grob(table, table2[i, ], t = row_ind + 1, l = panel_col, clip = clip, name = paste0(name, "-", seq_along(panel_col), "-", i), z = z) + table <- gtable_add_grob( + table, + table2[i, ], + t = row_ind + 1, + l = panel_col, + clip = clip, + name = paste0(name, "-", seq_along(panel_col), "-", i), + z = z + ) } } table } weave_axes <- function(panels, axes, empty = NULL, z = 3L) { - empty <- which(empty %||% matrix(logical(), 0, 0), arr.ind = TRUE) - sides <- match(names(axes), .trbl) + empty <- which(empty %||% matrix(logical(), 0, 0), arr.ind = TRUE) + sides <- match(names(axes), .trbl) margin <- c(1L, 2L, 1L, 2L)[sides] - shift <- c(1L, -1L, -1L, 1L)[sides] - sizes <- Map( - measure_axes, axis = axes, margin = margin, shift = shift, + shift <- c(1L, -1L, -1L, 1L)[sides] + sizes <- Map( + measure_axes, + axis = axes, + margin = margin, + shift = shift, MoreArgs = list(empty_idx = empty) ) names <- paste0("axis-", substr(names(axes), 1, 1)) shift <- c(-1L, 0L, 0L, -1L)[sides] weave <- list(weave_tables_row, weave_tables_col)[c(1, 2, 1, 2)][sides] for (i in seq_along(axes)) { - panels <- weave[[i]](panels, axes[[i]], shift[i], sizes[[i]], names[i], z = z) + panels <- weave[[i]]( + panels, + axes[[i]], + shift[i], + sizes[[i]], + names[i], + z = z + ) } panels } # Measures the size of axes while ignoring those bordering empty panels measure_axes <- function(empty_idx, axis, margin = 1L, shift = 0) { - dim <- dim(axis) + dim <- dim(axis) measure <- switch(margin, height_cm, width_cm) cm <- matrix(measure(axis), dim[1], dim[2]) @@ -570,7 +663,9 @@ wrap_layout <- function(id, dims, dir) { dir <- switch(dir, h = "lt", v = "tl") deprecate_soft0( "4.0.0", - what = I("Internal use of `dir = \"h\"` and `dir = \"v\"` in `facet_wrap()`"), + what = I( + "Internal use of `dir = \"h\"` and `dir = \"v\"` in `facet_wrap()`" + ), details = I(c( "The `dir` argument should incorporate the `as.table` argument.", paste0("Falling back to `dir = \"", dir, "\"`.") @@ -582,24 +677,32 @@ wrap_layout <- function(id, dims, dir) { ROW <- switch( dir, - lt = , rt = (id - 1L) %/% dims[2] + 1L, - tl = , tr = (id - 1L) %% dims[1] + 1L, - lb = , rb = dims[1] - (id - 1L) %/% dims[2], - bl = , br = dims[1] - (id - 1L) %% dims[1] + lt = , + rt = (id - 1L) %/% dims[2] + 1L, + tl = , + tr = (id - 1L) %% dims[1] + 1L, + lb = , + rb = dims[1] - (id - 1L) %/% dims[2], + bl = , + br = dims[1] - (id - 1L) %% dims[1] ) COL <- switch( dir, - lt = , lb = (id - 1L) %% dims[2] + 1L, - tl = , bl = (id - 1L) %/% dims[1] + 1L, - rt = , rb = dims[2] - (id - 1L) %% dims[2], - tr = , br = dims[2] - (id - 1L) %/% dims[1] + lt = , + lb = (id - 1L) %% dims[2] + 1L, + tl = , + bl = (id - 1L) %/% dims[1] + 1L, + rt = , + rb = dims[2] - (id - 1L) %% dims[2], + tr = , + br = dims[2] - (id - 1L) %/% dims[1] ) data_frame0( PANEL = factor(id, levels = seq_len(n)), - ROW = as.integer(ROW), - COL = as.integer(COL), + ROW = as.integer(ROW), + COL = as.integer(COL), .size = length(id) ) } diff --git a/R/fortify-map.R b/R/fortify-map.R index 26cfc9b8d9..9ef5737874 100644 --- a/R/fortify-map.R +++ b/R/fortify-map.R @@ -28,7 +28,9 @@ #' } fortify.map <- function(model, data, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), "map_data()" + "3.6.0", + I("`fortify()`"), + "map_data()" ) df <- data_frame0( long = model$x, @@ -85,7 +87,14 @@ fortify.map <- function(model, data, ...) { #' } map_data <- function(map, region = ".", exact = FALSE, ...) { check_installed("maps", reason = "for `map_data()`.") - map_obj <- maps::map(map, region, exact = exact, plot = FALSE, fill = TRUE, ...) + map_obj <- maps::map( + map, + region, + exact = exact, + plot = FALSE, + fill = TRUE, + ... + ) if (!inherits(map_obj, "map")) { cli::cli_abort(c( @@ -96,8 +105,8 @@ map_data <- function(map, region = ".", exact = FALSE, ...) { } df <- data_frame0( - long = map_obj$x, - lat = map_obj$y, + long = map_obj$x, + lat = map_obj$y, group = cumsum(is.na(map_obj$x) & is.na(map_obj$y)) + 1, order = seq_along(map_obj$x), .size = length(map_obj$x) diff --git a/R/fortify-models.R b/R/fortify-models.R index 5a0e95199a..5904ad8af6 100644 --- a/R/fortify-models.R +++ b/R/fortify-models.R @@ -39,7 +39,9 @@ #' geom_point() fortify.lm <- function(model, data = model$model, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), I("`broom::augment()`") + "3.6.0", + I("`fortify()`"), + I("`broom::augment()`") ) infl <- stats::influence(model, do.coef = FALSE) data$.hat <- infl$hat @@ -102,7 +104,9 @@ NULL #' @export fortify.glht <- function(model, data, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + "3.6.0", + I("`fortify()`"), + I("`broom::tidy()`") ) base::data.frame( lhs = rownames(model$linfct), @@ -118,7 +122,9 @@ fortify.glht <- function(model, data, ...) { #' @export fortify.confint.glht <- function(model, data, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + "3.6.0", + I("`fortify()`"), + I("`broom::tidy()`") ) coef <- model$confint colnames(coef) <- to_lower_ascii(colnames(coef)) @@ -137,10 +143,13 @@ fortify.confint.glht <- function(model, data, ...) { #' @export fortify.summary.glht <- function(model, data, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + "3.6.0", + I("`fortify()`"), + I("`broom::tidy()`") ) coef <- as.data.frame( - model$test[c("coefficients", "sigma", "tstat", "pvalues")]) + model$test[c("coefficients", "sigma", "tstat", "pvalues")] + ) names(coef) <- c("estimate", "se", "t", "p") base::data.frame( @@ -158,7 +167,9 @@ fortify.summary.glht <- function(model, data, ...) { #' @export fortify.cld <- function(model, data, ...) { lifecycle::deprecate_warn( - "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + "3.6.0", + I("`fortify()`"), + I("`broom::tidy()`") ) base::data.frame( lhs = names(model$mcletters$Letters), diff --git a/R/fortify-spatial.R b/R/fortify-spatial.R index 2bdcf06557..2142efe14d 100644 --- a/R/fortify-spatial.R +++ b/R/fortify-spatial.R @@ -18,7 +18,8 @@ NULL #' @export #' @method fortify SpatialPolygonsDataFrame fortify.SpatialPolygonsDataFrame <- function(model, data, region = NULL, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -28,12 +29,13 @@ fortify.SpatialPolygonsDataFrame <- function(model, data, region = NULL, ...) { if (is.null(region)) { # Suppress duplicated warnings withr::with_options(list(lifecycle_verbosity = "quiet"), { - coords <- lapply(model@polygons,fortify) + coords <- lapply(model@polygons, fortify) }) coords <- vec_rbind0(!!!coords) cli::cli_inform("Regions defined for each Polygons") } else { - lifecycle::deprecate_stop("3.4.4", + lifecycle::deprecate_stop( + "3.4.4", I("`fortify(, region = ...)` is defunct'"), details = "Please migrate to sf." ) @@ -45,7 +47,8 @@ fortify.SpatialPolygonsDataFrame <- function(model, data, region = NULL, ...) { #' @export #' @method fortify SpatialPolygons fortify.SpatialPolygons <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -61,7 +64,8 @@ fortify.SpatialPolygons <- function(model, data, ...) { #' @export #' @method fortify Polygons fortify.Polygons <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -85,7 +89,8 @@ fortify.Polygons <- function(model, data, ...) { #' @export #' @method fortify Polygon fortify.Polygon <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -101,7 +106,8 @@ fortify.Polygon <- function(model, data, ...) { #' @export #' @method fortify SpatialLinesDataFrame fortify.SpatialLinesDataFrame <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -114,7 +120,8 @@ fortify.SpatialLinesDataFrame <- function(model, data, ...) { #' @export #' @method fortify Lines fortify.Lines <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) @@ -138,7 +145,8 @@ fortify.Lines <- function(model, data, ...) { #' @export #' @method fortify Line fortify.Line <- function(model, data, ...) { - deprecate_warn0("3.4.4", + deprecate_warn0( + "3.4.4", I("`fortify()`"), details = "Please migrate to sf." ) diff --git a/R/fortify.R b/R/fortify.R index 108be24674..64c4578888 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -51,7 +51,8 @@ check_data_frame_like <- function(data) { "{.code dim(data)} must return an {.cls integer} of length 2." ) } - if (anyNA(orig_dims) || any(orig_dims < 0)) { # extra-paranoid mode + if (anyNA(orig_dims) || any(orig_dims < 0)) { + # extra-paranoid mode cli::cli_abort( "{.code dim(data)} can't have {.code NA}s or negative values." ) diff --git a/R/geom-.R b/R/geom-.R index 339750450c..fa73761fe6 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -194,19 +194,32 @@ Geom <- ggproto( #' **Value** #' #' A data frame with completed layer data. - use_defaults = function(self, data, params = list(), modifiers = aes(), - default_aes = NULL, theme = NULL, ...) { + use_defaults = function( + self, + data, + params = list(), + modifiers = aes(), + default_aes = NULL, + theme = NULL, + ... + ) { default_aes <- default_aes %||% self$default_aes # Inherit size as linewidth if no linewidth aesthetic and param exist - if (self$rename_size && is.null(data$linewidth) && is.null(params$linewidth)) { + if ( + self$rename_size && is.null(data$linewidth) && is.null(params$linewidth) + ) { data$linewidth <- data$size params$linewidth <- params$size } # Take care of subclasses setting the wrong default when inheriting from # a geom with rename_size = TRUE if (self$rename_size && is.null(default_aes$linewidth)) { - deprecate_warn0("3.4.0", I("Using the `size` aesthetic in this geom"), I("`linewidth` in the `default_aes` field and elsewhere")) + deprecate_warn0( + "3.4.0", + I("Using the `size` aesthetic in this geom"), + I("`linewidth` in the `default_aes` field and elsewhere") + ) default_aes$linewidth <- default_aes$size } @@ -245,7 +258,8 @@ Geom <- ggproto( if (length(modifiers) != 0) { modified_aes <- try_fetch( eval_aesthetics( - substitute_aes(modifiers), data, + substitute_aes(modifiers), + data, mask = list(stage = stage_scaled) ), error = function(cnd) { @@ -256,12 +270,17 @@ Geom <- ggproto( # Check that all output are valid data check_nondata_cols( - modified_aes, modifiers, + modified_aes, + modifiers, problem = "Aesthetic modifiers returned invalid values.", - hint = "Did you map the modifier in the wrong layer?" + hint = "Did you map the modifier in the wrong layer?" ) - modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale") + modified_aes <- cleanup_mismatched_data( + modified_aes, + nrow(data), + "after_scale" + ) data[names(modified_aes)] <- modified_aes } @@ -305,7 +324,9 @@ Geom <- ggproto( #' #' A data frame with layer data handle_na = function(self, data, params) { - remove_missing(data, params$na.rm, + remove_missing( + data, + params$na.rm, c(self$required_aes, self$non_missing_aes), snake_class(self) ) @@ -349,7 +370,9 @@ Geom <- ggproto( data_panels <- list(data) } lapply(data_panels, function(data) { - if (empty(data)) return(zeroGrob()) + if (empty(data)) { + return(zeroGrob()) + } panel_params <- layout$panel_params[[data$PANEL[1]]] inject(self$draw_panel(data, panel_params, coord, !!!params)) @@ -397,13 +420,18 @@ Geom <- ggproto( self$draw_group(group, panel_params, coord, ...) }) - ggname(snake_class(self), gTree( - children = inject(gList(!!!grobs)) - )) + ggname( + snake_class(self), + gTree( + children = inject(gList(!!!grobs)) + ) + ) }, draw_group = function(self, data, panel_params, coord) { - cli::cli_abort("{.fn {snake_class(self)}}, has not implemented a {.fn draw_group} method") + cli::cli_abort( + "{.fn {snake_class(self)}}, has not implemented a {.fn draw_group} method" + ) }, ## Utilities --------------------------------------------------------------- @@ -478,7 +506,6 @@ eval_from_theme <- function(aesthetics, theme, class = NULL) { class <- setdiff(class, c("Geom", "ggproto", "gg")) if (length(class) > 0) { - # CamelCase to dot.case class <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1.\\2\\3", class) class <- gsub("([a-z])([A-Z])", "\\1.\\2", class) @@ -530,7 +557,11 @@ check_aesthetics <- function(x, n) { fix_linewidth <- function(data, name) { if (is.null(data$linewidth) && !is.null(data$size)) { - deprecate_warn0("3.4.0", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic")) + deprecate_warn0( + "3.4.0", + I(paste0("Using the `size` aesthetic with ", name)), + I("the `linewidth` aesthetic") + ) data$linewidth <- data$size } data diff --git a/R/geom-abline.R b/R/geom-abline.R index 72f71f490e..919bdc5562 100644 --- a/R/geom-abline.R +++ b/R/geom-abline.R @@ -68,13 +68,15 @@ NULL #' geom_point() + #' geom_hline(aes(yintercept = wt, colour = wt), mean_wt) + #' facet_wrap(~ cyl) -geom_abline <- function(mapping = NULL, data = NULL, - ..., - slope, - intercept, - na.rm = FALSE, - show.legend = NA) { - +geom_abline <- function( + mapping = NULL, + data = NULL, + ..., + slope, + intercept, + na.rm = FALSE, + show.legend = NA +) { # If nothing set, default to y = x if (is.null(mapping) && missing(slope) && missing(intercept)) { slope <- 1 @@ -83,17 +85,24 @@ geom_abline <- function(mapping = NULL, data = NULL, # Act like an annotation if (!missing(slope) || !missing(intercept)) { - # Warn if supplied mapping and/or data is going to be overwritten if (!is.null(mapping)) { - cli::cli_warn("{.fn geom_abline}: Ignoring {.arg mapping} because {.arg slope} and/or {.arg intercept} were provided.") + cli::cli_warn( + "{.fn geom_abline}: Ignoring {.arg mapping} because {.arg slope} and/or {.arg intercept} were provided." + ) } if (!is.null(data)) { - cli::cli_warn("{.fn geom_abline}: Ignoring {.arg data} because {.arg slope} and/or {.arg intercept} were provided.") + cli::cli_warn( + "{.fn geom_abline}: Ignoring {.arg data} because {.arg slope} and/or {.arg intercept} were provided." + ) } - if (missing(slope)) slope <- 1 - if (missing(intercept)) intercept <- 0 + if (missing(slope)) { + slope <- 1 + } + if (missing(intercept)) { + intercept <- 0 + } n_slopes <- max(length(slope), length(intercept)) data <- data_frame0( @@ -124,7 +133,9 @@ geom_abline <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomAbline <- ggproto("GeomAbline", Geom, +GeomAbline <- ggproto( + "GeomAbline", + Geom, draw_panel = function(data, panel_params, coord, lineend = "butt") { ranges <- coord$backtransform_range(panel_params) @@ -136,14 +147,24 @@ GeomAbline <- ggproto("GeomAbline", Geom, } # Restrict 'x' to where 'y' is in range: x = (y - intercept) / slope - x <- sweep(outer(ranges$y, data$intercept, FUN = "-"), 2, data$slope, FUN = "/") + x <- sweep( + outer(ranges$y, data$intercept, FUN = "-"), + 2, + data$slope, + FUN = "/" + ) - data$x <- pmax(ranges$x[1], pmin(x[1, ], x[2, ])) + data$x <- pmax(ranges$x[1], pmin(x[1, ], x[2, ])) data$xend <- pmin(ranges$x[2], pmax(x[1, ], x[2, ])) - data$y <- data$x * data$slope + data$intercept + data$y <- data$x * data$slope + data$intercept data$yend <- data$xend * data$slope + data$intercept - GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) + GeomSegment$draw_panel( + unique0(data), + panel_params, + coord, + lineend = lineend + ) }, default_aes = aes( diff --git a/R/geom-bar.R b/R/geom-bar.R index 42d4d1db2b..526fcb80ed 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -4,7 +4,8 @@ #' @export #' @include geom-rect.R GeomBar <- ggproto( - "GeomBar", GeomRect, + "GeomBar", + GeomRect, required_aes = c("x", "y"), # These aes columns are created by setup_data(). They need to be listed here so @@ -25,14 +26,20 @@ GeomBar <- ggproto( data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) data <- compute_data_size( - data, size = params$width, - default = self$default_aes$width, zero = FALSE + data, + size = params$width, + default = self$default_aes$width, + zero = FALSE ) data$just <- params$just %||% 0.5 - data <- transform(data, - ymin = pmin(y, 0), ymax = pmax(y, 0), - xmin = x - width * just, xmax = x + width * (1 - just), - width = NULL, just = NULL + data <- transform( + data, + ymin = pmin(y, 0), + ymax = pmax(y, 0), + xmin = x - width * just, + xmax = x + width * (1 - just), + width = NULL, + just = NULL ) flip_data(data, params$flipped_aes) }, @@ -138,5 +145,7 @@ GeomBar <- ggproto( #' ggplot(df, aes(x, y)) + geom_col(just = 1) geom_bar <- make_constructor( GeomBar, - stat = "count", position = "stack", just = 0.5 + stat = "count", + position = "stack", + just = 0.5 ) diff --git a/R/geom-blank.R b/R/geom-blank.R index 72b5b1e265..78122171a1 100644 --- a/R/geom-blank.R +++ b/R/geom-blank.R @@ -10,11 +10,15 @@ #' @examples #' ggplot(mtcars, aes(wt, mpg)) #' # Nothing to see here! -geom_blank <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - show.legend = NA, - inherit.aes = TRUE) { +geom_blank <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + show.legend = NA, + inherit.aes = TRUE +) { layer( data = data, mapping = mapping, @@ -33,7 +37,9 @@ geom_blank <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomBlank <- ggproto("GeomBlank", Geom, +GeomBlank <- ggproto( + "GeomBlank", + Geom, default_aes = aes(), handle_na = function(data, params) { data diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 78bdbacc30..6a2d94f554 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -122,42 +122,45 @@ #' stat = "identity" #' ) #' } -geom_boxplot <- function(mapping = NULL, data = NULL, - stat = "boxplot", position = "dodge2", - ..., - outliers = TRUE, - outlier.colour = NULL, - outlier.color = NULL, - outlier.fill = NULL, - outlier.shape = NULL, - outlier.size = NULL, - outlier.stroke = 0.5, - outlier.alpha = NULL, - whisker.colour = NULL, - whisker.color = NULL, - whisker.linetype = NULL, - whisker.linewidth = NULL, - staple.colour = NULL, - staple.color = NULL, - staple.linetype = NULL, - staple.linewidth = NULL, - median.colour = NULL, - median.color = NULL, - median.linetype = NULL, - median.linewidth = NULL, - box.colour = NULL, - box.color = NULL, - box.linetype = NULL, - box.linewidth = NULL, - notch = FALSE, - notchwidth = 0.5, - staplewidth = 0, - varwidth = FALSE, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - +geom_boxplot <- function( + mapping = NULL, + data = NULL, + stat = "boxplot", + position = "dodge2", + ..., + outliers = TRUE, + outlier.colour = NULL, + outlier.color = NULL, + outlier.fill = NULL, + outlier.shape = NULL, + outlier.size = NULL, + outlier.stroke = 0.5, + outlier.alpha = NULL, + whisker.colour = NULL, + whisker.color = NULL, + whisker.linetype = NULL, + whisker.linewidth = NULL, + staple.colour = NULL, + staple.color = NULL, + staple.linetype = NULL, + staple.linewidth = NULL, + median.colour = NULL, + median.color = NULL, + median.linetype = NULL, + median.linewidth = NULL, + box.colour = NULL, + box.color = NULL, + box.linetype = NULL, + box.linewidth = NULL, + notch = FALSE, + notchwidth = 0.5, + staplewidth = 0, + varwidth = FALSE, + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE +) { # varwidth = TRUE is not compatible with preserve = "total" if (is.character(position)) { if (varwidth == TRUE) position <- position_dodge2(preserve = "single") @@ -170,34 +173,34 @@ geom_boxplot <- function(mapping = NULL, data = NULL, outlier_gp <- list( colour = outlier.color %||% outlier.colour, - fill = outlier.fill, - shape = outlier.shape, - size = outlier.size, + fill = outlier.fill, + shape = outlier.shape, + size = outlier.size, stroke = outlier.stroke, - alpha = outlier.alpha + alpha = outlier.alpha ) whisker_gp <- list( - colour = whisker.color %||% whisker.colour, - linetype = whisker.linetype, + colour = whisker.color %||% whisker.colour, + linetype = whisker.linetype, linewidth = whisker.linewidth ) staple_gp <- list( - colour = staple.color %||% staple.colour, - linetype = staple.linetype, + colour = staple.color %||% staple.colour, + linetype = staple.linetype, linewidth = staple.linewidth ) median_gp <- list( - colour = median.color %||% median.colour, - linetype = median.linetype, + colour = median.color %||% median.colour, + linetype = median.linetype, linewidth = median.linewidth ) box_gp <- list( - colour = box.color %||% box.colour, - linetype = box.linetype, + colour = box.color %||% box.colour, + linetype = box.linetype, linewidth = box.linewidth ) @@ -216,9 +219,9 @@ geom_boxplot <- function(mapping = NULL, data = NULL, outliers = outliers, outlier_gp = outlier_gp, whisker_gp = whisker_gp, - staple_gp = staple_gp, - median_gp = median_gp, - box_gp = box_gp, + staple_gp = staple_gp, + median_gp = median_gp, + box_gp = box_gp, notch = notch, notchwidth = notchwidth, staplewidth = staplewidth, @@ -234,14 +237,17 @@ geom_boxplot <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomBoxplot <- ggproto("GeomBoxplot", Geom, +GeomBoxplot <- ggproto( + "GeomBoxplot", + Geom, extra_params = c("na.rm", "orientation", "outliers"), setup_params = function(data, params) { if ("fatten" %in% names(params)) { deprecate_soft0( - "4.0.0", "geom_boxplot(fatten)", + "4.0.0", + "geom_boxplot(fatten)", "geom_boxplot(median.linewidth)" ) } else { @@ -256,9 +262,11 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) data <- compute_data_size( - data, params$width, + data, + params$width, default = self$default_aes$width, - zero = FALSE, discrete = TRUE + zero = FALSE, + discrete = TRUE ) if (isFALSE(params$outliers)) { data$outliers <- NULL @@ -270,12 +278,17 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, out_max <- vapply(data$outliers, max, numeric(1)) }) - data$ymin_final <- pmin(out_min, data$ymin) - data$ymax_final <- pmax(out_max, data$ymax) + data$ymin_final <- pmin(out_min, data$ymin) + data$ymax_final <- pmax(out_max, data$ymax) } # if `varwidth` not requested or not available, don't use it - if (is.null(params) || is.null(params$varwidth) || !params$varwidth || is.null(data$relvarwidth)) { + if ( + is.null(params) || + is.null(params$varwidth) || + !params$varwidth || + is.null(data$relvarwidth) + ) { data$xmin <- data$x - data$width / 2 data$xmax <- data$x + data$width / 2 } else { @@ -285,23 +298,39 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, data$xmax <- data$x + data$relvarwidth * data$width / 2 } data$width <- NULL - if (!is.null(data$relvarwidth)) data$relvarwidth <- NULL + if (!is.null(data$relvarwidth)) { + data$relvarwidth <- NULL + } flip_data(data, params$flipped_aes) }, - draw_group = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", fatten = 2, outlier_gp = NULL, - whisker_gp = NULL, staple_gp = NULL, median_gp = NULL, - box_gp = NULL, notch = FALSE, notchwidth = 0.5, - staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) { + draw_group = function( + self, + data, + panel_params, + coord, + lineend = "butt", + linejoin = "mitre", + fatten = 2, + outlier_gp = NULL, + whisker_gp = NULL, + staple_gp = NULL, + median_gp = NULL, + box_gp = NULL, + notch = FALSE, + notchwidth = 0.5, + staplewidth = 0, + varwidth = FALSE, + flipped_aes = FALSE + ) { data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) # this may occur when using geom_boxplot(stat = "identity") if (nrow(data) != 1) { cli::cli_abort(c( "Can only draw one boxplot per group.", - "i"= "Did you forget {.code aes(group = ...)}?" + "i" = "Did you forget {.code aes(group = ...)}?" )) } @@ -312,8 +341,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, xend = c(data$x, data$x), y = c(data$upper, data$lower), yend = c(data$ymax, data$ymin), - colour = rep(whisker_gp$colour %||% data$colour, 2), - linetype = rep(whisker_gp$linetype %||% data$linetype, 2), + colour = rep(whisker_gp$colour %||% data$colour, 2), + linetype = rep(whisker_gp$linetype %||% data$linetype, 2), linewidth = rep(whisker_gp$linewidth %||% data$linewidth, 2), alpha = c(NA_real_, NA_real_), !!!common, @@ -337,9 +366,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, y = data$outliers[[1]], x = data$x[1], colour = outlier_gp$colour %||% data$colour[1], - fill = outlier_gp$fill %||% data$fill[1], - shape = outlier_gp$shape %||% data$shape[1] %||% 19, - size = outlier_gp$size %||% data$size[1] %||% 1.5, + fill = outlier_gp$fill %||% data$fill[1], + shape = outlier_gp$shape %||% data$shape[1] %||% 19, + size = outlier_gp$size %||% data$size[1] %||% 1.5, stroke = outlier_gp$stroke %||% data$stroke[1] %||% 0.5, fill = NA, alpha = outlier_gp$alpha %||% data$alpha[1], @@ -354,55 +383,76 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, if (staplewidth != 0) { staples <- data_frame0( - x = rep((data$xmin - data$x) * staplewidth + data$x, 2), + 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), + y = c(data$ymax, data$ymin), yend = c(data$ymax, data$ymin), - linetype = rep(staple_gp$linetype %||% data$linetype, 2), + linetype = rep(staple_gp$linetype %||% data$linetype, 2), linewidth = rep(staple_gp$linewidth %||% data$linewidth, 2), - colour = rep(staple_gp$colour %||% data$colour, 2), + colour = rep(staple_gp$colour %||% data$colour, 2), alpha = c(NA_real_, NA_real_), !!!common, .size = 2 ) staples <- flip_data(staples, flipped_aes) staple_grob <- GeomSegment$draw_panel( - staples, panel_params, coord, + staples, + panel_params, + coord, lineend = lineend ) } else { staple_grob <- NULL } - ggname("geom_boxplot", grobTree( - outliers_grob, - staple_grob, - GeomSegment$draw_panel(whiskers, panel_params, coord, lineend = lineend), - GeomCrossbar$draw_panel( - box, - fatten = fatten, - panel_params, - coord, - lineend = lineend, - linejoin = linejoin, - flipped_aes = flipped_aes, - middle_gp = median_gp, - box_gp = box_gp + ggname( + "geom_boxplot", + grobTree( + outliers_grob, + staple_grob, + GeomSegment$draw_panel( + whiskers, + panel_params, + coord, + lineend = lineend + ), + GeomCrossbar$draw_panel( + box, + fatten = fatten, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin, + flipped_aes = flipped_aes, + middle_gp = median_gp, + box_gp = box_gp + ) ) - )) + ) }, draw_key = draw_key_boxplot, default_aes = aes( - weight = 1, colour = from_theme(colour %||% col_mix(ink, paper, 0.2)), - fill = from_theme(fill %||% paper), size = from_theme(pointsize), - alpha = NA, shape = from_theme(pointshape), linetype = from_theme(bordertype), + weight = 1, + colour = from_theme(colour %||% col_mix(ink, paper, 0.2)), + fill = from_theme(fill %||% paper), + size = from_theme(pointsize), + alpha = NA, + shape = from_theme(pointshape), + linetype = from_theme(bordertype), linewidth = from_theme(borderwidth), width = 0.9 ), - required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"), + required_aes = c( + "x|y", + "lower|xlower", + "upper|xupper", + "middle|xmiddle", + "ymin|xmin", + "ymax|xmax" + ), rename_size = TRUE ) diff --git a/R/geom-contour.R b/R/geom-contour.R index f6791fd4dc..8a4b54b871 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -4,7 +4,8 @@ #' @export #' @include geom-path.R GeomContour <- ggproto( - "GeomContour", GeomPath, + "GeomContour", + GeomPath, default_aes = aes( weight = 1, colour = from_theme(colour %||% accent), @@ -84,15 +85,21 @@ GeomContourFilled <- ggproto("GeomContourFilled", GeomPolygon) #' geom_contour(colour = "white") #' } geom_contour <- make_constructor( - GeomContour, stat = "contour", + GeomContour, + stat = "contour", # Passed to contour stat: - bins = NULL, binwidth = NULL, breaks = NULL + bins = NULL, + binwidth = NULL, + breaks = NULL ) #' @rdname geom_contour #' @export geom_contour_filled <- make_constructor( - GeomContourFilled, stat = "contour_filled", + GeomContourFilled, + stat = "contour_filled", # Passed to contour_filled stat: - bins = NULL, binwidth = NULL, breaks = NULL + bins = NULL, + binwidth = NULL, + breaks = NULL ) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 2547219ac6..612d905c6a 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -6,32 +6,35 @@ #' @param box.colour,box.color,box.linetype,box.linewidth #' Default aesthetics for the boxes. Set to `NULL` to inherit from the #' data's aesthetics. -geom_crossbar <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - middle.colour = NULL, - middle.color = NULL, - middle.linetype = NULL, - middle.linewidth = NULL, - box.colour = NULL, - box.color = NULL, - box.linetype = NULL, - box.linewidth = NULL, - fatten = deprecated(), - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - +geom_crossbar <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + middle.colour = NULL, + middle.color = NULL, + middle.linetype = NULL, + middle.linewidth = NULL, + box.colour = NULL, + box.color = NULL, + box.linetype = NULL, + box.linewidth = NULL, + fatten = deprecated(), + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE +) { middle_gp <- list( - colour = middle.color %||% middle.colour, - linetype = middle.linetype, + colour = middle.color %||% middle.colour, + linetype = middle.linetype, linewidth = middle.linewidth ) box_gp <- list( - colour = box.color %||% box.colour, - linetype = box.linetype, + colour = box.color %||% box.colour, + linetype = box.linetype, linewidth = box.linewidth ) @@ -58,11 +61,14 @@ geom_crossbar <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomCrossbar <- ggproto("GeomCrossbar", Geom, +GeomCrossbar <- ggproto( + "GeomCrossbar", + Geom, setup_params = function(data, params) { if (lifecycle::is_present(params$fatten %||% deprecated())) { deprecate_soft0( - "4.0.0", "geom_crossbar(fatten)", + "4.0.0", + "geom_crossbar(fatten)", "geom_crossbar(middle.linewidth)" ) } else { @@ -90,24 +96,44 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, draw_key = draw_key_crossbar, - draw_panel = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", fatten = 2.5, width = NULL, - flipped_aes = FALSE, middle_gp = NULL, box_gp = NULL) { + draw_panel = function( + self, + data, + panel_params, + coord, + lineend = "butt", + linejoin = "mitre", + fatten = 2.5, + width = NULL, + flipped_aes = FALSE, + middle_gp = NULL, + box_gp = NULL + ) { data <- fix_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) + middle <- transform( + data, + x = xmin, + xend = xmax, + yend = y, + linewidth = linewidth * fatten, + alpha = NA + ) middle <- data_frame0(!!!defaults(compact(middle_gp), middle)) - has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) && - !is.na(data$ynotchlower) && !is.na(data$ynotchupper) + has_notch <- !is.null(data$ynotchlower) && + !is.null(data$ynotchupper) && + !is.na(data$ynotchlower) && + !is.na(data$ynotchupper) if (has_notch) { - if (data$ynotchlower < data$ymin || data$ynotchupper > data$ymax) + if (data$ynotchlower < data$ymin || data$ynotchupper > data$ymax) { cli::cli_inform(c( "Notch went outside hinges", i = "Do you want {.code notch = FALSE}?" )) + } notchindent <- (1 - data$notchwidth) * (data$xmax - data$xmin) / 2 @@ -116,19 +142,35 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, 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, + data$xmin, + data$xmin, + data$xmin + notchindent, + data$xmin, + data$xmin, + data$xmax, + data$xmax, + data$xmax - notchindent, + data$xmax, + data$xmax, data$xmin ), y = c( - data$ymax, data$ynotchupper, data$y, data$ynotchlower, data$ymin, - data$ymin, data$ynotchlower, data$y, data$ynotchupper, data$ymax, + data$ymax, + data$ynotchupper, + data$y, + data$ynotchlower, + data$ymin, + data$ymin, + data$ynotchlower, + data$y, + data$ynotchupper, + data$ymax, data$ymax ), alpha = rep(data$alpha, 11), - colour = rep(data$colour, 11), + colour = rep(data$colour, 11), linewidth = rep(data$linewidth, 11), - linetype = rep(data$linetype, 11), + linetype = rep(data$linetype, 11), fill = rep(data$fill, 11), group = rep(seq_len(nrow(data)), 11) ) @@ -138,9 +180,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, 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), - colour = rep(data$colour, 5), + colour = rep(data$colour, 5), linewidth = rep(data$linewidth, 5), - linetype = rep(data$linetype, 5), + linetype = rep(data$linetype, 5), fill = rep(data$fill, 5), group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group ) @@ -149,10 +191,27 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, box <- flip_data(box, flipped_aes) middle <- flip_data(middle, flipped_aes) - ggname("geom_crossbar", gTree(children = gList( - GeomPolygon$draw_panel(box, panel_params, coord, lineend = lineend, linejoin = linejoin), - GeomSegment$draw_panel(middle, panel_params, coord, lineend = lineend, linejoin = linejoin) - ))) + ggname( + "geom_crossbar", + gTree( + children = gList( + GeomPolygon$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-curve.R b/R/geom-curve.R index dcb7b18003..0af528f8de 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -4,16 +4,29 @@ #' @usage NULL #' @export GeomCurve <- ggproto( - "GeomCurve", GeomSegment, - - draw_panel = function(data, panel_params, coord, curvature = 0.5, angle = 90, - ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) { + "GeomCurve", + GeomSegment, + draw_panel = function( + data, + panel_params, + coord, + curvature = 0.5, + angle = 90, + ncp = 5, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + na.rm = FALSE + ) { if (!coord$is_linear()) { - cli::cli_warn("{.fn geom_curve} is not implemented for non-linear coordinates") + cli::cli_warn( + "{.fn geom_curve} is not implemented for non-linear coordinates" + ) } data <- remove_missing( - data, na.rm = na.rm, + data, + na.rm = na.rm, c("x", "y", "xend", "yend", "linetype", "linewidth"), name = "geom_curve" ) @@ -32,16 +45,25 @@ GeomCurve <- ggproto( arrow.fill <- arrow.fill %||% trans$colour curveGrob( - trans$x, trans$y, trans$xend, trans$yend, + trans$x, + trans$y, + trans$xend, + trans$yend, default.units = "native", - curvature = curvature, angle = angle, ncp = ncp, - square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE, + curvature = curvature, + angle = angle, + ncp = ncp, + square = FALSE, + squareShape = 1, + inflect = FALSE, + open = TRUE, gp = gg_par( col = alpha(trans$colour, trans$alpha), fill = alpha(arrow.fill, trans$alpha), lwd = trans$linewidth, lty = trans$linetype, - lineend = lineend), + lineend = lineend + ), arrow = arrow ) } diff --git a/R/geom-defaults.R b/R/geom-defaults.R index 11d6776410..413fda0b90 100644 --- a/R/geom-defaults.R +++ b/R/geom-defaults.R @@ -112,7 +112,10 @@ get_geom_defaults <- function(geom, theme = theme_get()) { out <- geom$use_defaults(data = NULL, theme = theme) return(out) } - stop_input_type(geom, as_cli("a layer function, string or {.cls Geom} object")) + stop_input_type( + geom, + as_cli("a layer function, string or {.cls Geom} object") + ) } #' @rdname update_defaults @@ -126,18 +129,19 @@ reset_stat_defaults <- function() reset_defaults("stat") cache_defaults <- new_environment() update_defaults <- function(name, subclass, new, env = parent.frame()) { - obj <- validate_subclass(name, subclass, env = env) + obj <- validate_subclass(name, subclass, env = env) index <- snake_class(obj) - if (is.null(new)) { # Reset from cache + if (is.null(new)) { + # Reset from cache old <- cache_defaults[[index]] if (!is.null(old)) { new <- update_defaults(name, subclass, new = old, env = env) } invisible(new) - - } else { # Update default aesthetics + } else { + # Update default aesthetics old <- obj$default_aes # Only update cache the first time defaults are changed @@ -149,7 +153,6 @@ update_defaults <- function(name, subclass, new, env = parent.frame()) { new <- defaults(new, old)[name_order] obj$default_aes[names(new)] <- new invisible(old) - } } diff --git a/R/geom-density.R b/R/geom-density.R index d1964c07fe..2ba7af7ea7 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -4,14 +4,15 @@ #' @export #' @include geom-ribbon.R GeomDensity <- ggproto( - "GeomDensity", GeomArea, + "GeomDensity", + GeomArea, default_aes = aes( colour = from_theme(colour %||% ink), - fill = from_theme(fill %||% NA), + fill = from_theme(fill %||% NA), weight = 1, - alpha = NA, + alpha = NA, linewidth = from_theme(linewidth), - linetype = from_theme(linetype) + linetype = from_theme(linetype) ) ) @@ -76,8 +77,13 @@ GeomDensity <- ggproto( #' geom_density(position = "fill") #' } geom_density <- make_constructor( - GeomDensity, stat = "density", outline.type = "upper", + GeomDensity, + stat = "density", + outline.type = "upper", checks = exprs( - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + outline.type <- arg_match0( + outline.type, + c("both", "upper", "lower", "full") + ) ) ) diff --git a/R/geom-density2d.R b/R/geom-density2d.R index 0197e2698e..dfb7c95a9f 100644 --- a/R/geom-density2d.R +++ b/R/geom-density2d.R @@ -65,16 +65,20 @@ #' # Or points: #' d + stat_density_2d(geom = "point", aes(size = after_stat(density)), n = 20, contour = FALSE) #' } -geom_density_2d <- function(mapping = NULL, data = NULL, - stat = "density_2d", position = "identity", - ..., - contour_var = "density", - lineend = "butt", - linejoin = "round", - linemitre = 10, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_density_2d <- function( + mapping = NULL, + data = NULL, + stat = "density_2d", + position = "identity", + ..., + contour_var = "density", + lineend = "butt", + linejoin = "round", + linemitre = 10, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { layer( data = data, mapping = mapping, @@ -105,7 +109,9 @@ geom_density2d <- geom_density_2d #' @format NULL #' @usage NULL #' @export -GeomDensity2d <- ggproto("GeomDensity2d", GeomPath, +GeomDensity2d <- ggproto( + "GeomDensity2d", + GeomPath, default_aes = aes( colour = from_theme(colour %||% accent), linewidth = from_theme(linewidth), @@ -116,13 +122,17 @@ GeomDensity2d <- ggproto("GeomDensity2d", GeomPath, #' @export #' @rdname geom_density_2d -geom_density_2d_filled <- function(mapping = NULL, data = NULL, - stat = "density_2d_filled", position = "identity", - ..., - contour_var = "density", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_density_2d_filled <- function( + mapping = NULL, + data = NULL, + stat = "density_2d_filled", + position = "identity", + ..., + contour_var = "density", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { layer( data = data, mapping = mapping, @@ -151,4 +161,3 @@ geom_density2d_filled <- geom_density_2d_filled #' @export #' @include geom-polygon.R GeomDensity2dFilled <- ggproto("GeomDensity2dFilled", GeomPolygon) - diff --git a/R/geom-dotplot.R b/R/geom-dotplot.R index 89def6a9ac..4e34e20f12 100644 --- a/R/geom-dotplot.R +++ b/R/geom-dotplot.R @@ -120,38 +120,51 @@ #' ggplot(mtcars, aes(x = 1, y = mpg, fill = factor(cyl))) + #' geom_dotplot(binaxis = "y", stackgroups = TRUE, binwidth = 1, method = "histodot") #' } -geom_dotplot <- function(mapping = NULL, data = NULL, - position = "identity", - ..., - binwidth = NULL, - binaxis = "x", - method = "dotdensity", - binpositions = "bygroup", - stackdir = "up", - stackratio = 1, - dotsize = 1, - stackgroups = FALSE, - origin = NULL, - right = TRUE, - width = 0.9, - drop = FALSE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_dotplot <- function( + mapping = NULL, + data = NULL, + position = "identity", + ..., + binwidth = NULL, + binaxis = "x", + method = "dotdensity", + binpositions = "bygroup", + stackdir = "up", + stackratio = 1, + dotsize = 1, + stackgroups = FALSE, + origin = NULL, + right = TRUE, + width = 0.9, + drop = FALSE, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { # If identical(position, "stack") or position is position_stack(), tell them # to use stackgroups=TRUE instead. Need to use identical() instead of ==, # because == will fail if object is position_stack() or position_dodge() - if (!is.null(position) && - (identical(position, "stack") || (inherits(position, "PositionStack")))) - cli::cli_inform("{.code position = \"stack\"} doesn't work properly with {.fn geom_dotplot}. Use {.code stackgroups = TRUE} instead.") + if ( + !is.null(position) && + (identical(position, "stack") || (inherits(position, "PositionStack"))) + ) { + cli::cli_inform( + "{.code position = \"stack\"} doesn't work properly with {.fn geom_dotplot}. Use {.code stackgroups = TRUE} instead." + ) + } - if (stackgroups && method == "dotdensity" && binpositions == "bygroup") + if (stackgroups && method == "dotdensity" && binpositions == "bygroup") { cli::cli_inform(c( '{.fn geom_dotplot} called with {.code stackgroups = TRUE} and {.code method = "dotdensity"}.", i = "Do you want {.code binpositions = "all"} instead?' )) + } - stackdir <- arg_match0(stackdir, c("up", "down", "center", "centerwhole"), "stackdir") + stackdir <- arg_match0( + stackdir, + c("up", "down", "center", "centerwhole"), + "stackdir" + ) layer( data = data, mapping = mapping, @@ -184,7 +197,9 @@ geom_dotplot <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomDotplot <- ggproto("GeomDotplot", Geom, +GeomDotplot <- ggproto( + "GeomDotplot", + Geom, required_aes = c("x", "y"), non_missing_aes = c("size", "shape"), @@ -200,14 +215,16 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, setup_data = function(self, data, params) { data <- compute_data_size( - data, params$width, + data, + params$width, default = self$default_aes$width, - zero = FALSE, discrete = TRUE + zero = FALSE, + discrete = TRUE ) # Set up the stacking function and range if (is.null(params$stackdir) || params$stackdir == "up") { - stackdots <- function(a) a - 0.5 + stackdots <- function(a) a - 0.5 stackaxismin <- 0 stackaxismax <- 1 } else if (params$stackdir == "down") { @@ -215,11 +232,11 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, stackaxismin <- -1 stackaxismax <- 0 } else if (params$stackdir == "center") { - stackdots <- function(a) a - 1 - max(a - 1) / 2 + stackdots <- function(a) a - 1 - max(a - 1) / 2 stackaxismin <- -0.5 stackaxismax <- 0.5 } else if (params$stackdir == "centerwhole") { - stackdots <- function(a) a - 1 - floor(max(a - 1) / 2) + stackdots <- function(a) a - 1 - floor(max(a - 1) / 2) stackaxismin <- -0.5 stackaxismax <- 0.5 } @@ -232,8 +249,9 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, plyvars <- params$binaxis %||% "x" stackaxis <- setdiff(c("x", "y"), plyvars) plyvars <- c(plyvars, "PANEL") - if (is.null(params$stackgroups) || !params$stackgroups) + if (is.null(params$stackgroups) || !params$stackgroups) { plyvars <- c(plyvars, "group") + } if (stackaxis == "x") { plyvars <- c(plyvars, "x") @@ -246,7 +264,6 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, xx }) - # Set the bounding boxes for the dots if (is.null(params$binaxis) || params$binaxis == "x") { # ymin, ymax, xmin, and xmax define the bounding rectangle for each stack @@ -265,9 +282,13 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, # works. They're just set to the standard x +- width/2 so that dot clusters # can be dodged like other geoms. # After position code is rewritten, each dot should have its own bounding box. - data <- dapply(data, c("group", "PANEL"), transform, - ymin = min(y) - binwidth[1] / 2, - ymax = max(y) + binwidth[1] / 2) + data <- dapply( + data, + c("group", "PANEL"), + transform, + ymin = min(y) - binwidth[1] / 2, + ymax = max(y) + binwidth[1] / 2 + ) data$xmin <- data$x + data$width * stackaxismin data$xmax <- data$x + data$width * stackaxismax @@ -276,37 +297,62 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, data }, - - draw_group = function(data, panel_params, coord, lineend = "butt", na.rm = FALSE, - binaxis = "x", stackdir = "up", stackratio = 1, - dotsize = 1, stackgroups = FALSE) { + draw_group = function( + data, + panel_params, + coord, + lineend = "butt", + na.rm = FALSE, + binaxis = "x", + stackdir = "up", + stackratio = 1, + dotsize = 1, + stackgroups = FALSE + ) { if (!coord$is_linear()) { - cli::cli_warn("{.fn geom_dotplot} does not work properly with non-linear coordinates.") + cli::cli_warn( + "{.fn geom_dotplot} does not work properly with non-linear coordinates." + ) } tdata <- coord$transform(data, panel_params) # Swap axes if using coord_flip - if (inherits(coord, "CoordFlip")) + if (inherits(coord, "CoordFlip")) { binaxis <- ifelse(binaxis == "x", "y", "x") + } if (binaxis == "x") { stackaxis <- "y" - dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$x.range) - min(panel_params$x.range)) - + dotdianpc <- dotsize * + tdata$binwidth[1] / + (max(panel_params$x.range) - min(panel_params$x.range)) } else if (binaxis == "y") { stackaxis <- "x" - dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$y.range) - min(panel_params$y.range)) + dotdianpc <- dotsize * + tdata$binwidth[1] / + (max(panel_params$y.range) - min(panel_params$y.range)) } - ggname("geom_dotplot", - dotstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc, - stackposition = tdata$stackpos, stackdir = stackdir, stackratio = stackratio, - default.units = "npc", - gp = gg_par(col = alpha(tdata$colour, tdata$alpha), - fill = fill_alpha(tdata$fill, tdata$alpha), - lwd = tdata$stroke / .pt, lty = tdata$linetype, - lineend = lineend)) + ggname( + "geom_dotplot", + dotstackGrob( + stackaxis = stackaxis, + x = tdata$x, + y = tdata$y, + dotdia = dotdianpc, + stackposition = tdata$stackpos, + stackdir = stackdir, + stackratio = stackratio, + default.units = "npc", + gp = gg_par( + col = alpha(tdata$colour, tdata$alpha), + fill = fill_alpha(tdata$fill, tdata$alpha), + lwd = tdata$stroke / .pt, + lty = tdata$linetype, + lineend = lineend + ) + ) ) }, diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index dd0d57ca8f..972464e779 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export GeomErrorbar <- ggproto( - "GeomErrorbar", Geom, + "GeomErrorbar", + Geom, default_aes = aes( colour = from_theme(colour %||% ink), @@ -21,8 +22,8 @@ GeomErrorbar <- ggproto( params <- GeomLinerange$setup_params(data, params) if ( isTRUE(params$flipped_aes) && - isTRUE("height" %in% names(params)) && - !isTRUE("width" %in% names(params)) + isTRUE("height" %in% names(params)) && + !isTRUE("width" %in% names(params)) ) { params <- rename(params, c(height = "width")) cli::cli_inform("{.arg height} was translated to {.arg width}.") @@ -36,23 +37,53 @@ GeomErrorbar <- ggproto( data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) data <- compute_data_size( - data, params$width, + data, + params$width, default = self$default_aes$width, - zero = FALSE, discrete = TRUE + zero = FALSE, + discrete = TRUE ) - data <- transform(data, - xmin = x - width / 2, xmax = x + width / 2, width = NULL + data <- transform( + data, + xmin = x - width / 2, + xmax = x + width / 2, + width = NULL ) flip_data(data, params$flipped_aes) }, # Note: `width` is vestigial - draw_panel = function(self, data, panel_params, coord, lineend = "butt", - width = NULL, flipped_aes = FALSE) { + draw_panel = function( + self, + data, + panel_params, + coord, + lineend = "butt", + width = NULL, + flipped_aes = FALSE + ) { data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) - x <- vec_interleave(data$xmin, data$xmax, NA, data$x, data$x, NA, data$xmin, data$xmax) - y <- vec_interleave(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin) + x <- vec_interleave( + data$xmin, + data$xmax, + NA, + data$x, + data$x, + NA, + data$xmin, + data$xmax + ) + y <- vec_interleave( + data$ymax, + data$ymax, + NA, + data$ymax, + data$ymin, + NA, + data$ymin, + data$ymin + ) data <- data_frame0( x = x, y = y, @@ -75,10 +106,13 @@ GeomErrorbar <- ggproto( #' @usage NULL #' @export GeomErrorbarh <- ggproto( - "GeomErrorbarh", GeomErrorbar, + "GeomErrorbarh", + GeomErrorbar, setup_params = function(data, params) { deprecate_soft0( - "4.0.0", "geom_errobarh()", "geom_errorbar(orientation = \"y\")", + "4.0.0", + "geom_errobarh()", + "geom_errorbar(orientation = \"y\")", id = "no-more-errorbarh" ) GeomLinerange$setup_params(data, params) @@ -96,7 +130,9 @@ geom_errorbar <- make_constructor(GeomErrorbar, orientation = NA) #' `geom_errorbar(orientation = "y")` instead. geom_errorbarh <- function(..., orientation = "y") { deprecate_soft0( - "4.0.0", "geom_errobarh()", "geom_errorbar(orientation = \"y\")", + "4.0.0", + "geom_errobarh()", + "geom_errorbar(orientation = \"y\")", id = "no-more-errorbarh" ) geom_errorbar(..., orientation = orientation) diff --git a/R/geom-freqpoly.R b/R/geom-freqpoly.R index 0cdf193e08..272fbc53c3 100644 --- a/R/geom-freqpoly.R +++ b/R/geom-freqpoly.R @@ -1,12 +1,15 @@ #' @export #' @rdname geom_histogram -geom_freqpoly <- function(mapping = NULL, data = NULL, - stat = "bin", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - +geom_freqpoly <- function( + mapping = NULL, + data = NULL, + stat = "bin", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { params <- list2(na.rm = na.rm, ...) if (identical(stat, "bin")) { params$pad <- TRUE diff --git a/R/geom-function.R b/R/geom-function.R index ba595da7c3..05f29f5df4 100644 --- a/R/geom-function.R +++ b/R/geom-function.R @@ -3,10 +3,21 @@ #' @usage NULL #' @export #' @include geom-path.R -GeomFunction <- ggproto("GeomFunction", GeomPath, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", linemitre = 10, - na.rm = FALSE) { +GeomFunction <- ggproto( + "GeomFunction", + GeomPath, + draw_panel = function( + self, + data, + panel_params, + coord, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, + na.rm = FALSE + ) { groups <- unique0(data$group) if (length(groups) > 1) { cli::cli_warn(c( @@ -16,7 +27,15 @@ GeomFunction <- ggproto("GeomFunction", GeomPath, } ggproto_parent(GeomPath, self)$draw_panel( - data, panel_params, coord, arrow, arrow.fill, lineend, linejoin, linemitre, na.rm + data, + panel_params, + coord, + arrow, + arrow.fill, + lineend, + linejoin, + linemitre, + na.rm ) } ) @@ -84,6 +103,7 @@ GeomFunction <- ggproto("GeomFunction", GeomPath, #' #' @export geom_function <- make_constructor( - GeomFunction, stat = "function", + GeomFunction, + stat = "function", checks = exprs(data <- data %||% ensure_nonempty_data) ) diff --git a/R/geom-hex.R b/R/geom-hex.R index 0e67b49ad9..e982bbc394 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -2,9 +2,18 @@ #' @format NULL #' @usage NULL #' @export -GeomHex <- ggproto("GeomHex", Geom, - draw_group = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", linemitre = 10) { +GeomHex <- ggproto( + "GeomHex", + Geom, + draw_group = function( + self, + data, + panel_params, + coord, + lineend = "butt", + linejoin = "mitre", + linemitre = 10 + ) { data <- fix_linewidth(data, snake_class(self)) if (empty(data)) { return(zeroGrob()) @@ -20,7 +29,7 @@ GeomHex <- ggproto("GeomHex", Geom, # for the effect of the overlapping range in y-direction on the resolution # calculation if (!is.null(data$height)) { - dy <- data$height[1] / sqrt(3) / 2 + dy <- data$height[1] / sqrt(3) / 2 } else { dy <- resolution(data$y, FALSE, TRUE) / sqrt(3) / 2 * 1.15 } @@ -35,20 +44,24 @@ GeomHex <- ggproto("GeomHex", Geom, coords <- coord$transform(hexdata, panel_params) - ggname("geom_hex", polygonGrob( - coords$x, coords$y, - gp = gg_par( - col = data$colour, - fill = fill_alpha(data$fill, data$alpha), - lwd = data$linewidth, - lty = data$linetype, - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre - ), - default.units = "native", - id.lengths = rep.int(6, n) - )) + ggname( + "geom_hex", + polygonGrob( + coords$x, + coords$y, + gp = gg_par( + col = data$colour, + fill = fill_alpha(data$fill, data$alpha), + lwd = data$linewidth, + lty = data$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ), + default.units = "native", + id.lengths = rep.int(6, n) + ) + ) }, required_aes = c("x", "y"), diff --git a/R/geom-histogram.R b/R/geom-histogram.R index a922a54dd7..d8fc6c9132 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -134,7 +134,11 @@ #' facet_wrap(~variable, scales = 'free_x') + #' geom_histogram(binwidth = \(x) 2 * IQR(x) / (length(x)^(1/3))) geom_histogram <- make_constructor( - GeomBar, stat = "bin", position = "stack", + GeomBar, + stat = "bin", + position = "stack", # Passed to bin stat: - binwidth = NULL, bins = NULL, orientation = NA + binwidth = NULL, + bins = NULL, + orientation = NA ) diff --git a/R/geom-hline.R b/R/geom-hline.R index 9d59f21b6e..62d4e310a7 100644 --- a/R/geom-hline.R +++ b/R/geom-hline.R @@ -3,21 +3,27 @@ NULL #' @export #' @rdname geom_abline -geom_hline <- function(mapping = NULL, data = NULL, - position = "identity", - ..., - yintercept, - na.rm = FALSE, - show.legend = NA) { - +geom_hline <- function( + mapping = NULL, + data = NULL, + position = "identity", + ..., + yintercept, + na.rm = FALSE, + show.legend = NA +) { # Act like an annotation if (!missing(yintercept)) { # Warn if supplied mapping and/or data is going to be overwritten if (!is.null(mapping)) { - cli::cli_warn("{.fn geom_hline}: Ignoring {.arg mapping} because {.arg yintercept} was provided.") + cli::cli_warn( + "{.fn geom_hline}: Ignoring {.arg mapping} because {.arg yintercept} was provided." + ) } if (!is.null(data)) { - cli::cli_warn("{.fn geom_hline}: Ignoring {.arg data} because {.arg yintercept} was provided.") + cli::cli_warn( + "{.fn geom_hline}: Ignoring {.arg data} because {.arg yintercept} was provided." + ) } data <- data_frame0(yintercept = yintercept) @@ -44,16 +50,23 @@ geom_hline <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomHline <- ggproto("GeomHline", Geom, +GeomHline <- ggproto( + "GeomHline", + Geom, draw_panel = function(data, panel_params, coord, lineend = "butt") { ranges <- coord$backtransform_range(panel_params) - data$x <- ranges$x[1] + data$x <- ranges$x[1] data$xend <- ranges$x[2] - data$y <- data$yintercept + data$y <- data$yintercept data$yend <- data$yintercept - GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) + GeomSegment$draw_panel( + unique0(data), + panel_params, + coord, + lineend = lineend + ) }, default_aes = aes( diff --git a/R/geom-jitter.R b/R/geom-jitter.R index 1f4b3e99c9..20af42415d 100644 --- a/R/geom-jitter.R +++ b/R/geom-jitter.R @@ -33,14 +33,18 @@ #' geom_jitter() #' ggplot(mpg, aes(cty, hwy)) + #' geom_jitter(width = 0.5, height = 0.5) -geom_jitter <- function(mapping = NULL, data = NULL, - stat = "identity", position = "jitter", - ..., - width = NULL, - height = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_jitter <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "jitter", + ..., + width = NULL, + height = NULL, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { if (!missing(width) || !missing(height)) { if (!missing(position)) { cli::cli_abort(c( diff --git a/R/geom-label.R b/R/geom-label.R index f250089435..27eaf84325 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -10,22 +10,25 @@ #' @param text.colour,text.color Colour of the text. When `NULL` (default), the #' `colour` aesthetic determines the colour of the text. `text.color` is an #' alias for `text.colour`. -geom_label <- function(mapping = NULL, data = NULL, - stat = "identity", position = "nudge", - ..., - parse = FALSE, - label.padding = unit(0.25, "lines"), - label.r = unit(0.15, "lines"), - label.size = deprecated(), - border.colour = NULL, - border.color = NULL, - text.colour = NULL, - text.color = NULL, - size.unit = "mm", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - +geom_label <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "nudge", + ..., + parse = FALSE, + label.padding = unit(0.25, "lines"), + label.r = unit(0.15, "lines"), + label.size = deprecated(), + border.colour = NULL, + border.color = NULL, + text.colour = NULL, + text.color = NULL, + size.unit = "mm", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { extra_args <- list2(...) if (lifecycle::is_present(label.size)) { deprecate_soft0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)") @@ -57,7 +60,9 @@ geom_label <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomLabel <- ggproto("GeomLabel", Geom, +GeomLabel <- ggproto( + "GeomLabel", + Geom, required_aes = c("x", "y", "label"), default_aes = aes( @@ -66,19 +71,28 @@ GeomLabel <- ggproto("GeomLabel", Geom, family = from_theme(family), size = from_theme(fontsize), angle = 0, - hjust = 0.5, vjust = 0.5, alpha = NA, fontface = 1, + hjust = 0.5, + vjust = 0.5, + alpha = NA, + fontface = 1, lineheight = 1.2, linewidth = from_theme(borderwidth * 0.5), - linetype = from_theme(bordertype) + linetype = from_theme(bordertype) ), - draw_panel = function(self, data, panel_params, coord, parse = FALSE, - na.rm = FALSE, - label.padding = unit(0.25, "lines"), - label.r = unit(0.15, "lines"), - border.colour = NULL, - text.colour = NULL, - size.unit = "mm") { + draw_panel = function( + self, + data, + panel_params, + coord, + parse = FALSE, + na.rm = FALSE, + label.padding = unit(0.25, "lines"), + label.r = unit(0.15, "lines"), + border.colour = NULL, + text.colour = NULL, + size.unit = "mm" + ) { lab <- data$label if (parse) { lab <- parse_safe(as.character(lab)) @@ -92,16 +106,16 @@ GeomLabel <- ggproto("GeomLabel", Geom, } size.unit <- resolve_text_unit(size.unit) - data$text.colour <- text.colour %||% data$colour + data$text.colour <- text.colour %||% data$colour data$border.colour <- border.colour %||% data$colour data$border.colour[data$linewidth == 0] <- NA data$fill <- fill_alpha(data$fill, data$alpha) data$size <- data$size * size.unit - grobs <- lapply(seq_len(nrow(data)), function(i) { row <- data[i, , drop = FALSE] - labelGrob(lab[i], + labelGrob( + lab[i], x = unit(row$x, "native"), y = unit(row$y, "native"), just = c(row$hjust, row$vjust), @@ -131,24 +145,38 @@ GeomLabel <- ggproto("GeomLabel", Geom, draw_key = draw_key_label ) -labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), - just = "center", padding = unit(0.25, "lines"), r = unit(0.1, "snpc"), - angle = NULL, default.units = "npc", name = NULL, - text.gp = gpar(), rect.gp = gg_par(fill = "white"), vp = NULL) { - +labelGrob <- function( + label, + x = unit(0.5, "npc"), + y = unit(0.5, "npc"), + just = "center", + padding = unit(0.25, "lines"), + r = unit(0.1, "snpc"), + angle = NULL, + default.units = "npc", + name = NULL, + text.gp = gpar(), + rect.gp = gg_par(fill = "white"), + vp = NULL +) { if (length(label) != 1) { cli::cli_abort("{.arg label} must be of length 1.") } - if (!is.unit(x)) + if (!is.unit(x)) { x <- unit(x, default.units) - if (!is.unit(y)) + } + if (!is.unit(y)) { y <- unit(y, default.units) + } if (!is.null(angle) & is.null(vp)) { vp <- viewport( - angle = angle, x = x, y = y, - width = unit(0, "cm"), height = unit(0, "cm"), + angle = angle, + x = x, + y = y, + width = unit(0, "cm"), + height = unit(0, "cm"), gp = gg_par(fontsize = text.gp$fontsize) ) x <- unit(rep(0.5, length(x)), "npc") @@ -156,7 +184,10 @@ labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), } descent <- font_descent( - text.gp$fontfamily, text.gp$fontface, text.gp$fontsize, text.gp$cex + text.gp$fontfamily, + text.gp$fontface, + text.gp$fontsize, + text.gp$cex ) # To balance labels, we ensure the top includes at least the descent height # and subtract the descent height from the bottom padding @@ -167,19 +198,27 @@ labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), vjust <- resolveVJust(just, NULL) text <- titleGrob( - label = label, hjust = hjust, vjust = vjust, x = x, + label = label, + hjust = hjust, + vjust = vjust, + x = x, y = y + (1 - vjust) * descent, - margin = padding, margin_x = TRUE, margin_y = TRUE, + margin = padding, + margin_x = TRUE, + margin_y = TRUE, gp = text.gp ) height <- heightDetails(text) box <- roundrectGrob( - x = x, y = y + (0.5 - vjust) * height, - width = widthDetails(text), + x = x, + y = y + (0.5 - vjust) * height, + width = widthDetails(text), height = height, - just = c(hjust, 0.5), - r = r, gp = rect.gp, name = "box" + just = c(hjust, 0.5), + r = r, + gp = rect.gp, + name = "box" ) gTree(children = gList(box, text), name = name, vp = vp) diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 0d67908ec8..1378d44d55 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export GeomLinerange <- ggproto( - "GeomLinerange", Geom, + "GeomLinerange", + Geom, default_aes = GeomPath$default_aes, @@ -12,10 +13,19 @@ GeomLinerange <- ggproto( required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), setup_params = function(data, params) { - params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + range_is_orthogonal = TRUE + ) # if flipped_aes == TRUE then y, xmin, xmax is present - if (!(params$flipped_aes || all(c("x", "ymin", "ymax") %in% c(names(data), names(params))))) { - cli::cli_abort("Either, {.field x}, {.field ymin}, and {.field ymax} {.emph or} {.field y}, {.field xmin}, and {.field xmax} must be supplied.") + if ( + !(params$flipped_aes || + all(c("x", "ymin", "ymax") %in% c(names(data), names(params)))) + ) { + cli::cli_abort( + "Either, {.field x}, {.field ymin}, and {.field ymax} {.emph or} {.field y}, {.field xmin}, and {.field xmax} must be supplied." + ) } params }, @@ -27,11 +37,27 @@ GeomLinerange <- ggproto( data }, - draw_panel = function(data, panel_params, coord, lineend = "butt", flipped_aes = FALSE, na.rm = FALSE) { + draw_panel = function( + data, + panel_params, + coord, + lineend = "butt", + flipped_aes = FALSE, + na.rm = FALSE + ) { data <- flip_data(data, flipped_aes) data <- transform(data, xend = x, y = ymin, yend = ymax) data <- flip_data(data, flipped_aes) - ggname("geom_linerange", GeomSegment$draw_panel(data, panel_params, coord, lineend = lineend, na.rm = na.rm)) + ggname( + "geom_linerange", + GeomSegment$draw_panel( + data, + panel_params, + coord, + lineend = lineend, + na.rm = na.rm + ) + ) }, rename_size = TRUE diff --git a/R/geom-map.R b/R/geom-map.R index 026bb94e6b..8883979fbf 100644 --- a/R/geom-map.R +++ b/R/geom-map.R @@ -89,20 +89,31 @@ NULL #' ) + #' facet_wrap(~variable) #' } -geom_map <- function(mapping = NULL, data = NULL, - stat = "identity", - ..., - map, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_map <- function( + mapping = NULL, + data = NULL, + stat = "identity", + ..., + map, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { # Get map input into correct form check_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 (!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))) { - cli::cli_abort("{.arg map} must have the columns {.col x}, {.col y}, and {.col id}.") + cli::cli_abort( + "{.arg map} must have the columns {.col x}, {.col y}, and {.col id}." + ) } layer( @@ -125,9 +136,18 @@ geom_map <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomMap <- ggproto("GeomMap", GeomPolygon, - draw_panel = function(data, panel_params, coord, lineend = "butt", - linejoin = "round", linemitre = 10, map) { +GeomMap <- ggproto( + "GeomMap", + GeomPolygon, + 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] @@ -143,7 +163,11 @@ GeomMap <- ggproto("GeomMap", GeomPolygon, data_rows <- match(coords$id[!duplicated(grob_id)], data$map_id) data <- data[data_rows, , drop = FALSE] - polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id, + polygonGrob( + coords$x, + coords$y, + default.units = "native", + id = grob_id, gp = gg_par( col = data$colour, fill = fill_alpha(data$fill, data$alpha), diff --git a/R/geom-path.R b/R/geom-path.R index 9688e9e2c2..18d9d849f0 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -2,7 +2,9 @@ #' @format NULL #' @usage NULL #' @export -GeomPath <- ggproto("GeomPath", Geom, +GeomPath <- ggproto( + "GeomPath", + Geom, required_aes = c("x", "y"), default_aes = aes( @@ -32,9 +34,18 @@ GeomPath <- ggproto("GeomPath", Geom, data }, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", linemitre = 10, - na.rm = FALSE) { + draw_panel = function( + self, + data, + panel_params, + coord, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, + na.rm = FALSE + ) { data <- fix_linewidth(data, snake_class(self)) if (!anyDuplicated(data$group)) { cli::cli_inform(c( @@ -50,38 +61,49 @@ GeomPath <- ggproto("GeomPath", Geom, # Silently drop lines with less than two points, preserving order rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length) munched <- munched[rows >= 2, ] - if (nrow(munched) < 2) return(zeroGrob()) + if (nrow(munched) < 2) { + return(zeroGrob()) + } # Work out whether we should use lines or segments attr <- dapply(munched, "group", function(df) { linetype <- unique0(df$linetype) data_frame0( - solid = length(linetype) == 1 && (identical(linetype, "solid") || linetype == 1), - constant = nrow(unique0(df[, names(df) %in% c("alpha", "colour", "linewidth", "linetype")])) == 1, + solid = length(linetype) == 1 && + (identical(linetype, "solid") || linetype == 1), + constant = nrow(unique0(df[, + names(df) %in% c("alpha", "colour", "linewidth", "linetype") + ])) == + 1, .size = 1 ) }) solid_lines <- all(attr$solid) constant <- all(attr$constant) if (!solid_lines && !constant) { - cli::cli_abort("{.fn {snake_class(self)}} can't have varying {.field colour}, {.field linewidth}, and/or {.field alpha} along the line when {.field linetype} isn't solid.") + cli::cli_abort( + "{.fn {snake_class(self)}} can't have varying {.field colour}, {.field linewidth}, and/or {.field alpha} along the line when {.field linetype} isn't solid." + ) } # Work out grouping variables for grobs n <- nrow(munched) group_diff <- munched$group[-1] != munched$group[-n] start <- c(TRUE, group_diff) - end <- c(group_diff, TRUE) + end <- c(group_diff, TRUE) munched$fill <- arrow.fill %||% munched$colour if (!constant) { - arrow <- repair_segment_arrow(arrow, munched$group) segmentsGrob( - munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start], - default.units = "native", arrow = arrow, + munched$x[!end], + munched$y[!end], + munched$x[!start], + munched$y[!start], + default.units = "native", + arrow = arrow, gp = gg_par( col = alpha(munched$colour, munched$alpha)[!end], fill = alpha(munched$fill, munched$alpha)[!end], @@ -95,8 +117,11 @@ GeomPath <- ggproto("GeomPath", Geom, } else { id <- match(munched$group, unique0(munched$group)) polylineGrob( - munched$x, munched$y, id = id, - default.units = "native", arrow = arrow, + munched$x, + munched$y, + id = id, + default.units = "native", + arrow = arrow, gp = gg_par( col = alpha(munched$colour, munched$alpha)[start], fill = alpha(munched$fill, munched$alpha)[start], @@ -121,7 +146,8 @@ GeomPath <- ggproto("GeomPath", Geom, #' @export #' @include geom-path.R GeomLine <- ggproto( - "GeomLine", GeomPath, + "GeomLine", + GeomPath, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) params @@ -143,16 +169,25 @@ GeomLine <- ggproto( #' @export #' @include geom-path.R GeomStep <- ggproto( - "GeomStep", GeomPath, + "GeomStep", + GeomPath, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) params }, extra_params = c("na.rm", "orientation"), - draw_panel = function(data, panel_params, coord, - lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL, - direction = "hv", flipped_aes = FALSE) { + draw_panel = function( + data, + panel_params, + coord, + lineend = "butt", + linejoin = "round", + linemitre = 10, + arrow = NULL, + arrow.fill = NULL, + direction = "hv", + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) if (isTRUE(flipped_aes)) { direction <- switch(direction, hv = "vh", vh = "hv", direction) @@ -160,9 +195,14 @@ GeomStep <- ggproto( data <- dapply(data, "group", stairstep, direction = direction) data <- flip_data(data, flipped_aes) GeomPath$draw_panel( - data, panel_params, coord, - lineend = lineend, linejoin = linejoin, linemitre = linemitre, - arrow = arrow, arrow.fill = arrow.fill + data, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre, + arrow = arrow, + arrow.fill = arrow.fill ) } ) @@ -310,22 +350,22 @@ stairstep <- function(data, direction = "hv") { } if (direction == "vh") { - xs <- rep(1:n, each = 2)[-2*n] + xs <- rep(1:n, each = 2)[-2 * n] ys <- c(1, rep(2:n, each = 2)) } else if (direction == "hv") { - ys <- rep(1:n, each = 2)[-2*n] + ys <- rep(1:n, each = 2)[-2 * n] xs <- c(1, rep(2:n, each = 2)) } else if (direction == "mid") { - xs <- rep(1:(n-1), each = 2) + xs <- rep(1:(n - 1), each = 2) ys <- rep(1:n, each = 2) } if (direction == "mid") { gaps <- data$x[-1] - data$x[-n] - mid_x <- data$x[-n] + gaps/2 # map the mid-point between adjacent x-values + mid_x <- data$x[-n] + gaps / 2 # map the mid-point between adjacent x-values x <- c(data$x[1], mid_x[xs], data$x[n]) y <- c(data$y[ys]) - data_attr <- data[c(1,xs,n), setdiff(names(data), c("x", "y"))] + data_attr <- data[c(1, xs, n), setdiff(names(data), c("x", "y"))] } else { x <- data$x[xs] y <- data$y[ys] @@ -342,15 +382,15 @@ repair_segment_arrow <- function(arrow, group) { } # Get group parameters - rle <- vec_group_rle(group) # handles NAs better than base::rle() - n_groups <- length(rle) - rle_len <- field(rle, "length") - 1 # segments have 1 member less than lines - rle_end <- cumsum(rle_len) + rle <- vec_group_rle(group) # handles NAs better than base::rle() + n_groups <- length(rle) + rle_len <- field(rle, "length") - 1 # segments have 1 member less than lines + rle_end <- cumsum(rle_len) rle_start <- rle_end - rle_len + 1 # Recycle ends and lengths - ends <- rep(rep(arrow$ends, length.out = n_groups), rle_len) - len <- rep(rep(arrow$length, length.out = n_groups), rle_len) + ends <- rep(rep(arrow$ends, length.out = n_groups), rle_len) + len <- rep(rep(arrow$length, length.out = n_groups), rle_len) # Repair ends # Convert 'both' ends to first/last in multi-member groups diff --git a/R/geom-point.R b/R/geom-point.R index f03d1a9917..8b05ab4203 100644 --- a/R/geom-point.R +++ b/R/geom-point.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export GeomPoint <- ggproto( - "GeomPoint", Geom, + "GeomPoint", + Geom, required_aes = c("x", "y"), non_missing_aes = c("size", "shape", "colour"), default_aes = aes( @@ -21,7 +22,8 @@ GeomPoint <- ggproto( ggname( "geom_point", pointsGrob( - coords$x, coords$y, + coords$x, + coords$y, pch = coords$shape, gp = gg_par( col = alpha(coords$colour, coords$alpha), @@ -182,33 +184,33 @@ translate_shape_string <- function(shape_string) { } pch_table <- c( - "square open" = 0, - "circle open" = 1, - "triangle open" = 2, - "plus" = 3, - "cross" = 4, - "diamond open" = 5, - "triangle down open" = 6, - "square cross" = 7, - "asterisk" = 8, - "diamond plus" = 9, - "circle plus" = 10, - "star" = 11, - "square plus" = 12, - "circle cross" = 13, - "square triangle" = 14, - "triangle square" = 14, - "square" = 15, - "circle small" = 16, - "triangle" = 17, - "diamond" = 18, - "circle" = 19, - "bullet" = 20, - "circle filled" = 21, - "square filled" = 22, - "diamond filled" = 23, - "triangle filled" = 24, - "triangle down filled" = 25 + "square open" = 0, + "circle open" = 1, + "triangle open" = 2, + "plus" = 3, + "cross" = 4, + "diamond open" = 5, + "triangle down open" = 6, + "square cross" = 7, + "asterisk" = 8, + "diamond plus" = 9, + "circle plus" = 10, + "star" = 11, + "square plus" = 12, + "circle cross" = 13, + "square triangle" = 14, + "triangle square" = 14, + "square" = 15, + "circle small" = 16, + "triangle" = 17, + "diamond" = 18, + "circle" = 19, + "bullet" = 20, + "circle filled" = 21, + "square filled" = 22, + "diamond filled" = 23, + "triangle filled" = 24, + "triangle down filled" = 25 ) shape_match <- charmatch(shape_string, names(pch_table)) @@ -218,7 +220,9 @@ translate_shape_string <- function(shape_string) { if (any(invalid_strings)) { bad_string <- unique0(shape_string[invalid_strings]) - cli::cli_abort("Shape aesthetic contains invalid value{?s}: {.val {bad_string}}.") + cli::cli_abort( + "Shape aesthetic contains invalid value{?s}: {.val {bad_string}}." + ) } if (any(nonunique_strings)) { diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index 4f3603f485..83754c76be 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -2,11 +2,17 @@ #' @format NULL #' @usage NULL #' @export -GeomPointrange <- ggproto("GeomPointrange", Geom, +GeomPointrange <- ggproto( + "GeomPointrange", + Geom, default_aes = aes( - colour = from_theme(colour %||% ink), size = from_theme(pointsize / 3), - linewidth = from_theme(linewidth), linetype = from_theme(linetype), - shape = from_theme(pointshape), fill = from_theme(fill %||% NA), alpha = NA, + colour = from_theme(colour %||% ink), + size = from_theme(pointsize / 3), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + shape = from_theme(pointshape), + fill = from_theme(fill %||% NA), + alpha = NA, stroke = from_theme(borderwidth * 2) ), @@ -16,7 +22,11 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, setup_params = function(data, params) { if (lifecycle::is_present(params$fatten %||% deprecated())) { - deprecate_soft0("4.0.0", "geom_pointrange(fatten)", I("the `size` aesthetic")) + deprecate_soft0( + "4.0.0", + "geom_pointrange(fatten)", + I("the `size` aesthetic") + ) } else { # For backward compatibility reasons params$fatten <- 4 @@ -30,23 +40,40 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, GeomLinerange$setup_data(data, params) }, - draw_panel = function(data, panel_params, coord, lineend = "butt", fatten = 4, - flipped_aes = FALSE, na.rm = FALSE) { + draw_panel = function( + data, + panel_params, + coord, + lineend = "butt", + fatten = 4, + flipped_aes = FALSE, + na.rm = FALSE + ) { line_grob <- GeomLinerange$draw_panel( - data, panel_params, coord, lineend = lineend, flipped_aes = flipped_aes, + data, + panel_params, + coord, + lineend = lineend, + flipped_aes = flipped_aes, na.rm = na.rm ) - if (is.null(data[[flipped_names(flipped_aes)$y]])) + if (is.null(data[[flipped_names(flipped_aes)$y]])) { return(line_grob) + } - ggname("geom_pointrange", - gTree(children = gList( - line_grob, - GeomPoint$draw_panel( - transform(data, size = size * fatten), - panel_params, coord, na.rm = na.rm + ggname( + "geom_pointrange", + gTree( + children = gList( + line_grob, + GeomPoint$draw_panel( + transform(data, size = size * fatten), + panel_params, + coord, + na.rm = na.rm + ) ) - )) + ) ) } ) @@ -55,5 +82,6 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, #' @rdname geom_linerange geom_pointrange <- make_constructor( GeomPointrange, - orientation = NA, fatten = deprecated() + orientation = NA, + fatten = deprecated() ) diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 12dab3ce84..1bb3b0b138 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -5,12 +5,24 @@ NULL #' @format NULL #' @usage NULL #' @export -GeomPolygon <- ggproto("GeomPolygon", Geom, - draw_panel = function(self, data, panel_params, coord, rule = "evenodd", - lineend = "butt", linejoin = "round", linemitre = 10) { +GeomPolygon <- ggproto( + "GeomPolygon", + Geom, + draw_panel = function( + self, + data, + panel_params, + coord, + rule = "evenodd", + lineend = "butt", + linejoin = "round", + linemitre = 10 + ) { data <- fix_linewidth(data, snake_class(self)) n <- nrow(data) - if (n == 1) return(zeroGrob()) + if (n == 1) { + return(zeroGrob()) + } munched <- coord_munch(coord, data, panel_params, is_closed = TRUE) @@ -27,7 +39,9 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, ggname( "geom_polygon", polygonGrob( - munched$x, munched$y, default.units = "native", + munched$x, + munched$y, + default.units = "native", id = munched$group, gp = gg_par( col = first_rows$colour, @@ -57,8 +71,11 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, ggname( "geom_polygon", pathGrob( - munched$x, munched$y, default.units = "native", - id = id, pathId = munched$group, + munched$x, + munched$y, + default.units = "native", + id = id, + pathId = munched$group, rule = rule, gp = gg_par( col = first_rows$colour, @@ -79,7 +96,8 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), linewidth = from_theme(borderwidth), linetype = from_theme(bordertype), - alpha = NA, subgroup = NULL + alpha = NA, + subgroup = NULL ), handle_na = function(data, params) { diff --git a/R/geom-quantile.R b/R/geom-quantile.R index 99d569538f..9a47b30bf8 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -4,11 +4,14 @@ #' @export #' @include geom-path.R GeomQuantile <- ggproto( - "GeomQuantile", GeomPath, - default_aes = aes(!!!defaults( - aes(weight = 1, colour = from_theme(colour %||% accent)), - GeomPath$default_aes - )) + "GeomQuantile", + GeomPath, + default_aes = aes( + !!!defaults( + aes(weight = 1, colour = from_theme(colour %||% accent)), + GeomPath$default_aes + ) + ) ) #' Quantile regression diff --git a/R/geom-raster.R b/R/geom-raster.R index 79d8b6fc88..ba118f2ae6 100644 --- a/R/geom-raster.R +++ b/R/geom-raster.R @@ -5,7 +5,9 @@ NULL #' @format NULL #' @usage NULL #' @export -GeomRaster <- ggproto("GeomRaster", Geom, +GeomRaster <- ggproto( + "GeomRaster", + Geom, default_aes = aes( fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), alpha = NA @@ -50,8 +52,15 @@ GeomRaster <- ggproto("GeomRaster", Geom, data }, - draw_panel = function(self, data, panel_params, coord, interpolate = FALSE, - hjust = 0.5, vjust = 0.5) { + draw_panel = function( + self, + data, + panel_params, + coord, + interpolate = FALSE, + hjust = 0.5, + vjust = 0.5 + ) { if (!coord$is_linear()) { cli::cli_inform(c( "{.fn {snake_class(self)}} only works with linear coordinate systems, \\ @@ -84,10 +93,14 @@ GeomRaster <- ggproto("GeomRaster", Geom, x_rng <- c(min(data$xmin, na.rm = TRUE), max(data$xmax, na.rm = TRUE)) y_rng <- c(min(data$ymin, na.rm = TRUE), max(data$ymax, na.rm = TRUE)) - rasterGrob(raster, - x = mean(x_rng), y = mean(y_rng), - width = diff(x_rng), height = diff(y_rng), - default.units = "native", interpolate = interpolate + rasterGrob( + raster, + x = mean(x_rng), + y = mean(y_rng), + width = diff(x_rng), + height = diff(y_rng), + default.units = "native", + interpolate = interpolate ) }, draw_key = draw_key_polygon diff --git a/R/geom-rect.R b/R/geom-rect.R index 1e8ec2227c..5f8dd99944 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -2,11 +2,14 @@ #' @format NULL #' @usage NULL #' @export -GeomRect <- ggproto("GeomRect", Geom, +GeomRect <- ggproto( + "GeomRect", + Geom, default_aes = aes( colour = from_theme(colour %||% NA), fill = from_theme(fill %||% col_mix(ink, paper, 0.35)), - linewidth = from_theme(borderwidth), linetype = from_theme(bordertype), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), alpha = NA ), @@ -19,24 +22,30 @@ GeomRect <- ggproto("GeomRect", Geom, # Fill in missing aesthetics from parameters required <- strsplit(self$required_aes, "|", fixed = TRUE) - missing <- setdiff(unlist(required), names(data)) + missing <- setdiff(unlist(required), names(data)) default <- params[intersect(missing, names(params))] data[names(default)] <- default if (is.null(data$xmin) || is.null(data$xmax)) { x <- resolve_rect( - data[["xmin"]], data[["xmax"]], - data[["x"]], data[["width"]], - fun = snake_class(self), type = "x" + data[["xmin"]], + data[["xmax"]], + data[["x"]], + data[["width"]], + fun = snake_class(self), + type = "x" ) i <- lengths(x) > 1 data[c("xmin", "xmax")[i]] <- x[i] } if (is.null(data$ymin) || is.null(data$ymax)) { y <- resolve_rect( - data[["ymin"]], data[["ymax"]], - data[["y"]], data[["height"]], - fun = snake_class(self), type = "y" + data[["ymin"]], + data[["ymax"]], + data[["y"]], + data[["height"]], + fun = snake_class(self), + type = "y" ) i <- lengths(y) > 1 data[c("ymin", "ymax")[i]] <- y[i] @@ -44,11 +53,19 @@ GeomRect <- ggproto("GeomRect", Geom, data }, - draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") { + draw_panel = function( + self, + data, + panel_params, + coord, + lineend = "butt", + linejoin = "mitre" + ) { data <- fix_linewidth(data, snake_class(self)) if (!coord$is_linear()) { aesthetics <- setdiff( - names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax") + names(data), + c("x", "y", "xmin", "xmax", "ymin", "ymax") ) index <- rep(seq_len(nrow(data)), each = 4) @@ -57,26 +74,37 @@ GeomRect <- ggproto("GeomRect", Geom, new$y <- vec_interleave(data$ymax, data$ymax, data$ymin, data$ymin) new$group <- index - ggname("geom_rect", GeomPolygon$draw_panel( - new, panel_params, coord, lineend = lineend, linejoin = linejoin - )) + ggname( + "geom_rect", + GeomPolygon$draw_panel( + new, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin + ) + ) } else { coords <- coord$transform(data, panel_params) - ggname("geom_rect", rectGrob( - coords$xmin, coords$ymax, - width = coords$xmax - coords$xmin, - height = coords$ymax - coords$ymin, - default.units = "native", - just = c("left", "top"), - gp = gg_par( - col = coords$colour, - fill = fill_alpha(coords$fill, coords$alpha), - lwd = coords$linewidth, - lty = coords$linetype, - linejoin = linejoin, - lineend = lineend + ggname( + "geom_rect", + rectGrob( + coords$xmin, + coords$ymax, + width = coords$xmax - coords$xmin, + height = coords$ymax - coords$ymin, + default.units = "native", + just = c("left", "top"), + gp = gg_par( + col = coords$colour, + fill = fill_alpha(coords$fill, coords$alpha), + lwd = coords$linewidth, + lty = coords$linetype, + linejoin = linejoin, + lineend = lineend + ) ) - )) + ) } }, @@ -89,8 +117,14 @@ GeomRect <- ggproto("GeomRect", Geom, #' @rdname geom_tile geom_rect <- make_constructor(GeomRect) -resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL, - fun, type) { +resolve_rect <- function( + min = NULL, + max = NULL, + center = NULL, + length = NULL, + fun, + type +) { absent <- c(is.null(min), is.null(max), is.null(center), is.null(length)) if (sum(absent) > 2) { missing <- switch( diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index 805f0c6aa9..2d3b66c8c9 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -2,7 +2,9 @@ #' @format NULL #' @usage NULL #' @export -GeomRibbon <- ggproto("GeomRibbon", Geom, +GeomRibbon <- ggproto( + "GeomRibbon", + Geom, default_aes = aes( colour = from_theme(colour %||% NA), @@ -15,7 +17,11 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), setup_params = function(data, params) { - params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + range_is_orthogonal = TRUE + ) params }, @@ -26,7 +32,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, data <- flip_data(data, params$flipped_aes) if (is.null(data$ymin) && is.null(data$ymax)) { - cli::cli_abort("Either {.field {flipped_names(params$flipped_aes)$ymin}} or {.field {flipped_names(params$flipped_aes)$ymax}} must be given as an aesthetic.") + cli::cli_abort( + "Either {.field {flipped_names(params$flipped_aes)$ymin}} or {.field {flipped_names(params$flipped_aes)$ymax}} must be given as an aesthetic." + ) } data <- data[order(data$PANEL, data$group, data$x), , drop = FALSE] data$y <- data$ymin %||% data$ymax @@ -36,10 +44,11 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, draw_key = draw_key_polygon, handle_na = function(self, data, params) { - vars <- vapply( strsplit(self$required_aes, "|", fixed = TRUE), - `[[`, i = 1, character(1) + `[[`, + i = 1, + character(1) ) if (isTRUE(params$flipped_aes || any(data$flipped_aes) %||% FALSE)) { vars <- switch_orientation(vars) @@ -63,16 +72,27 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, data }, - draw_group = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "round", linemitre = 10, 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 <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) data <- data[order(data$group), ] # Check that aesthetics are constant aes <- lapply( - data[names(data) %in% c("colour", "fill", "linewidth", "linetype", "alpha")], + data[ + names(data) %in% c("colour", "fill", "linewidth", "linetype", "alpha") + ], unique0 ) non_constant <- names(aes)[lengths(aes) > 1] @@ -96,14 +116,20 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, args <- list( colours = alpha(data$fill, data$alpha)[keep], stops = rescale(transformed$y)[keep], - y1 = 0, y2 = 1, x1 = 0.5, x2 = 0.5 + y1 = 0, + y2 = 1, + x1 = 0.5, + x2 = 0.5 ) } else { keep <- is.finite(transformed$x) args <- list( colours = alpha(data$fill, data$alpha)[keep], stops = rescale(transformed$x)[keep], - x1 = 0, x2 = 1, y1 = 0.5, y2 = 0.5 + x1 = 0, + x2 = 1, + y1 = 0.5, + y2 = 0.5 ) } aes$fill <- inject(linearGradient(!!!args)) @@ -149,7 +175,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, is_full_outline <- identical(outline.type, "full") g_poly <- polygonGrob( - munched_poly$x, munched_poly$y, id = munched_poly$id, + munched_poly$x, + munched_poly$y, + id = munched_poly$id, default.units = "native", gp = gg_par( fill = fill_alpha(aes$fill, aes$alpha), @@ -174,13 +202,16 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, c("both", "upper", "lower") ) - munched_lines <- switch(outline.type, + munched_lines <- switch( + outline.type, both = vec_rbind0(munched_upper, munched_lower), upper = munched_upper, lower = munched_lower ) g_lines <- polylineGrob( - munched_lines$x, munched_lines$y, id = munched_lines$id, + munched_lines$x, + munched_lines$y, + id = munched_lines$id, default.units = "native", gp = gg_par( col = aes$colour, @@ -202,7 +233,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, #' @format NULL #' @usage NULL #' @export -GeomArea <- ggproto("GeomArea", GeomRibbon, +GeomArea <- ggproto( + "GeomArea", + GeomRibbon, required_aes = c("x", "y"), @@ -214,7 +247,11 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, setup_data = function(data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data <- transform(data[order(data$PANEL, data$group, data$x), ], ymin = 0, ymax = y) + data <- transform( + data[order(data$PANEL, data$group, data$x), ], + ymin = 0, + ymax = y + ) flip_data(data, params$flipped_aes) } ) @@ -288,18 +325,28 @@ GeomArea <- ggproto("GeomArea", GeomRibbon, #' geom_area(stat = "identity") #' geom_ribbon <- make_constructor( - GeomRibbon, orientation = NA, + GeomRibbon, + orientation = NA, checks = exprs( - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + outline.type <- arg_match0( + outline.type, + c("both", "upper", "lower", "full") + ) ) ) #' @rdname geom_ribbon #' @export geom_area <- make_constructor( - GeomArea, stat = "align", position = "stack", - orientation = NA, outline.type = "upper", + GeomArea, + stat = "align", + position = "stack", + orientation = NA, + outline.type = "upper", checks = exprs( - outline.type <- arg_match0(outline.type, c("both", "upper", "lower", "full")) + outline.type <- arg_match0( + outline.type, + c("both", "upper", "lower", "full") + ) ) ) diff --git a/R/geom-rug.R b/R/geom-rug.R index 2f2b37cd2d..a6eaf13aef 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -2,11 +2,21 @@ #' @format NULL #' @usage NULL #' @export -GeomRug <- ggproto("GeomRug", Geom, +GeomRug <- ggproto( + "GeomRug", + Geom, optional_aes = c("x", "y"), - draw_panel = function(self, data, panel_params, coord, lineend = "butt", - sides = "bl", outside = FALSE, length = unit(0.03, "npc")) { + draw_panel = function( + self, + data, + panel_params, + coord, + lineend = "butt", + sides = "bl", + outside = FALSE, + length = unit(0.03, "npc") + ) { data <- fix_linewidth(data, snake_class(self)) check_inherits(length, "unit") rugs <- list() @@ -34,16 +44,20 @@ GeomRug <- ggproto("GeomRug", Geom, if (!is.null(data$x)) { if (grepl("b", sides)) { rugs$x_b <- segmentsGrob( - x0 = unit(data$x, "native"), x1 = unit(data$x, "native"), - y0 = unit(0, "npc"), y1 = rug_length$min, + x0 = unit(data$x, "native"), + x1 = unit(data$x, "native"), + y0 = unit(0, "npc"), + y1 = rug_length$min, gp = gp ) } if (grepl("t", sides)) { rugs$x_t <- segmentsGrob( - x0 = unit(data$x, "native"), x1 = unit(data$x, "native"), - y0 = unit(1, "npc"), y1 = rug_length$max, + x0 = unit(data$x, "native"), + x1 = unit(data$x, "native"), + y0 = unit(1, "npc"), + y1 = rug_length$max, gp = gp ) } @@ -52,16 +66,20 @@ GeomRug <- ggproto("GeomRug", Geom, if (!is.null(data$y)) { if (grepl("l", sides)) { rugs$y_l <- segmentsGrob( - y0 = unit(data$y, "native"), y1 = unit(data$y, "native"), - x0 = unit(0, "npc"), x1 = rug_length$min, + y0 = unit(data$y, "native"), + y1 = unit(data$y, "native"), + x0 = unit(0, "npc"), + x1 = rug_length$min, gp = gp ) } if (grepl("r", sides)) { rugs$y_r <- segmentsGrob( - y0 = unit(data$y, "native"), y1 = unit(data$y, "native"), - x0 = unit(1, "npc"), x1 = rug_length$max, + y0 = unit(data$y, "native"), + y1 = unit(data$y, "native"), + x0 = unit(1, "npc"), + x1 = rug_length$max, gp = gp ) } @@ -97,7 +115,8 @@ GeomRug <- ggproto("GeomRug", Geom, sides_aes, function(axis) { remove_missing( - data, params$na.rm, + data, + params$na.rm, c(axis, self$required_aes, self$non_missing_aes), snake_class(self) ) @@ -111,7 +130,8 @@ GeomRug <- ggproto("GeomRug", Geom, ) } else { data <- remove_missing( - data, params$na.rm, + data, + params$na.rm, c(self$required_aes, self$non_missing_aes), snake_class(self) ) diff --git a/R/geom-segment.R b/R/geom-segment.R index 77ca127a44..5ea10cb448 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -3,50 +3,76 @@ #' @usage NULL #' @export GeomSegment <- ggproto( - "GeomSegment", Geom, + "GeomSegment", + Geom, required_aes = c("x", "y", "xend|yend"), non_missing_aes = c("linetype", "linewidth"), default_aes = GeomPath$default_aes, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, - lineend = "butt", linejoin = "round", na.rm = FALSE) { + draw_panel = function( + self, + data, + panel_params, + coord, + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + na.rm = FALSE + ) { data$xend <- data$xend %||% data$x data$yend <- data$yend %||% data$y data <- fix_linewidth(data, snake_class(self)) - data <- remove_missing(data, na.rm = na.rm, - c("x", "y", "xend", "yend", "linetype", "linewidth"), - name = "geom_segment" + data <- remove_missing( + data, + na.rm = na.rm, + c("x", "y", "xend", "yend", "linetype", "linewidth"), + name = "geom_segment" ) - if (empty(data)) return(zeroGrob()) + if (empty(data)) { + return(zeroGrob()) + } if (coord$is_linear()) { coord <- coord$transform(data, panel_params) arrow.fill <- arrow.fill %||% coord$colour - return(segmentsGrob(coord$x, coord$y, coord$xend, coord$yend, - default.units = "native", - gp = gg_par( - col = alpha(coord$colour, coord$alpha), - fill = alpha(arrow.fill, coord$alpha), - lwd = coord$linewidth, - lty = coord$linetype, - lineend = lineend, - linejoin = linejoin - ), - arrow = arrow + return(segmentsGrob( + coord$x, + coord$y, + coord$xend, + coord$yend, + default.units = "native", + gp = gg_par( + col = alpha(coord$colour, coord$alpha), + fill = alpha(arrow.fill, coord$alpha), + lwd = coord$linewidth, + lty = coord$linetype, + lineend = lineend, + linejoin = linejoin + ), + arrow = arrow )) } data$group <- seq_len(nrow(data)) starts <- subset(data, select = c(-xend, -yend)) - ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y")) + ends <- rename( + subset(data, select = c(-x, -y)), + c("xend" = "x", "yend" = "y") + ) pieces <- vec_rbind0(starts, ends) - pieces <- pieces[order(pieces$group),] + pieces <- pieces[order(pieces$group), ] - GeomPath$draw_panel(pieces, panel_params, coord, arrow = arrow, - lineend = lineend) + GeomPath$draw_panel( + pieces, + panel_params, + coord, + arrow = arrow, + lineend = lineend + ) }, draw_key = draw_key_path, diff --git a/R/geom-sf.R b/R/geom-sf.R index 177c30f933..26c5a690e0 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -118,7 +118,9 @@ NULL #' @rdname ggsf #' @usage NULL #' @format NULL -GeomSf <- ggproto("GeomSf", Geom, +GeomSf <- ggproto( + "GeomSf", + Geom, required_aes = "geometry", default_aes = aes( shape = NULL, @@ -131,10 +133,22 @@ GeomSf <- ggproto("GeomSf", Geom, stroke = 0.5 ), - use_defaults = function(self, data, params = list(), modifiers = aes(), - default_aes = NULL, theme = NULL, ...) { + use_defaults = function( + self, + data, + params = list(), + modifiers = aes(), + default_aes = NULL, + theme = NULL, + ... + ) { data <- ggproto_parent(Geom, self)$use_defaults( - data, params, modifiers, default_aes, theme = theme, ... + data, + params, + modifiers, + default_aes, + theme = theme, + ... ) # Early exit for e.g. legend data that don't have geometry columns if (!"geometry" %in% names(data)) { @@ -159,19 +173,23 @@ GeomSf <- ggproto("GeomSf", Geom, if (length(index$point) > 0) { points <- GeomPoint$use_defaults( vec_slice(data, index$point), - params, modifiers, theme = theme + params, + modifiers, + theme = theme ) } if (length(index$line) > 0) { lines <- GeomLine$use_defaults( vec_slice(data, index$line), - params, modifiers, theme = theme + params, + modifiers, + theme = theme ) } other_default <- modify_list( GeomPolygon$default_aes, aes( - fill = from_theme(fill %||% col_mix(ink, paper, 0.899)), + fill = from_theme(fill %||% col_mix(ink, paper, 0.899)), colour = from_theme(colour %||% col_mix(ink, paper, 0.35)), linewidth = from_theme(0.4 * borderwidth) ) @@ -179,7 +197,8 @@ GeomSf <- ggproto("GeomSf", Geom, if (length(index$other) > 0) { others <- GeomPolygon$use_defaults( vec_slice(data, index$other), - params, modifiers, + params, + modifiers, default_aes = other_default, theme = theme ) @@ -192,7 +211,8 @@ GeomSf <- ggproto("GeomSf", Geom, modified <- modify_list(other_default, modified) collections <- Geom$use_defaults( vec_slice(data, index$collection), - params, modifiers, + params, + modifiers, default_aes = modified, theme = theme ) @@ -203,11 +223,23 @@ GeomSf <- ggproto("GeomSf", Geom, vec_slice(data, order(unlist(index))) }, - draw_panel = function(self, data, panel_params, coord, legend = NULL, - lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, arrow.fill = NULL, na.rm = TRUE) { + draw_panel = function( + self, + data, + panel_params, + coord, + legend = NULL, + lineend = "butt", + linejoin = "round", + linemitre = 10, + arrow = NULL, + arrow.fill = NULL, + na.rm = TRUE + ) { if (!inherits(coord, "CoordSf")) { - cli::cli_abort("{.fn {snake_class(self)}} can only be used with {.fn coord_sf}.") + cli::cli_abort( + "{.fn {snake_class(self)}} can only be used with {.fn coord_sf}." + ) } data$shape <- translate_shape_string(data$shape) @@ -215,7 +247,7 @@ GeomSf <- ggproto("GeomSf", Geom, type <- sf_types[sf::st_geometry_type(data$geometry)] is_point <- type == "point" - is_line <- type == "line" + is_line <- type == "line" is_collection <- type == "collection" fill <- fill_alpha(data$fill %||% rep(NA, nrow(data)), data$alpha) @@ -236,9 +268,14 @@ GeomSf <- ggproto("GeomSf", Geom, linewidth[is_point] <- stroke[is_point] gp <- gpar( - col = colour, fill = fill, fontsize = font_size, - lwd = linewidth, lty = data$linetype, - lineend = lineend, linejoin = linejoin, linemitre = linemitre + col = colour, + fill = fill, + fontsize = font_size, + lwd = linewidth, + lty = data$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre ) sf::st_as_grob(data$geometry, pch = data$shape, gp = gp, arrow = arrow) @@ -248,7 +285,7 @@ GeomSf <- ggproto("GeomSf", Geom, switch( params$legend %||% "other", point = draw_key_point(data, params, size), - line = draw_key_path(data, params, size), + line = draw_key_path(data, params, size), draw_key_polygon(data, params, size) ) }, @@ -264,7 +301,7 @@ GeomSf <- ggproto("GeomSf", Geom, } remove[types$point] <- get_missing(GeomPoint)[types$point] - remove[types$line] <- get_missing(GeomPath)[types$line] + remove[types$line] <- get_missing(GeomPath)[types$line] remove[types$other] <- get_missing(GeomPolygon)[types$other] remove <- remove | get_missing(self) @@ -286,9 +323,16 @@ GeomSf <- ggproto("GeomSf", Geom, #' @export #' @rdname ggsf #' @inheritParams geom_point -geom_sf <- function(mapping = aes(), data = NULL, stat = "sf", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) { +geom_sf <- function( + mapping = aes(), + data = NULL, + stat = "sf", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + ... +) { c( layer_sf( geom = GeomSf, @@ -311,22 +355,25 @@ geom_sf <- function(mapping = aes(), data = NULL, stat = "sf", #' @rdname ggsf #' @inheritParams geom_label #' @inheritParams stat_sf_coordinates -geom_sf_label <- function(mapping = aes(), data = NULL, - stat = "sf_coordinates", position = "nudge", - ..., - parse = FALSE, - label.padding = unit(0.25, "lines"), - label.r = unit(0.15, "lines"), - label.size = deprecated(), - border.colour = NULL, - border.color = NULL, - text.colour = NULL, - text.color = NULL, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE, - fun.geometry = NULL) { - +geom_sf_label <- function( + mapping = aes(), + data = NULL, + stat = "sf_coordinates", + position = "nudge", + ..., + parse = FALSE, + label.padding = unit(0.25, "lines"), + label.r = unit(0.15, "lines"), + label.size = deprecated(), + border.colour = NULL, + border.color = NULL, + text.colour = NULL, + text.color = NULL, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + fun.geometry = NULL +) { extra_args <- list2(...) if (lifecycle::is_present(label.size)) { deprecate_warn0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)") @@ -358,16 +405,19 @@ geom_sf_label <- function(mapping = aes(), data = NULL, #' @rdname ggsf #' @inheritParams geom_text #' @inheritParams stat_sf_coordinates -geom_sf_text <- function(mapping = aes(), data = NULL, - stat = "sf_coordinates", position = "nudge", - ..., - parse = FALSE, - check_overlap = FALSE, - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE, - fun.geometry = NULL) { - +geom_sf_text <- function( + mapping = aes(), + data = NULL, + stat = "sf_coordinates", + position = "nudge", + ..., + parse = FALSE, + check_overlap = FALSE, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + fun.geometry = NULL +) { layer_sf( data = data, mapping = mapping, @@ -386,10 +436,23 @@ geom_sf_text <- function(mapping = aes(), data = NULL, ) } -sf_types <- c(GEOMETRY = "other", POINT = "point", LINESTRING = "line", - POLYGON = "other", MULTIPOINT = "point", MULTILINESTRING = "line", - MULTIPOLYGON = "other", GEOMETRYCOLLECTION = "collection", - CIRCULARSTRING = "line", COMPOUNDCURVE = "line", CURVEPOLYGON = "other", - MULTICURVE = "line", MULTISURFACE = "other", CURVE = "line", - SURFACE = "other", POLYHEDRALSURFACE = "other", TIN = "other", - TRIANGLE = "other") +sf_types <- c( + GEOMETRY = "other", + POINT = "point", + LINESTRING = "line", + POLYGON = "other", + MULTIPOINT = "point", + MULTILINESTRING = "line", + MULTIPOLYGON = "other", + GEOMETRYCOLLECTION = "collection", + CIRCULARSTRING = "line", + COMPOUNDCURVE = "line", + CURVEPOLYGON = "other", + MULTICURVE = "line", + MULTISURFACE = "other", + CURVE = "line", + SURFACE = "other", + POLYHEDRALSURFACE = "other", + TIN = "other", + TRIANGLE = "other" +) diff --git a/R/geom-smooth.R b/R/geom-smooth.R index a022807b16..bdab528084 100644 --- a/R/geom-smooth.R +++ b/R/geom-smooth.R @@ -3,9 +3,15 @@ #' @usage NULL #' @export GeomSmooth <- ggproto( - "GeomSmooth", Geom, + "GeomSmooth", + Geom, setup_params = function(data, params) { - params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE, ambiguous = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + range_is_orthogonal = TRUE, + ambiguous = TRUE + ) params$se <- params$se %||% if (params$flipped_aes) { all(c("xmin", "xmax") %in% names(data)) @@ -29,8 +35,16 @@ GeomSmooth <- ggproto( # ribbon won't be drawn either in that case, keeping the overall # behavior predictable and sensible. The user will realize that they # need to set `se = TRUE` to obtain the ribbon and the legend key. - draw_group = function(data, panel_params, coord, lineend = "butt", linejoin = "round", - linemitre = 10, se = FALSE, flipped_aes = FALSE) { + draw_group = function( + data, + panel_params, + coord, + lineend = "butt", + linejoin = "round", + linemitre = 10, + se = FALSE, + flipped_aes = FALSE + ) { ribbon <- transform(data, colour = NA) path <- transform(data, alpha = NA) @@ -39,8 +53,22 @@ GeomSmooth <- ggproto( has_ribbon <- se && !is.null(data[[ymax]]) && !is.null(data[[ymin]]) gList( - if (has_ribbon) GeomRibbon$draw_group(ribbon, panel_params, coord, flipped_aes = flipped_aes), - GeomLine$draw_panel(path, panel_params, coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre) + if (has_ribbon) { + GeomRibbon$draw_group( + ribbon, + panel_params, + coord, + flipped_aes = flipped_aes + ) + }, + GeomLine$draw_panel( + path, + panel_params, + coord, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) ) }, @@ -54,7 +82,8 @@ GeomSmooth <- ggproto( fill = from_theme(fill %||% col_mix(ink, paper, 0.6)), linewidth = from_theme(2 * linewidth), linetype = from_theme(linetype), - weight = 1, alpha = 0.4 + weight = 1, + alpha = 0.4 ), rename_size = TRUE @@ -146,17 +175,20 @@ GeomSmooth <- ggproto( #' # But in this case, it's probably better to fit the model yourself #' # so you can exercise more control and see whether or not it's a good model. #' } -geom_smooth <- function(mapping = NULL, data = NULL, - stat = "smooth", position = "identity", - ..., - method = NULL, - formula = NULL, - se = TRUE, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - +geom_smooth <- function( + mapping = NULL, + data = NULL, + stat = "smooth", + position = "identity", + ..., + method = NULL, + formula = NULL, + se = TRUE, + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE +) { params <- list2( na.rm = na.rm, orientation = orientation, diff --git a/R/geom-spoke.R b/R/geom-spoke.R index 71ac416482..0fba94ee92 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -3,14 +3,16 @@ #' @usage NULL #' @export GeomSpoke <- ggproto( - "GeomSpoke", GeomSegment, + "GeomSpoke", + GeomSegment, setup_data = function(data, params) { data$radius <- data$radius %||% params$radius data$angle <- data$angle %||% params$angle - transform(data, - xend = x + cos(angle) * radius, - yend = y + sin(angle) * radius + transform( + data, + xend = x + cos(angle) * radius, + yend = y + sin(angle) * radius ) }, required_aes = c("x", "y", "angle", "radius") diff --git a/R/geom-text.R b/R/geom-text.R index a680b01ab2..2abf65359f 100644 --- a/R/geom-text.R +++ b/R/geom-text.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export GeomText <- ggproto( - "GeomText", Geom, + "GeomText", + Geom, required_aes = c("x", "y", "label"), non_missing_aes = "angle", @@ -12,13 +13,23 @@ GeomText <- ggproto( colour = from_theme(colour %||% ink), family = from_theme(family), size = from_theme(fontsize), - angle = 0, hjust = 0.5, - vjust = 0.5, alpha = NA, fontface = 1, lineheight = 1.2 + angle = 0, + hjust = 0.5, + vjust = 0.5, + alpha = NA, + fontface = 1, + lineheight = 1.2 ), - draw_panel = function(data, panel_params, coord, parse = FALSE, - na.rm = FALSE, check_overlap = FALSE, - size.unit = "mm") { + draw_panel = function( + data, + panel_params, + coord, + parse = FALSE, + na.rm = FALSE, + check_overlap = FALSE, + size.unit = "mm" + ) { lab <- data$label if (parse) { lab <- parse_safe(as.character(lab)) @@ -33,8 +44,11 @@ GeomText <- ggproto( textGrob( lab, - data$x, data$y, default.units = "native", - hjust = data$hjust, vjust = data$vjust, + data$x, + data$y, + default.units = "native", + hjust = data$hjust, + vjust = data$vjust, rot = data$angle, gp = gg_par( col = alpha(data$colour, data$alpha), @@ -232,11 +246,16 @@ compute_just <- function(just, a = 0.5, b = a, angle = 0) { outward <- (just == "outward" & !just_swap) | (just == "inward" & just_swap) just[outward] <- c("right", "middle", "left")[just_dir(ab[outward])] - } - unname(c(left = 0, center = 0.5, right = 1, - bottom = 0, middle = 0.5, top = 1)[just]) + unname(c( + left = 0, + center = 0.5, + right = 1, + bottom = 0, + middle = 0.5, + top = 1 + )[just]) } just_dir <- function(x, tol = 0.001) { diff --git a/R/geom-tile.R b/R/geom-tile.R index 85673eddce..da751136c4 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -4,26 +4,37 @@ #' @export #' @include geom-rect.R GeomTile <- ggproto( - "GeomTile", GeomRect, + "GeomTile", + GeomRect, extra_params = c("na.rm"), setup_data = function(self, data, params) { - data <- compute_data_size( - data, params$width, + data, + params$width, default = self$default_aes$width, - panels = "by", target = "width", - zero = FALSE, discrete = TRUE + panels = "by", + target = "width", + zero = FALSE, + discrete = TRUE ) data <- compute_data_size( - data, params$height, + data, + params$height, default = self$default_aes$height, - panels = "by", target = "height", - zero = FALSE, discrete = TRUE + panels = "by", + target = "height", + zero = FALSE, + discrete = TRUE ) - transform(data, - xmin = x - width / 2, xmax = x + width / 2, width = NULL, - ymin = y - height / 2, ymax = y + height / 2, height = NULL + transform( + data, + xmin = x - width / 2, + xmax = x + width / 2, + width = NULL, + ymin = y - height / 2, + ymax = y + height / 2, + height = NULL ) }, @@ -32,7 +43,9 @@ GeomTile <- ggproto( colour = from_theme(colour %||% NA), linewidth = from_theme(0.4 * borderwidth), linetype = from_theme(bordertype), - alpha = NA, width = 1, height = 1 + alpha = NA, + width = 1, + height = 1 ), required_aes = c("x", "y"), diff --git a/R/geom-violin.R b/R/geom-violin.R index c8d9dc47fb..9cdde3388a 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -92,22 +92,25 @@ #' geom_violin(aes(group = cut_width(year, 10)), scale = "width") #' } #' } -geom_violin <- function(mapping = NULL, data = NULL, - stat = "ydensity", position = "dodge", - ..., - trim = TRUE, - bounds = c(-Inf, Inf), - quantile.colour = NULL, - quantile.color = NULL, - quantile.linetype = 0L, - quantile.linewidth = NULL, - draw_quantiles = deprecated(), - scale = "area", - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE) { - +geom_violin <- function( + mapping = NULL, + data = NULL, + stat = "ydensity", + position = "dodge", + ..., + trim = TRUE, + bounds = c(-Inf, Inf), + quantile.colour = NULL, + quantile.color = NULL, + quantile.linetype = 0L, + quantile.linewidth = NULL, + draw_quantiles = deprecated(), + scale = "area", + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE +) { extra <- list() if (lifecycle::is_present(draw_quantiles)) { deprecate_soft0( @@ -130,8 +133,8 @@ geom_violin <- function(mapping = NULL, data = NULL, } quantile_gp <- list( - colour = quantile.color %||% quantile.colour, - linetype = quantile.linetype, + colour = quantile.color %||% quantile.colour, + linetype = quantile.linetype, linewidth = quantile.linewidth ) @@ -160,7 +163,9 @@ geom_violin <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomViolin <- ggproto("GeomViolin", Geom, +GeomViolin <- ggproto( + "GeomViolin", + Geom, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) params @@ -172,21 +177,32 @@ GeomViolin <- ggproto("GeomViolin", Geom, data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) data <- compute_data_size( - data, params$width, + data, + params$width, default = self$default_aes$width ) # ymin, ymax, xmin, and xmax define the bounding rectangle for each group - data <- dapply(data, "group", transform, + data <- dapply( + data, + "group", + transform, xmin = x - width / 2, xmax = x + width / 2 ) flip_data(data, params$flipped_aes) }, - draw_group = function(self, data, ..., quantile_gp = list(linetype = 0), flipped_aes = FALSE) { + draw_group = function( + self, + data, + ..., + quantile_gp = list(linetype = 0), + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) # Find the points for the line to go all the way around - data <- transform(data, + data <- transform( + data, xminv = x - violinwidth * (x - xmin), xmaxv = x + violinwidth * (xmax - x) ) @@ -199,23 +215,25 @@ GeomViolin <- ggproto("GeomViolin", Geom, # Close the polygon: set first and last point the same # Needed for coord_polar and such - newdata <- vec_rbind0(newdata, newdata[1,]) + newdata <- vec_rbind0(newdata, newdata[1, ]) newdata <- flip_data(newdata, flipped_aes) violin_grob <- GeomPolygon$draw_panel(newdata, ...) - if (!"quantile" %in% names(newdata) || + if ( + !"quantile" %in% names(newdata) || all(quantile_gp$linetype == 0) || - all(quantile_gp$linetype == "blank")) { + all(quantile_gp$linetype == "blank") + ) { return(ggname("geom_violin", violin_grob)) } # Draw quantiles if requested, so long as there is non-zero y range - quantiles <- newdata[!is.na(newdata$quantile),] + quantiles <- newdata[!is.na(newdata$quantile), ] quantiles$group <- match(quantiles$quantile, unique(quantiles$quantile)) - quantiles$linetype <- quantile_gp$linetype %||% quantiles$linetype + quantiles$linetype <- quantile_gp$linetype %||% quantiles$linetype quantiles$linewidth <- quantile_gp$linewidth %||% quantiles$linewidth - quantiles$colour <- quantile_gp$colour %||% quantiles$colour + quantiles$colour <- quantile_gp$colour %||% quantiles$colour quantile_grob <- if (nrow(quantiles) == 0) { zeroGrob() @@ -260,4 +278,3 @@ create_quantile_segment_frame <- function(data, draw_quantiles) { group = rep(ys, each = 2) ) } - diff --git a/R/geom-vline.R b/R/geom-vline.R index 872ac379f7..b139b1e385 100644 --- a/R/geom-vline.R +++ b/R/geom-vline.R @@ -3,21 +3,27 @@ NULL #' @export #' @rdname geom_abline -geom_vline <- function(mapping = NULL, data = NULL, - position = "identity", - ..., - xintercept, - na.rm = FALSE, - show.legend = NA) { - +geom_vline <- function( + mapping = NULL, + data = NULL, + position = "identity", + ..., + xintercept, + na.rm = FALSE, + show.legend = NA +) { # Act like an annotation if (!missing(xintercept)) { # Warn if supplied mapping and/or data is going to be overwritten if (!is.null(mapping)) { - cli::cli_warn("{.fn geom_vline}: Ignoring {.arg mapping} because {.arg xintercept} was provided.") + cli::cli_warn( + "{.fn geom_vline}: Ignoring {.arg mapping} because {.arg xintercept} was provided." + ) } if (!is.null(data)) { - cli::cli_warn("{.fn geom_vline}: Ignoring {.arg data} because {.arg xintercept} was provided.") + cli::cli_warn( + "{.fn geom_vline}: Ignoring {.arg data} because {.arg xintercept} was provided." + ) } data <- data_frame0(xintercept = xintercept) @@ -44,16 +50,23 @@ geom_vline <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -GeomVline <- ggproto("GeomVline", Geom, +GeomVline <- ggproto( + "GeomVline", + Geom, draw_panel = function(data, panel_params, coord, lineend = "butt") { ranges <- coord$backtransform_range(panel_params) - data$x <- data$xintercept + data$x <- data$xintercept data$xend <- data$xintercept - data$y <- ranges$y[1] + data$y <- ranges$y[1] data$yend <- ranges$y[2] - GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) + GeomSegment$draw_panel( + unique0(data), + panel_params, + coord, + lineend = lineend + ) }, default_aes = GeomPath$default_aes, diff --git a/R/ggplot-global.R b/R/ggplot-global.R index 495dc65ae0..854b411a46 100644 --- a/R/ggplot-global.R +++ b/R/ggplot-global.R @@ -16,11 +16,47 @@ ggplot_global$element_tree <- list() # (In the future, .all_aesthetics should be removed in favor # of direct assignment to ggplot_global$all_aesthetics, see below.) .all_aesthetics <- c( - "adj", "alpha", "angle", "bg", "cex", "col", "color", - "colour", "fg", "fill", "group", "hjust", "label", "linetype", "lower", - "lty", "lwd", "max", "middle", "min", "pch", "radius", "sample", "shape", - "size", "srt", "upper", "vjust", "weight", "width", "x", "xend", "xmax", - "xmin", "xintercept", "y", "yend", "ymax", "ymin", "yintercept", "z" + "adj", + "alpha", + "angle", + "bg", + "cex", + "col", + "color", + "colour", + "fg", + "fill", + "group", + "hjust", + "label", + "linetype", + "lower", + "lty", + "lwd", + "max", + "middle", + "min", + "pch", + "radius", + "sample", + "shape", + "size", + "srt", + "upper", + "vjust", + "weight", + "width", + "x", + "xend", + "xmax", + "xmin", + "xintercept", + "y", + "yend", + "ymax", + "ymin", + "yintercept", + "z" ) ggplot_global$all_aesthetics <- .all_aesthetics @@ -29,26 +65,48 @@ ggplot_global$all_aesthetics <- .all_aesthetics # (In the future, .base_to_ggplot should be removed in favor # of direct assignment to ggplot_global$base_to_ggplot, see below.) .base_to_ggplot <- c( - "col" = "colour", + "col" = "colour", "color" = "colour", - "pch" = "shape", - "cex" = "size", - "lty" = "linetype", - "lwd" = "linewidth", - "srt" = "angle", - "adj" = "hjust", - "bg" = "fill", - "fg" = "colour", - "min" = "ymin", - "max" = "ymax" + "pch" = "shape", + "cex" = "size", + "lty" = "linetype", + "lwd" = "linewidth", + "srt" = "angle", + "adj" = "hjust", + "bg" = "fill", + "fg" = "colour", + "min" = "ymin", + "max" = "ymax" ) ggplot_global$base_to_ggplot <- .base_to_ggplot # These two vectors must match in length and position of symmetrical aesthetics # xintercept2 is a filler to match to the intercept aesthetic in geom_abline -ggplot_global$x_aes <- c("x", "xmin", "xmax", "xend", "xintercept", - "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper", "x0") +ggplot_global$x_aes <- c( + "x", + "xmin", + "xmax", + "xend", + "xintercept", + "xmin_final", + "xmax_final", + "xlower", + "xmiddle", + "xupper", + "x0" +) -ggplot_global$y_aes <- c("y", "ymin", "ymax", "yend", "yintercept", - "ymin_final", "ymax_final", "lower", "middle", "upper", "y0") +ggplot_global$y_aes <- c( + "y", + "ymin", + "ymax", + "yend", + "yintercept", + "ymin_final", + "ymax_final", + "lower", + "middle", + "upper", + "y0" +) diff --git a/R/ggproto.R b/R/ggproto.R index 853a440f9f..b619d3bcc6 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -157,7 +157,6 @@ fetch_ggproto <- function(x, name) { } else { grep(pattern, methods, value = TRUE) } - } #' @export @@ -184,7 +183,7 @@ make_proto_method <- function(self, f, name) { args <- formals(f) # is.null is a fast path for a common case; the %in% check is slower but also # catches the case where there's a `self = NULL` argument. - has_self <- !is.null(args[["self"]]) || "self" %in% names(args) + has_self <- !is.null(args[["self"]]) || "self" %in% names(args) # We assign the method with its correct name and construct a call to it to # make errors reported as coming from the method name rather than `f()` @@ -252,7 +251,6 @@ as.list.ggproto <- function(x, inherit = TRUE, ...) { print.ggproto <- function(x, ..., flat = TRUE) { if (is.function(x$print)) { x$print(...) - } else { cat(format(x, flat = flat), "\n", sep = "") invisible(x) @@ -262,11 +260,12 @@ print.ggproto <- function(x, ..., flat = TRUE) { #' @export #' @rdname print.ggproto -format.ggproto <- function(x, ..., flat = TRUE) { +format.ggproto <- function(x, ..., flat = TRUE) { classes_str <- function(obj) { classes <- setdiff(class(obj), "ggproto") - if (length(classes) == 0) + if (length(classes) == 0) { return("") + } paste0(": Class ", paste(classes, collapse = ', ')) } @@ -278,13 +277,16 @@ format.ggproto <- function(x, ..., flat = TRUE) { } str <- paste0( - "\n", + "\n", indent(object_summaries(objs, flat = flat), 4) ) if (flat && is.function(x$super)) { str <- paste0( - str, "\n", + str, + "\n", indent( paste0("super: ", " "), 4 @@ -298,25 +300,38 @@ format.ggproto <- function(x, ..., flat = TRUE) { # Return a summary string of the items of a list or environment # x must be a list or environment object_summaries <- function(x, exclude = NULL, flat = TRUE) { - if (length(x) == 0) + if (length(x) == 0) { return(NULL) + } - if (is.list(x)) + if (is.list(x)) { obj_names <- sort(names(x)) - else if (is.environment(x)) + } else if (is.environment(x)) { obj_names <- ls(x, all.names = TRUE) + } obj_names <- setdiff(obj_names, exclude) - values <- vapply(obj_names, function(name) { - obj <- x[[name]] - if (is.function(obj)) "function" - else if (is_ggproto(obj)) format(obj, flat = flat) - else if (is.environment(obj)) "environment" - else if (is.null(obj)) "NULL" - else if (is.atomic(obj)) trim(paste(as.character(obj), collapse = " ")) - else paste(class(obj), collapse = ", ") - }, FUN.VALUE = character(1)) + values <- vapply( + obj_names, + function(name) { + obj <- x[[name]] + if (is.function(obj)) { + "function" + } else if (is_ggproto(obj)) { + format(obj, flat = flat) + } else if (is.environment(obj)) { + "environment" + } else if (is.null(obj)) { + "NULL" + } else if (is.atomic(obj)) { + trim(paste(as.character(obj), collapse = " ")) + } else { + paste(class(obj), collapse = ", ") + } + }, + FUN.VALUE = character(1) + ) paste0(obj_names, ": ", values, sep = "", collapse = "\n") } @@ -324,7 +339,8 @@ object_summaries <- function(x, exclude = NULL, flat = TRUE) { # Given a string, indent every line by some number of spaces. # The exception is to not add spaces after a trailing \n. indent <- function(str, indent = 0) { - gsub("(\\n|^)(?!$)", + gsub( + "(\\n|^)(?!$)", paste0("\\1", paste(rep(" ", indent), collapse = "")), str, perl = TRUE @@ -333,8 +349,11 @@ indent <- function(str, indent = 0) { # Trim a string to n characters; if it's longer than n, add " ..." to the end trim <- function(str, n = 60) { - if (nchar(str) > n) paste(substr(str, 1, 56), "...") - else str + if (nchar(str) > n) { + paste(substr(str, 1, 56), "...") + } else { + str + } } #' @export @@ -344,13 +363,13 @@ print.ggproto_method <- function(x, ...) { #' @export format.ggproto_method <- function(x, ...) { - # Given a function, return a string from srcref if present. If not present, # paste the deparsed lines of code together. format_fun <- function(fn) { srcref <- attr(fn, "srcref", exact = TRUE) - if (is.null(srcref)) + if (is.null(srcref)) { return(paste(format(fn), collapse = "\n")) + } paste(as.character(srcref), collapse = "\n") } @@ -358,8 +377,10 @@ format.ggproto_method <- function(x, ...) { x <- unclass(x) paste0( "", - "\n \n ", format_fun(x), - "\n\n \n ", format_fun(environment(x)$f) + "\n \n ", + format_fun(x), + "\n\n \n ", + format_fun(environment(x)$f) ) } @@ -394,9 +415,8 @@ ggproto_debug <- function(method, debug = c("once", "always", "never"), ...) { check_function(method) switch( arg_match0(debug, c("once", "always", "never")), - once = debugonce(method, ...), + once = debugonce(method, ...), always = debug(method, ...), - never = undebug(method, ...) + never = undebug(method, ...) ) } - diff --git a/R/grob-absolute.R b/R/grob-absolute.R index cce138712a..951c962809 100644 --- a/R/grob-absolute.R +++ b/R/grob-absolute.R @@ -5,14 +5,22 @@ #' It's still experimental #' #' @keywords internal -absoluteGrob <- function(grob, width = NULL, height = NULL, - xmin = NULL, ymin = NULL, vp = NULL) { - +absoluteGrob <- function( + grob, + width = NULL, + height = NULL, + xmin = NULL, + ymin = NULL, + vp = NULL +) { gTree( children = grob, - width = width, height = height, - xmin = xmin, ymin = ymin, - vp = vp, cl = "absoluteGrob" + width = width, + height = height, + xmin = xmin, + ymin = ymin, + vp = vp, + cl = "absoluteGrob" ) } @@ -24,19 +32,23 @@ grobHeight.absoluteGrob <- function(x) { #' @export #' @method grobWidth absoluteGrob grobWidth.absoluteGrob <- function(x) { - x$width %||% grobWidth(x$children) + x$width %||% grobWidth(x$children) } #' @export #' @method grobX absoluteGrob grobX.absoluteGrob <- function(x, theta) { - if (!is.null(x$xmin) && theta == "west") return(x$xmin) + if (!is.null(x$xmin) && theta == "west") { + return(x$xmin) + } grobX(x$children, theta) } #' @export #' @method grobY absoluteGrob grobY.absoluteGrob <- function(x, theta) { - if (!is.null(x$ymin) && theta == "south") return(x$ymin) + if (!is.null(x$ymin) && theta == "south") { + return(x$ymin) + } grobY(x$children, theta) } diff --git a/R/grob-dotstack.R b/R/grob-dotstack.R index 7bbcd28418..057b1c4130 100644 --- a/R/grob-dotstack.R +++ b/R/grob-dotstack.R @@ -1,25 +1,42 @@ dotstackGrob <- function( - x = unit(0.5, "npc"), # x pos of the dotstack's origin - y = unit(0.5, "npc"), # y pos of the dotstack's origin - stackaxis = "y", - dotdia = unit(1, "npc"), # Dot diameter in the non-stack axis, should be in npc - stackposition = 0, # Position of each dot in the stack, relative to origin - stackdir = "up", # Stacking direction ("up", "down", "center", or "centerwhole") - stackratio = 1, # Stacking height of dots (.75 means 25% dot overlap) - default.units = "npc", name = NULL, gp = gpar(), vp = NULL) -{ - if (!is.unit(x)) - x <- unit(x, default.units) - if (!is.unit(y)) - y <- unit(y, default.units) - if (!is.unit(dotdia)) - dotdia <- unit(dotdia, default.units) - if (!isTRUE(unitType(dotdia) == "npc")) - cli::cli_warn("Unit type of dotdia should be {.val npc}") + x = unit(0.5, "npc"), # x pos of the dotstack's origin + y = unit(0.5, "npc"), # y pos of the dotstack's origin + stackaxis = "y", + dotdia = unit(1, "npc"), # Dot diameter in the non-stack axis, should be in npc + stackposition = 0, # Position of each dot in the stack, relative to origin + stackdir = "up", # Stacking direction ("up", "down", "center", or "centerwhole") + stackratio = 1, # Stacking height of dots (.75 means 25% dot overlap) + default.units = "npc", + name = NULL, + gp = gpar(), + vp = NULL +) { + if (!is.unit(x)) { + x <- unit(x, default.units) + } + if (!is.unit(y)) { + y <- unit(y, default.units) + } + if (!is.unit(dotdia)) { + dotdia <- unit(dotdia, default.units) + } + if (!isTRUE(unitType(dotdia) == "npc")) { + cli::cli_warn("Unit type of dotdia should be {.val npc}") + } - grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia, - stackposition = stackposition, stackdir = stackdir, stackratio = stackratio, - name = name, gp = gp, vp = vp, cl = "dotstackGrob") + grob( + x = x, + y = y, + stackaxis = stackaxis, + dotdia = dotdia, + stackposition = stackposition, + stackdir = stackdir, + stackratio = stackratio, + name = name, + gp = gp, + vp = vp, + cl = "dotstackGrob" + ) } #' @export @@ -54,7 +71,12 @@ makeContext.dotstackGrob <- function(x) { } circleGrob( - x = xpos, y = ypos, r = dotdiamm / 2, default.units = "mm", - name = x$name, gp = x$gp, vp = x$vp + x = xpos, + y = ypos, + r = dotdiamm / 2, + default.units = "mm", + name = x$name, + gp = x$gp, + vp = x$vp ) } diff --git a/R/grouping.R b/R/grouping.R index 7db4807a0f..89451b3425 100644 --- a/R/grouping.R +++ b/R/grouping.R @@ -9,7 +9,9 @@ NO_GROUP <- -1L # character) vectors, excluding `label`. The special value `NO_GROUP` # is used for all observations if no discrete variables exist. add_group <- function(data) { - if (empty(data)) return(data) + if (empty(data)) { + return(data) + } if (is.null(data[["group"]])) { disc <- vapply(data, is_discrete, logical(1)) diff --git a/R/guide-.R b/R/guide-.R index 8b0cee001f..34ac7a7ce0 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -17,7 +17,6 @@ NULL #' @keywords internal #' @export new_guide <- function(..., available_aes = "any", super) { - pf <- parent.frame() super <- validate_subclass(super, "Guide", env = pf) @@ -40,7 +39,7 @@ new_guide <- function(..., available_aes = "any", super) { # Stop when some required parameters are missing. # This should only happen with mis-constructed guides required_params <- names(Guide$params) - missing_params <- setdiff(required_params, names(params)) + missing_params <- setdiff(required_params, names(params)) if (length(missing_params) > 0) { cli::cli_abort(paste0( "The following parameter{?s} {?is/are} required for setting up a guide, ", @@ -60,7 +59,8 @@ new_guide <- function(..., available_aes = "any", super) { vec_assert(params$order, 0L, size = 1L, arg = "order", call = pf) ggproto( - NULL, super, + NULL, + super, params = params, available_aes = available_aes ) @@ -170,13 +170,13 @@ Guide <- ggproto( #' * During build stages, a mutable copy of `params` holds information #' about the guide. params = list( - title = waiver(), - theme = NULL, - name = character(), - position = waiver(), + title = waiver(), + theme = NULL, + name = character(), + position = waiver(), direction = NULL, - order = 0, - hash = character() + order = 0, + hash = character() ), #' @field available_aes A character vector of aesthetic names for which the @@ -232,7 +232,7 @@ Guide <- ggproto( #' A modified list of parameters train = function(self, params = self$params, scale, aesthetic = NULL, ...) { params$aesthetic <- aesthetic %||% scale$aesthetics[1] - params$key <- inject(self$extract_key(scale, !!!params)) + params$key <- inject(self$extract_key(scale, !!!params)) if (is.null(params$key)) { return(NULL) } @@ -240,7 +240,11 @@ Guide <- ggproto( params <- self$extract_params(scale, params, ...) # Make hash # TODO: Maybe we only need the hash on demand during merging? - params$hash <- hash(lapply(unname(self$hashables), eval_tidy, data = params)) + params$hash <- hash(lapply( + unname(self$hashables), + eval_tidy, + data = params + )) params }, @@ -497,17 +501,21 @@ Guide <- ggproto( #' **Value** #' #' A grob with the guide. - draw = function(self, theme, position = NULL, direction = NULL, - params = self$params) { - + draw = function( + self, + theme, + position = NULL, + direction = NULL, + params = self$params + ) { # Setup parameters params <- replace_null(params, position = position, direction = direction) params <- self$setup_params(params) - key <- params$key + key <- params$key # Setup style options - elems <- self$setup_elements(params, self$elements, theme) - elems <- self$override_elements(params, elems, theme) + elems <- self$setup_elements(params, self$elements, theme) + elems <- self$override_elements(params, elems, theme) # Allow early exit when key is empty if (prod(dim(key)) == 0) { @@ -517,8 +525,8 @@ Guide <- ggproto( # Build grobs grobs <- list( - title = self$build_title(params$title, elems, params), - ticks = self$build_ticks(key, elems, params) + title = self$build_title(params$title, elems, params), + ticks = self$build_ticks(key, elems, params) ) if (params$draw_label %||% TRUE) { grobs$labels <- self$build_labels(key, elems, params) @@ -528,7 +536,7 @@ Guide <- ggproto( grobs$decor <- self$build_decor(params$decor, grobs, elems, params) # Arrange and assemble grobs - sizes <- self$measure_grobs(grobs, params, elems) + sizes <- self$measure_grobs(grobs, params, elems) layout <- self$arrange_layout(key, sizes, params, elems) self$assemble_drawing(grobs, layout, sizes, params, elems) }, @@ -617,7 +625,7 @@ Guide <- ggproto( #' A list of elements or resolved theme settings. setup_elements = function(params, elements, theme) { theme <- add_theme(theme, params$theme) - is_char <- vapply(elements, is.character, logical(1)) + is_char <- vapply(elements, is.character, logical(1)) elements[is_char] <- lapply(elements[is_char], calc_element, theme = theme) elements }, @@ -658,7 +666,7 @@ Guide <- ggproto( "guide.title", element_grob( elements$title, - label = label, + label = label, margin_x = TRUE, margin_y = TRUE ) @@ -695,8 +703,13 @@ Guide <- ggproto( #' **Value** #' #' A grob representing tick marks. - build_ticks = function(key, elements, params, position = params$position, - length = elements$ticks_length) { + build_ticks = function( + key, + elements, + params, + position = params$position, + length = elements$ticks_length + ) { force(length) # TODO: position logic is crooked, should this be reversed? @@ -734,7 +747,8 @@ Guide <- ggproto( # Build grob flip_element_grob( elements, - x = tick, y = mark, + x = tick, + y = mark, id.lengths = rep(2, n_breaks), flip = position %in% c("top", "bottom") ) @@ -926,32 +940,36 @@ Guide <- ggproto( return(gtable) } - title_width_cm <- width_cm(title) + title_width_cm <- width_cm(title) title_height_cm <- height_cm(title) # Add extra row/col for title gtable <- switch( position, - top = gtable_add_rows(gtable, unit(title_height_cm, "cm"), pos = 0), - right = gtable_add_cols(gtable, unit(title_width_cm, "cm"), pos = -1), + top = gtable_add_rows(gtable, unit(title_height_cm, "cm"), pos = 0), + right = gtable_add_cols(gtable, unit(title_width_cm, "cm"), pos = -1), bottom = gtable_add_rows(gtable, unit(title_height_cm, "cm"), pos = -1), - left = gtable_add_cols(gtable, unit(title_width_cm, "cm"), pos = 0) + left = gtable_add_cols(gtable, unit(title_width_cm, "cm"), pos = 0) ) # Add title args <- switch( position, - top = list(t = 1, l = 1, r = -1, b = 1), - right = list(t = 1, l = -1, r = -1, b = -1), - bottom = list(t = -1, l = 1, r = -1, b = -1), - left = list(t = 1, l = 1, r = 1, b = -1), + top = list(t = 1, l = 1, r = -1, b = 1), + right = list(t = 1, l = -1, r = -1, b = -1), + bottom = list(t = -1, l = 1, r = -1, b = -1), + left = list(t = 1, l = 1, r = 1, b = -1), ) gtable <- inject(gtable_add_grob( - x = gtable, grobs = title, !!!args, z = -Inf, name = "title", clip = "off" + x = gtable, + grobs = title, + !!!args, + z = -Inf, + name = "title", + clip = "off" )) if (position %in% c("top", "bottom")) { - if (any(unitType(gtable$widths) == "null")) { # Don't need to add extra title size for stretchy legends return(gtable) @@ -962,11 +980,9 @@ Guide <- ggproto( return(gtable) } extra_width <- unit((c(1, -1) * just$hjust + c(0, 1)) * extra_width, "cm") - gtable <- gtable_add_cols(gtable, extra_width[1], pos = 0) + gtable <- gtable_add_cols(gtable, extra_width[1], pos = 0) gtable <- gtable_add_cols(gtable, extra_width[2], pos = -1) - } else { - if (any(unitType(gtable$heights) == "null")) { # Don't need to add extra title size for stretchy legends return(gtable) @@ -976,8 +992,11 @@ Guide <- ggproto( if (extra_height == 0) { return(gtable) } - extra_height <- unit((c(-1, 1) * just$vjust + c(1, 0)) * extra_height, "cm") - gtable <- gtable_add_rows(gtable, extra_height[1], pos = 0) + extra_height <- unit( + (c(-1, 1) * just$vjust + c(1, 0)) * extra_height, + "cm" + ) + gtable <- gtable_add_rows(gtable, extra_height[1], pos = 0) gtable <- gtable_add_rows(gtable, extra_height[2], pos = -1) } @@ -1002,12 +1021,12 @@ flip_element_grob <- function(..., flip = FALSE) { # The flippable arguments for `flip_element_grob()`. flip_names <- c( - "x" = "y", - "y" = "x", - "width" = "height", - "height" = "width", - "hjust" = "vjust", - "vjust" = "hjust", + "x" = "y", + "y" = "x", + "width" = "height", + "height" = "width", + "hjust" = "vjust", + "vjust" = "hjust", "margin_x" = "margin_y", "margin_y" = "margin_x" ) @@ -1018,10 +1037,10 @@ flip_names <- c( opposite_position <- function(position) { switch( position, - top = "bottom", + top = "bottom", bottom = "top", - left = "right", - right = "left", + left = "right", + right = "left", position ) } diff --git a/R/guide-axis-logticks.R b/R/guide-axis-logticks.R index 1a66637b31..2d722629e1 100644 --- a/R/guide-axis-logticks.R +++ b/R/guide-axis-logticks.R @@ -67,8 +67,8 @@ NULL #' # To control the tick density around 0, one can set `negative.small` #' p2 + guides(x = guide_axis_logticks(negative.small = 1)) guide_axis_logticks <- function( - long = 2.25, - mid = 1.5, + long = 2.25, + mid = 1.5, short = 0.75, prescale.base = NULL, negative.small = NULL, @@ -83,19 +83,25 @@ guide_axis_logticks <- function( ) { if (lifecycle::is_present(prescale_base)) { deprecate_warn0( - "3.5.1", "guide_axis_logticks(prescale_base)", "guide_axis_logticks(prescale.base)" + "3.5.1", + "guide_axis_logticks(prescale_base)", + "guide_axis_logticks(prescale.base)" ) prescale.base <- prescale_base } if (lifecycle::is_present(negative_small)) { deprecate_warn0( - "3.5.1", "guide_axis_logticks(negative_small)", "guide_axis_logticks(negative.small)" + "3.5.1", + "guide_axis_logticks(negative_small)", + "guide_axis_logticks(negative.small)" ) negative.small <- negative_small } if (lifecycle::is_present(short_theme)) { deprecate_warn0( - "3.5.1", "guide_axis_logticks(short_theme)", "guide_axis_logticks(short.theme)" + "3.5.1", + "guide_axis_logticks(short_theme)", + "guide_axis_logticks(short.theme)" ) short.theme <- short_theme } @@ -106,32 +112,42 @@ guide_axis_logticks <- function( } cap <- arg_match0(cap, c("none", "both", "upper", "lower")) - if (is_bare_numeric(long)) long <- rel(long) - if (is_bare_numeric(mid)) mid <- rel(mid) - if (is_bare_numeric(short)) short <- rel(short) + if (is_bare_numeric(long)) { + long <- rel(long) + } + if (is_bare_numeric(mid)) { + mid <- rel(mid) + } + if (is_bare_numeric(short)) { + short <- rel(short) + } check_fun <- function(x) (is_rel(x) || is.unit(x)) && length(x) == 1 what <- "a {.cls rel} or {.cls unit} object of length 1" - check_object(long, check_fun, what) - check_object(mid, check_fun, what) + check_object(long, check_fun, what) + check_object(mid, check_fun, what) check_object(short, check_fun, what) check_number_decimal( - negative.small, min = 1e-100, # minimal domain of scales::log_trans + negative.small, + min = 1e-100, # minimal domain of scales::log_trans allow_infinite = FALSE, allow_null = TRUE ) check_bool(expanded) - check_inherits(short.theme, c("ggplot2::element_blank", "ggplot2::element_line")) + check_inherits( + short.theme, + c("ggplot2::element_blank", "ggplot2::element_line") + ) new_guide( - available_aes = c("x", "y"), - prescale_base = prescale.base, + available_aes = c("x", "y"), + prescale_base = prescale.base, negative_small = negative.small, - expanded = expanded, - long = long, - mid = mid, + expanded = expanded, + long = long, + mid = mid, short = short, - cap = cap, + cap = cap, minor.ticks = TRUE, short_theme = short.theme, theme = theme, @@ -145,15 +161,16 @@ guide_axis_logticks <- function( #' @usage NULL #' @export GuideAxisLogticks <- ggproto( - "GuideAxisLogticks", GuideAxis, + "GuideAxisLogticks", + GuideAxis, params = defaults( list( - prescale_base = NULL, + prescale_base = NULL, negative_small = 0.1, - minor.ticks = TRUE, # for spacing calculation - long = 2.25, - mid = 1.5, + minor.ticks = TRUE, # for spacing calculation + long = 2.25, + mid = 1.5, short = 0.75, expanded = TRUE, short_theme = NULL @@ -163,12 +180,11 @@ GuideAxisLogticks <- ggproto( # Here we calculate a 'shadow key' that only applies to the tickmarks. extract_params = function(scale, params, ...) { - if (scale$is_discrete()) { cli::cli_abort("Cannot calculate logarithmic ticks for discrete scales.") } - aesthetic <- params$aesthetic + aesthetic <- params$aesthetic params$name <- paste0(params$name, "_", aesthetic) params @@ -230,7 +246,7 @@ GuideAxisLogticks <- ggproto( if (is.unit(x)) x else unclass(x) * length }) tick_length <- inject(unit.c(!!!tick_length)) - elements$tick_length <- tick_length + elements$tick_length <- tick_length # We replace the lengths so that spacing calculation works out as intended elements$major_length <- max(tick_length) @@ -243,19 +259,25 @@ GuideAxisLogticks <- ggproto( key <- params$logkey long <- Guide$build_ticks( vec_slice(key, key$.type == 1L), - elements$ticks, params, position, + elements$ticks, + params, + position, elements$tick_length[1L] ) mid <- Guide$build_ticks( vec_slice(key, key$.type == 2L), - elements$minor, params, position, + elements$minor, + params, + position, elements$tick_length[2L] ) short <- Guide$build_ticks( vec_slice(key, key$.type == 3L), - elements$short, params, position, + elements$short, + params, + position, elements$tick_length[3L] ) grobTree(long, mid, short, name = "ticks") diff --git a/R/guide-axis-stack.R b/R/guide-axis-stack.R index 8a3ba4c91c..86730447b1 100644 --- a/R/guide-axis-stack.R +++ b/R/guide-axis-stack.R @@ -29,9 +29,15 @@ NULL #' #' # A normal axis first, then a capped axis #' p + guides(x = guide_axis_stack("axis", guide_axis(cap = "both"))) -guide_axis_stack <- function(first = "axis", ..., title = waiver(), theme = NULL, - spacing = NULL, order = 0, position = waiver()) { - +guide_axis_stack <- function( + first = "axis", + ..., + title = waiver(), + theme = NULL, + spacing = NULL, + order = 0, + position = waiver() +) { check_object(spacing, is.unit, "{.cls unit}", allow_null = TRUE) # Validate guides @@ -40,7 +46,11 @@ guide_axis_stack <- function(first = "axis", ..., title = waiver(), theme = NULL # Check available aesthetics available <- lapply(axes, `[[`, name = "available_aes") - available <- vapply(available, function(x) all(c("x", "y") %in% x), logical(1)) + available <- vapply( + available, + function(x) all(c("x", "y") %in% x), + logical(1) + ) if (!any(available)) { cli::cli_abort(paste0( "{.fn guide_axis_stack} can only use guides that handle {.field x} and ", @@ -50,13 +60,16 @@ guide_axis_stack <- function(first = "axis", ..., title = waiver(), theme = NULL # Remove guides that don't support x/y aesthetics if (!all(available)) { - remove <- which(!available) + remove <- which(!available) removed <- vapply(axes[remove], snake_class, character(1)) axes[remove] <- NULL - cli::cli_warn(c(paste0( - "{.fn guide_axis_stack} cannot use the following guide{?s}: ", - "{.and {.fn {removed}}}." - ), i = "Guides need to handle {.field x} and {.field y} aesthetics.")) + cli::cli_warn(c( + paste0( + "{.fn guide_axis_stack} cannot use the following guide{?s}: ", + "{.and {.fn {removed}}}." + ), + i = "Guides need to handle {.field x} and {.field y} aesthetics." + )) } params <- lapply(axes, `[[`, name = "params") @@ -80,23 +93,24 @@ guide_axis_stack <- function(first = "axis", ..., title = waiver(), theme = NULL #' @usage NULL #' @export GuideAxisStack <- ggproto( - "GuideAxisStack", GuideAxis, + "GuideAxisStack", + GuideAxis, params = list( # List of guides to track the guide objects - guides = list(), + guides = list(), # List of parameters to each guide guide_params = list(), - spacing = NULL, + spacing = NULL, # Standard guide stuff - name = "stacked_axis", - title = waiver(), - theme = NULL, - angle = waiver(), - hash = character(), - position = waiver(), + name = "stacked_axis", + title = waiver(), + theme = NULL, + angle = waiver(), + hash = character(), + position = waiver(), direction = NULL, - order = 0 + order = 0 ), available_aes = c("x", "y", "theta", "r"), @@ -107,15 +121,18 @@ GuideAxisStack <- ggproto( # Sets position, loops through guides to train train = function(self, params = self$params, scale, aesthetic = NULL, ...) { position <- arg_match0( - params$position, c(.trbl, "theta", "theta.sec"), + params$position, + c(.trbl, "theta", "theta.sec"), arg_nm = "position" ) for (i in seq_along(params$guides)) { params$guide_params[[i]]$position <- position - params$guide_params[[i]]$angle <- params$guide_params[[i]]$angle %|W|% params$angle + params$guide_params[[i]]$angle <- params$guide_params[[i]]$angle %|W|% + params$angle params$guide_params[[i]] <- params$guides[[i]]$train( params = params$guide_params[[i]], - scale = scale, aesthetic = aesthetic, + scale = scale, + aesthetic = aesthetic, ... ) } @@ -127,7 +144,8 @@ GuideAxisStack <- ggproto( for (i in seq_along(params$guides)) { params$guide_params[[i]] <- params$guides[[i]]$transform( params = params$guide_params[[i]], - coord = coord, panel_params = panel_params + coord = coord, + panel_params = panel_params ) } params @@ -144,25 +162,30 @@ GuideAxisStack <- ggproto( params }, - draw = function(self, theme, position = NULL, direction = NULL, - params = self$params) { + draw = function( + self, + theme, + position = NULL, + direction = NULL, + params = self$params + ) { theme <- add_theme(theme, params$theme) - position <- params$position %||% position + position <- params$position %||% position direction <- params$direction %||% direction # If we are instructed to not draw labels at interior panels, just render # the first axis - draw_label <- params$draw_label %||% TRUE + draw_label <- params$draw_label %||% TRUE guide_index <- if (draw_label) seq_along(params$guides) else 1L if (position %in% c("theta", "theta.sec")) { # If we are a theta guide, we need to keep track how much space in the # radial direction a guide occupies, and add that as an offset to the # next guide. - offset <- unit(0, "cm") + offset <- unit(0, "cm") spacing <- params$spacing %||% unit(2.25, "pt") - grobs <- list() + grobs <- list() for (i in guide_index) { # Add offset to params @@ -170,7 +193,9 @@ GuideAxisStack <- ggproto( pars$stack_offset <- offset # Draw guide grobs[[i]] <- params$guides[[i]]$draw( - theme, position = position, direction = direction, + theme, + position = position, + direction = direction, params = pars ) # Increment offset @@ -189,7 +214,9 @@ GuideAxisStack <- ggproto( pars <- params$guide_params[[i]] pars$draw_label <- draw_label grobs[[i]] <- params$guides[[i]]$draw( - theme, position = position, direction = direction, + theme, + position = position, + direction = direction, params = pars ) } @@ -202,7 +229,7 @@ GuideAxisStack <- ggproto( along <- seq_along(grobs) # Get sizes - widths <- inject(unit.c(!!!lapply(grobs, grobWidth))) + widths <- inject(unit.c(!!!lapply(grobs, grobWidth))) heights <- inject(unit.c(!!!lapply(grobs, grobHeight))) # Set spacing @@ -216,40 +243,53 @@ GuideAxisStack <- ggproto( # Reorder grobs/sizes if necessary if (position %in% c("top", "left")) { - along <- rev(along) - widths <- rev(widths) + along <- rev(along) + widths <- rev(widths) heights <- rev(heights) } # Place guides in a gtable, apply spacing if (position %in% c("bottom", "top")) { gt <- gtable(widths = unit(1, "npc"), heights = heights) - gt <- gtable_add_grob(gt, grobs, t = along, l = 1, name = "axis", clip = "off") + gt <- gtable_add_grob( + gt, + grobs, + t = along, + l = 1, + name = "axis", + clip = "off" + ) gt <- gtable_add_row_space(gt, height = spacing) vp <- exec( viewport, - y = unit(as.numeric(position == "bottom"), "npc"), + y = unit(as.numeric(position == "bottom"), "npc"), height = grobHeight(gt), just = opposite_position(position) ) } else { gt <- gtable(widths = widths, heights = unit(1, "npc")) - gt <- gtable_add_grob(gt, grobs, t = 1, l = along, name = "axis", clip = "off") + gt <- gtable_add_grob( + gt, + grobs, + t = 1, + l = along, + name = "axis", + clip = "off" + ) gt <- gtable_add_col_space(gt, width = spacing) vp <- exec( viewport, - x = unit(as.numeric(position == "left"), "npc"), + x = unit(as.numeric(position == "left"), "npc"), width = grobWidth(gt), - just = opposite_position(position) + just = opposite_position(position) ) } absoluteGrob( - grob = gList(gt), - width = gtable_width(gt), + grob = gList(gt), + width = gtable_width(gt), height = gtable_height(gt), vp = vp ) } ) - diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index 796b406f96..30a56cc778 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -23,10 +23,15 @@ NULL #' #' # The `angle` argument can be used to set relative angles #' p + guides(theta = guide_axis_theta(angle = 0)) -guide_axis_theta <- function(title = waiver(), theme = NULL, angle = waiver(), - minor.ticks = FALSE, cap = "none", order = 0, - position = waiver()) { - +guide_axis_theta <- function( + title = waiver(), + theme = NULL, + angle = waiver(), + minor.ticks = FALSE, + cap = "none", + order = 0, + position = waiver() +) { check_bool(minor.ticks) if (is.logical(cap)) { check_bool(cap) @@ -40,7 +45,7 @@ guide_axis_theta <- function(title = waiver(), theme = NULL, angle = waiver(), # customisations angle = angle, cap = cap, - minor.ticks = minor.ticks, + minor.ticks = minor.ticks, theme = theme, # parameter @@ -59,15 +64,21 @@ guide_axis_theta <- function(title = waiver(), theme = NULL, angle = waiver(), #' @usage NULL #' @export GuideAxisTheta <- ggproto( - "GuideAxisTheta", GuideAxis, + "GuideAxisTheta", + GuideAxis, transform = function(params, coord, panel_params) { - position <- params$position if (!is.null(position)) { opposite_var <- setdiff(c("x", "y"), params$aesthetic) - opposite_value <- switch(position, top = , right = , theta.sec = -Inf, Inf) + opposite_value <- switch( + position, + top = , + right = , + theta.sec = -Inf, + Inf + ) if (is.unsorted(panel_params$inner_radius %||% NA)) { opposite_value <- -opposite_value } @@ -92,10 +103,10 @@ GuideAxisTheta <- ggproto( # standard axes to be visually similar. key$theta <- switch( params$position, - top = 0, - bottom = 1 * pi, - left = 1.5 * pi, - right = 0.5 * pi + top = 0, + bottom = 1 * pi, + left = 1.5 * pi, + right = 0.5 * pi ) } else { if (params$position == 'theta.sec') { @@ -104,9 +115,11 @@ GuideAxisTheta <- ggproto( # If the first and last positions are close together, we merge the # labels of these positions - if (n > 1L && - (key$theta[n] - key$theta[1]) %% (2 * pi) < 0.05 && - !is.null(key$.label)) { + if ( + n > 1L && + (key$theta[n] - key$theta[1]) %% (2 * pi) < 0.05 && + !is.null(key$.label) + ) { if (is.expression(key$.label[[1]])) { combined <- substitute( paste(a, "/", b), @@ -132,20 +145,29 @@ GuideAxisTheta <- ggproto( setup_elements = function(params, elements, theme) { theme <- add_theme(theme, params$theme) - axis_elem <- c("line", "text", "ticks", "minor", "major_length", "minor_length") + axis_elem <- c( + "line", + "text", + "ticks", + "minor", + "major_length", + "minor_length" + ) is_char <- vapply(elements[axis_elem], is.character, logical(1)) axis_elem <- axis_elem[is_char] - aes <- params$theme_suffix %||% switch( - params$position, - theta = "x.bottom", - theta.sec = "x.top", - paste0(params$aesthetic, ".", params$position) - ) + aes <- params$theme_suffix %||% + switch( + params$position, + theta = "x.bottom", + theta.sec = "x.top", + paste0(params$aesthetic, ".", params$position) + ) elements[axis_elem] <- lapply( paste(unlist(elements[axis_elem]), aes, sep = "."), - calc_element, theme = theme + calc_element, + theme = theme ) # Offset distance from axis arc to text positions @@ -154,7 +176,8 @@ GuideAxisTheta <- ggproto( } offset <- max(unit(0, "pt"), elements$major_length, elements$minor_length) - elements$offset <- offset + max(try_prop(elements$text, "margin", default = unit(0, "pt"))) + elements$offset <- offset + + max(try_prop(elements$text, "margin", default = unit(0, "pt"))) elements }, @@ -183,7 +206,6 @@ GuideAxisTheta <- ggproto( }, build_labels = function(key, elements, params) { - if (is_theme_element(elements$text, "blank")) { return(zeroGrob()) } @@ -222,8 +244,8 @@ GuideAxisTheta <- ggproto( element_grob( elements$text, label = labels, - x = unit(key$x, "npc") + xoffset, - y = unit(key$y, "npc") + yoffset, + x = unit(key$x, "npc") + xoffset, + y = unit(key$y, "npc") + yoffset, hjust = 0.5 - sin(theta + rad) / 2, vjust = 0.5 - cos(theta + rad) / 2, angle = angle @@ -234,19 +256,26 @@ GuideAxisTheta <- ggproto( offset <- params$stack_offset major <- theta_tickmarks( vec_slice(key, (key$.type %||% "major") == "major"), - elements$ticks, elements$major_length, offset = offset + elements$ticks, + elements$major_length, + offset = offset ) minor <- theta_tickmarks( vec_slice(key, (key$.type %||% "major") == "minor"), - elements$minor, elements$minor_length, offset = offset + elements$minor, + elements$minor_length, + offset = offset ) grobTree(major, minor, name = "ticks") }, draw_early_exit = function(self, params, elements) { - line <- self$build_decor(decor = params$decor, elements = elements, - params = params) + line <- self$build_decor( + decor = params$decor, + elements = elements, + params = params + ) gTree(children = gList(line), offset = unit(0, "cm")) }, @@ -281,16 +310,22 @@ GuideAxisTheta <- ggproto( angle <- key$theta + deg2rad(angle) # Set margin - margin <- rep(max(try_prop(elements$text, "margin", default = unit(0, "pt"))), length.out = 4) + margin <- rep( + max(try_prop(elements$text, "margin", default = unit(0, "pt"))), + length.out = 4 + ) # Measure size of each individual label single_labels <- lapply(labels, function(lab) { element_grob( - elements$text, label = lab, - margin = margin, margin_x = TRUE, margin_y = TRUE + elements$text, + label = lab, + margin = margin, + margin_x = TRUE, + margin_y = TRUE ) }) - widths <- width_cm(single_labels) + widths <- width_cm(single_labels) heights <- height_cm(single_labels) # Set text justification @@ -319,7 +354,6 @@ GuideAxisTheta <- ggproto( }, assemble_drawing = function(grobs, layout, sizes, params, elements) { - # Fix order of grobs grobs <- grobs[c("title", "labels", "ticks", "decor")] @@ -339,7 +373,8 @@ GuideAxisTheta <- ggproto( ) vp <- viewport( y = unit(as.numeric(params$position == "bottom"), "npc"), - height = height, width = unit(1, "npc"), + height = height, + width = unit(1, "npc"), just = opposite_position(params$position) ) } else { @@ -349,14 +384,15 @@ GuideAxisTheta <- ggproto( ) vp <- viewport( x = unit(as.numeric(params$position == "left"), "npc"), - height = unit(1, "npc"), width = width, + height = unit(1, "npc"), + width = width, just = opposite_position(params$position) ) } absoluteGrob( inject(gList(!!!grobs)), - width = vp$width, + width = vp$width, height = vp$height, vp = vp ) @@ -370,10 +406,10 @@ theta_tickmarks <- function(key, element, length, offset = NULL) { } length <- rep(length, length.out = n_breaks * 2) - angle <- rep(key$theta, each = 2) - x <- rep(key$x, each = 2) - y <- rep(key$y, each = 2) - length <- rep(c(0, 1), times = n_breaks) * length + angle <- rep(key$theta, each = 2) + x <- rep(key$x, each = 2) + y <- rep(key$y, each = 2) + length <- rep(c(0, 1), times = n_breaks) * length if (!is.null(offset)) { length <- length + offset } diff --git a/R/guide-axis.R b/R/guide-axis.R index 5f5aa9b8b1..8b0ec7dfb8 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -1,4 +1,3 @@ - #' Axis guide #' #' Axis guides are the visual representation of position scales like those @@ -49,9 +48,17 @@ #' #' # can also be used to add a duplicate guide #' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) -guide_axis <- function(title = waiver(), theme = NULL, check.overlap = FALSE, - angle = waiver(), n.dodge = 1, minor.ticks = FALSE, - cap = "none", order = 0, position = waiver()) { +guide_axis <- function( + title = waiver(), + theme = NULL, + check.overlap = FALSE, + angle = waiver(), + n.dodge = 1, + minor.ticks = FALSE, + cap = "none", + order = 0, + position = waiver() +) { check_bool(minor.ticks) if (is.logical(cap)) { check_bool(cap) @@ -86,20 +93,21 @@ guide_axis <- function(title = waiver(), theme = NULL, check.overlap = FALSE, #' @usage NULL #' @export GuideAxis <- ggproto( - "GuideAxis", Guide, + "GuideAxis", + Guide, params = list( - title = waiver(), - theme = NULL, - name = "axis", - hash = character(), - position = waiver(), + title = waiver(), + theme = NULL, + name = "axis", + hash = character(), + position = waiver(), direction = NULL, - angle = NULL, - n.dodge = 1, + angle = NULL, + n.dodge = 1, minor.ticks = FALSE, - cap = "none", - order = 0, + cap = "none", + order = 0, check.overlap = FALSE ), @@ -108,8 +116,8 @@ GuideAxis <- ggproto( hashables = exprs(title, key$.value, key$.label, name), elements = list( - line = "axis.line", - text = "axis.text", + line = "axis.line", + text = "axis.text", ticks = "axis.ticks", minor = "axis.minor.ticks", major_length = "axis.ticks.length", @@ -156,7 +164,6 @@ GuideAxis <- ggproto( }, extract_decor = function(scale, aesthetic, position, key, cap = "none", ...) { - value <- c(-Inf, Inf) has_key <- !(is.null(key) || nrow(key) < 1) if (cap %in% c("both", "upper") && has_key) { @@ -177,8 +184,8 @@ GuideAxis <- ggproto( check <- FALSE aesthetic <- names(key)[!grepl("^\\.", names(key))] - ortho <- setdiff(c("x", "y"), params$aesthetic) - override <- switch(position %||% "", bottom = , left = -Inf, Inf) + ortho <- setdiff(c("x", "y"), params$aesthetic) + override <- switch(position %||% "", bottom = , left = -Inf, Inf) if (!(panel_params$reverse %||% "none") %in% c("xy", ortho)) { override <- -override @@ -266,41 +273,63 @@ GuideAxis <- ggproto( if (is_theme_element(elements$ticks, "blank")) { elements$major_length <- unit(0, "cm") } - if (is_theme_element(elements$minor, "blank") || isFALSE(params$minor.ticks)) { + if ( + is_theme_element(elements$minor, "blank") || isFALSE(params$minor.ticks) + ) { elements$minor_length <- unit(0, "cm") } return(elements) }, setup_params = function(params) { - position <- arg_match0(params$position, .trbl) + position <- arg_match0(params$position, .trbl) direction <- if (position %in% c("left", "right")) { "vertical" } else { "horizontal" } - new_params <- c("aes", "orth_aes", "para_sizes", "orth_size", "orth_sizes", - "vertical", "measure_gtable", "measure_text") + new_params <- c( + "aes", + "orth_aes", + "para_sizes", + "orth_size", + "orth_sizes", + "vertical", + "measure_gtable", + "measure_text" + ) if (direction == "vertical") { params[new_params] <- list( - "y", "x", "heights", "width", "widths", - TRUE, gtable_width, width_cm + "y", + "x", + "heights", + "width", + "widths", + TRUE, + gtable_width, + width_cm ) } else { params[new_params] <- list( - "x", "y", "widths", "height", "heights", - FALSE, gtable_height, height_cm + "x", + "y", + "widths", + "height", + "heights", + FALSE, + gtable_height, + height_cm ) } new_params <- list( - opposite = opposite_position(position), + opposite = opposite_position(position), secondary = position %in% c("top", "right"), lab_first = position %in% c("top", "left"), orth_side = if (position %in% c("top", "right")) 0 else 1, direction = direction, - position = position + position = position ) c(params, new_params) }, @@ -322,10 +351,11 @@ GuideAxis <- ggproto( }, build_ticks = function(key, elements, params, position = params$opposite) { - major <- Guide$build_ticks( vec_slice(key, (key$.type %||% "major") == "major"), - elements$ticks, params, position, + elements$ticks, + params, + position, elements$major_length ) @@ -335,19 +365,20 @@ GuideAxis <- ggproto( minor <- Guide$build_ticks( vec_slice(key, (key$.type %||% "major") == "minor"), - elements$minor, params, position, + elements$minor, + params, + position, elements$minor_length ) grobTree(major, minor, name = "ticks") }, build_labels = function(key, elements, params) { - if (".type" %in% names(key)) { key <- vec_slice(key, key$.type == "major") } - labels <- validate_labels(key$.label) + labels <- validate_labels(key$.label) n_labels <- length(labels) if (n_labels < 1) { @@ -356,22 +387,21 @@ GuideAxis <- ggproto( pos <- key[[params$aes]] - dodge_pos <- rep(seq_len(params$n.dodge %||% 1), length.out = n_labels) + dodge_pos <- rep(seq_len(params$n.dodge %||% 1), length.out = n_labels) dodge_indices <- unname(split(seq_len(n_labels), dodge_pos)) lapply(dodge_indices, function(indices) { draw_axis_labels( break_positions = pos[indices], - break_labels = labels[indices], - label_element = elements$text, - is_vertical = params$vertical, - check.overlap = params$check.overlap %||% FALSE + break_labels = labels[indices], + label_element = elements$text, + is_vertical = params$vertical, + check.overlap = params$check.overlap %||% FALSE ) }) }, measure_grobs = function(grobs, params, elements) { - # Below, we include a spacer measurement. This measurement is used # to offset subsequent rows/columns in the gtable in case the tick length is # negative. This causes the text to align nicely at panel borders. @@ -393,7 +423,7 @@ GuideAxis <- ggproto( # Text labels <- unit(measure(grobs$labels), "cm") - title <- unit(measure(grobs$title), "cm") + title <- unit(measure(grobs$title), "cm") sizes <- unit.c(length, spacer, labels, title) if (params$lab_first) { @@ -403,7 +433,6 @@ GuideAxis <- ggproto( }, arrange_layout = function(key, sizes, params, elements) { - layout <- seq_along(sizes) if (params$lab_first) { @@ -418,14 +447,13 @@ GuideAxis <- ggproto( }, assemble_drawing = function(grobs, layout, sizes, params, elements) { - axis_line <- grobs$decor # Unlist the 'label' grobs z <- if (params$position == "left") c(2, 1, 3) else 1:3 z <- rep(z, c(1, length(grobs$labels), 1)) has_labels <- !is_zero(grobs$labels[[1]]) - grobs <- c(list(grobs$ticks), grobs$labels, list(grobs$title)) + grobs <- c(list(grobs$ticks), grobs$labels, list(grobs$title)) # Initialise empty gtable gt <- exec( @@ -437,9 +465,14 @@ GuideAxis <- ggproto( # Add grobs gt <- gtable_add_grob( - gt, grobs, - t = layout$t, b = layout$b, l = layout$l, r = layout$r, - clip = "off", z = z + gt, + grobs, + t = layout$t, + b = layout$b, + l = layout$l, + r = layout$r, + clip = "off", + z = z ) # Set justification viewport @@ -468,18 +501,21 @@ GuideAxis <- ggproto( # Assemble with axis line absoluteGrob( gList(axis_line, gt), - width = gtable_width(gt), + width = gtable_width(gt), height = gtable_height(gt), vp = vp ) }, draw_early_exit = function(self, params, elements) { - line <- self$build_decor(decor = params$decor, elements = elements, - params = params) + line <- self$build_decor( + decor = params$decor, + elements = elements, + params = params + ) absoluteGrob( gList(line), - width = grobWidth(line), + width = grobWidth(line), height = grobHeight(line) ) } @@ -506,12 +542,21 @@ GuideAxis <- ggproto( #' #' @noRd #' -draw_axis <- function(break_positions, break_labels, axis_position, theme, - check.overlap = FALSE, angle = NULL, n.dodge = 1) { - guide <- guide_axis(check.overlap = check.overlap, - angle = angle, - n.dodge = n.dodge, - position = axis_position) +draw_axis <- function( + break_positions, + break_labels, + axis_position, + theme, + check.overlap = FALSE, + angle = NULL, + n.dodge = 1 +) { + guide <- guide_axis( + check.overlap = check.overlap, + angle = angle, + n.dodge = n.dodge, + position = axis_position + ) params <- guide$params aes <- if (axis_position %in% c("top", "bottom")) "x" else "y" opp <- setdiff(c("x", "y"), aes) @@ -529,9 +574,13 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme, guide$draw(theme, params = params) } -draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical, - check.overlap = FALSE) { - +draw_axis_labels <- function( + break_positions, + break_labels, + label_element, + is_vertical, + check.overlap = FALSE +) { position_dim <- if (is_vertical) "y" else "x" label_margin_name <- if (is_vertical) "margin_x" else "margin_y" @@ -545,7 +594,8 @@ draw_axis_labels <- function(break_positions, break_labels, label_element, is_ve } labels_grob <- exec( - element_grob, label_element, + element_grob, + label_element, !!position_dim := break_positions, !!label_margin_name := TRUE, label = break_labels, @@ -594,9 +644,11 @@ axis_label_priority_between <- function(x, y) { #' overridden from the user- or theme-supplied element. #' @noRd label_angle_heuristic <- function(element, position, angle) { - if (!is_theme_element(element, "text") - || is.null(position) - || is.null(angle %|W|% NULL)) { + if ( + !is_theme_element(element, "text") || + is.null(position) || + is.null(angle %|W|% NULL) + ) { return(element) } arg_match0(position, .trbl) @@ -610,11 +662,23 @@ label_angle_heuristic <- function(element, position, angle) { # The rounding step ensures we can get (co)sine to exact 0 so it can become 0.5 # which we need for center-justifications cosine <- sign(round(cos(radian), digits)) / 2 + 0.5 - sine <- sign(round(sin(radian), digits)) / 2 + 0.5 + sine <- sign(round(sin(radian), digits)) / 2 + 0.5 # Depending on position, we might need to swap or flip justification values - hjust <- switch(position, left = cosine, right = 1 - cosine, top = 1 - sine, sine) - vjust <- switch(position, left = 1 - sine, right = sine, top = 1 - cosine, cosine) + hjust <- switch( + position, + left = cosine, + right = 1 - cosine, + top = 1 - sine, + sine + ) + vjust <- switch( + position, + left = 1 - sine, + right = sine, + top = 1 - cosine, + cosine + ) element@angle <- angle %||% try_prop(element, "angle") element@hjust <- hjust %||% try_prop(element, "hjust") diff --git a/R/guide-bins.R b/R/guide-bins.R index d62d7af67b..fca31066ee 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -69,16 +69,15 @@ guide_bins <- function( theme = NULL, # general - angle = NULL, - position = NULL, - direction = NULL, + angle = NULL, + position = NULL, + direction = NULL, override.aes = list(), - reverse = FALSE, - order = 0, - show.limits = NULL, + reverse = FALSE, + order = 0, + show.limits = NULL, ... ) { - theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { position <- arg_match0(position, c(.trbl, "inside")) @@ -111,7 +110,8 @@ guide_bins <- function( #' @usage NULL #' @export GuideBins <- ggproto( - "GuideBins", GuideLegend, + "GuideBins", + GuideLegend, params = list( title = waiver(), @@ -137,15 +137,19 @@ GuideBins <- ggproto( elements = c( GuideLegend$elements, list( - axis_line = "legend.axis.line", + axis_line = "legend.axis.line", ticks_length = "legend.ticks.length", - ticks = "legend.ticks" + ticks = "legend.ticks" ) ), - extract_key = function(scale, aesthetic, show.limits = FALSE, - reverse = FALSE, ...) { - + extract_key = function( + scale, + aesthetic, + show.limits = FALSE, + reverse = FALSE, + ... + ) { breaks <- scale$get_breaks() parsed <- parse_binned_breaks(scale, breaks) @@ -155,16 +159,22 @@ GuideBins <- ggproto( limits <- parsed$limits breaks <- parsed$breaks - key <- data_frame(c(scale$map(parsed$bin_at), NA), - .name_repair = ~ aesthetic) + key <- data_frame( + c(scale$map(parsed$bin_at), NA), + .name_repair = ~aesthetic + ) key$.value <- (seq_along(key[[1]]) - 1) / (nrow(key) - 1) - key$.show <- NA + key$.show <- NA labels <- scale$get_labels(breaks) labels <- labels[!is.na(breaks)] breaks <- breaks[!is.na(breaks)] - if (is.character(scale$labels) || is.numeric(scale$labels) || is.expression(scale$labels)) { + if ( + is.character(scale$labels) || + is.numeric(scale$labels) || + is.expression(scale$labels) + ) { limit_lab <- c(NA, NA) } else { limit_lab <- scale$get_labels(limits) @@ -186,20 +196,29 @@ GuideBins <- ggproto( return(key) }, - extract_params = function(scale, params, - title = waiver(), direction = NULL, ...) { - + extract_params = function( + scale, + params, + title = waiver(), + direction = NULL, + ... + ) { show.limits <- params$show.limits %||% scale$show.limits %||% FALSE - if (show.limits && - (is.character(scale$labels) || is.numeric(scale$labels))) { - cli::cli_warn(c(paste0( - "{.arg show.limits} is ignored when {.arg labels} are given as a ", - "character vector." - ), "i" = paste0( - "Either add the limits to {.arg breaks} or provide a function for ", - "{.arg labels}." - ))) + if ( + show.limits && + (is.character(scale$labels) || is.numeric(scale$labels)) + ) { + cli::cli_warn(c( + paste0( + "{.arg show.limits} is ignored when {.arg labels} are given as a ", + "character vector." + ), + "i" = paste0( + "Either add the limits to {.arg breaks} or provide a function for ", + "{.arg labels}." + ) + )) show.limits <- FALSE } show.limits <- rep(show.limits, length.out = 2) @@ -214,7 +233,10 @@ GuideBins <- ggproto( ord <- seq_len(nrow(key)) key <- vec_slice(key, rev(ord)) # Put NA back in the trailing position - key[params$aesthetic] <- vec_slice(key[params$aesthetic], c(ord[-1], ord[1])) + key[params$aesthetic] <- vec_slice( + key[params$aesthetic], + c(ord[-1], ord[1]) + ) key$.value <- 1 - key$.value } @@ -233,15 +255,15 @@ GuideBins <- ggproto( valid_position <- switch( params$direction, "horizontal" = c("bottom", "top"), - "vertical" = c("right", "left") + "vertical" = c("right", "left") ) # Set defaults theme <- replace_null( theme, legend.text.position = valid_position[1], - legend.axis.line = params$default_axis, - legend.ticks = params$default_ticks + legend.axis.line = params$default_axis, + legend.ticks = params$default_ticks ) # Let the legend guide handle the rest @@ -269,14 +291,16 @@ GuideBins <- ggproto( key$.value <- 1 - key$.value } - list(labels = flip_element_grob( - elements$text, - label = validate_labels(key$.label), - x = unit(key$.value, "npc"), - margin_x = FALSE, - margin_y = TRUE, - flip = params$direction == "vertical" - )) + list( + labels = flip_element_grob( + elements$text, + label = validate_labels(key$.label), + x = unit(key$.value, "npc"), + margin_x = FALSE, + margin_y = TRUE, + flip = params$direction == "vertical" + ) + ) }, build_ticks = function(key, elements, params, position = params$position) { @@ -295,8 +319,11 @@ GuideBins <- ggproto( decor <- GuideLegend$build_decor(decor, grobs, elements, params) sizes <- measure_legend_keys( - decor, nkeys, dim, byrow = FALSE, - default_width = elements$width_cm, + decor, + nkeys, + dim, + byrow = FALSE, + default_width = elements$width_cm, default_height = elements$height_cm ) sizes <- lapply(sizes, function(x) rep_len(max(x), length(x))) @@ -305,25 +332,31 @@ GuideBins <- ggproto( key_id <- rep(seq_len(nkeys), each = n_layers) key_nm <- paste("key", key_id, c("bg", seq_len(n_layers - 1))) if (params$direction == "vertical") { - top <- key_id + top <- key_id left <- 1 } else { - top <- 1 + top <- 1 left <- key_id } gt <- gtable( - widths = unit(sizes$widths, "cm"), + widths = unit(sizes$widths, "cm"), heights = unit(sizes$heights, "cm") ) - gt <- gtable_add_grob(gt, decor, t = top, l = left, - name = key_nm, clip = "off") + gt <- gtable_add_grob( + gt, + decor, + t = top, + l = left, + name = key_nm, + clip = "off" + ) axis <- switch( elements$text_position, - "top" = list(x = c(0, 1), y = c(1, 1)), + "top" = list(x = c(0, 1), y = c(1, 1)), "bottom" = list(x = c(0, 1), y = c(0, 0)), - "left" = list(x = c(0, 0), y = c(0, 1)), - "right" = list(x = c(1, 1), y = c(0, 1)) + "left" = list(x = c(0, 0), y = c(0, 1)), + "right" = list(x = c(1, 1), y = c(0, 1)) ) axis <- element_grob(elements$axis_line, x = axis$x, y = axis$y) @@ -332,7 +365,7 @@ GuideBins <- ggproto( measure_grobs = function(grobs, params, elements) { params$sizes <- list( - widths = sum( width_cm(grobs$decor$keys)), + widths = sum(width_cm(grobs$decor$keys)), heights = sum(height_cm(grobs$decor$keys)) ) GuideLegend$measure_grobs(grobs, params, elements) @@ -340,7 +373,6 @@ GuideBins <- ggproto( ) parse_binned_breaks <- function(scale, breaks = scale$get_breaks()) { - if (is_waiver(scale$labels) || is.function(scale$labels)) { breaks <- breaks[!is.na(breaks)] } @@ -360,9 +392,9 @@ parse_binned_breaks <- function(scale, breaks = scale$get_breaks()) { bin_at <- all_breaks[-1] - diff(all_breaks) / 2 } else { bin_at <- breaks - nums <- as.character(breaks) - nums <- strsplit(gsub("\\(|\\)|\\[|\\]", "", nums), ",\\s?") - nums <- as.numeric(unlist(nums, FALSE, FALSE)) + nums <- as.character(breaks) + nums <- strsplit(gsub("\\(|\\)|\\[|\\]", "", nums), ",\\s?") + nums <- as.numeric(unlist(nums, FALSE, FALSE)) if (anyNA(nums)) { cli::cli_abort(c( @@ -371,8 +403,8 @@ parse_binned_breaks <- function(scale, breaks = scale$get_breaks()) { )) } all_breaks <- nums[c(1, seq_along(breaks) * 2)] - limits <- all_breaks[ c(1, length(all_breaks))] - breaks <- all_breaks[-c(1, length(all_breaks))] + limits <- all_breaks[c(1, length(all_breaks))] + breaks <- all_breaks[-c(1, length(all_breaks))] } list( breaks = breaks, diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index c38a5fc2d2..f978658a76 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -135,7 +135,11 @@ guide_colourbar <- function( ... ) { if (lifecycle::is_present(raster)) { - deprecate_soft0("3.5.0", "guide_colourbar(raster)", "guide_colourbar(display)") + deprecate_soft0( + "3.5.0", + "guide_colourbar(raster)", + "guide_colourbar(display)" + ) check_bool(raster) display <- if (raster) "raster" else "rectangles" } @@ -175,7 +179,8 @@ guide_colorbar <- guide_colourbar #' @usage NULL #' @export GuideColourbar <- ggproto( - "GuideColourbar", GuideLegend, + "GuideColourbar", + GuideLegend, params = list( # title @@ -210,19 +215,19 @@ GuideColourbar <- ggproto( hashables = exprs(title, key$.label, decor, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - text = "legend.text", - theme.title = "legend.title", - text_position = "legend.text.position", + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + text = "legend.text", + theme.title = "legend.title", + text_position = "legend.text.position", title_position = "legend.title.position", - axis_line = "legend.axis.line", - ticks = "legend.ticks", - ticks_length = "legend.ticks.length", - frame = "legend.frame" + axis_line = "legend.axis.line", + ticks = "legend.ticks", + ticks_length = "legend.ticks.length", + frame = "legend.frame" ), extract_key = function(scale, aesthetic, ...) { @@ -237,8 +242,14 @@ GuideColourbar <- ggproto( key }, - extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, alpha = NA, ...) { - + extract_decor = function( + scale, + aesthetic, + nbin = 300, + reverse = FALSE, + alpha = NA, + ... + ) { limits <- scale$get_limits() bar <- seq(limits[1], limits[2], length.out = nbin) if (length(bar) == 0) { @@ -246,8 +257,8 @@ GuideColourbar <- ggproto( } bar <- data_frame0( colour = alpha(scale$map(bar), alpha), - value = bar, - .size = length(bar) + value = bar, + .size = length(bar) ) if (reverse) { bar <- bar[nrow(bar):1, , drop = FALSE] @@ -255,8 +266,7 @@ GuideColourbar <- ggproto( return(bar) }, - extract_params = function(scale, params, - title = waiver(), ...) { + extract_params = function(scale, params, title = waiver(), ...) { params$title <- scale$make_title(params$title, scale$name, title) limits <- params$decor$value[c(1L, nrow(params$decor))] to <- switch( @@ -282,7 +292,8 @@ GuideColourbar <- ggproto( setup_params = function(params) { params$direction <- arg_match0( params$direction, - c("horizontal", "vertical"), arg_nm = "direction" + c("horizontal", "vertical"), + arg_nm = "direction" ) params }, @@ -302,8 +313,8 @@ GuideColourbar <- ggproto( theme <- replace_null( theme, legend.text.position = valid_position[1], - legend.ticks = params$default_ticks, - legend.frame = params$default_frame + legend.ticks = params$default_ticks, + legend.frame = params$default_frame ) # Let the legend guide handle the rest @@ -326,24 +337,30 @@ GuideColourbar <- ggproto( return(list(labels = zeroGrob())) } - list(labels = flip_element_grob( - elements$text, - label = validate_labels(key$.label), - x = unit(key$.value, "npc"), - margin_x = FALSE, - margin_y = TRUE, - flip = params$direction == "vertical" - )) + list( + labels = flip_element_grob( + elements$text, + label = validate_labels(key$.label), + x = unit(key$.value, "npc"), + margin_x = FALSE, + margin_y = TRUE, + flip = params$direction == "vertical" + ) + ) }, build_ticks = function(key, elements, params, position = params$position) { pos <- key$.value - if (!params$draw_lim[1]) pos <- pos[-1] - if (!params$draw_lim[2]) pos <- pos[-length(pos)] + if (!params$draw_lim[1]) { + pos <- pos[-1] + } + if (!params$draw_lim[2]) { + pos <- pos[-length(pos)] + } position <- switch( params$direction, "horizontal" = c("bottom", "top"), - "vertical" = c("right", "left") + "vertical" = c("right", "left") ) ticks_length <- rep(elements$ticks_length, length.out = 2) @@ -358,11 +375,11 @@ GuideColourbar <- ggproto( image <- switch( params$direction, "horizontal" = t(decor$colour), - "vertical" = rev(decor$colour) + "vertical" = rev(decor$colour) ) grob <- rasterGrob( - image = image, - width = 1, + image = image, + width = 1, height = 1, default.units = "npc", gp = gpar(col = NA), @@ -370,20 +387,23 @@ GuideColourbar <- ggproto( ) } else if (params$display == "rectangles") { if (params$direction == "horizontal") { - width <- 1 / nrow(decor) + width <- 1 / nrow(decor) height <- 1 x <- (seq_len(nrow(decor)) - 1) * width y <- 0 } else { - width <- 1 + width <- 1 height <- 1 / nrow(decor) y <- (seq_len(nrow(decor)) - 1) * height x <- 0 } grob <- rectGrob( - x = x, y = y, - vjust = 0, hjust = 0, - width = width, height = height, + x = x, + y = y, + vjust = 0, + hjust = 0, + width = width, + height = height, default.units = "npc", gp = gg_par(col = NA, fill = decor$colour) ) @@ -397,7 +417,7 @@ GuideColourbar <- ggproto( position <- switch( params$direction, horizontal = list(y1 = unit(0.5, "npc"), y2 = unit(0.5, "npc")), - vertical = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc")) + vertical = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc")) ) gradient <- inject(linearGradient(decor$colour, value, !!!position)) grob <- rectGrob(gp = gg_par(fill = gradient, col = NA)) @@ -410,7 +430,7 @@ GuideColourbar <- ggproto( measure_grobs = function(grobs, params, elements) { params$sizes <- list( - widths = elements$width_cm, + widths = elements$width_cm, heights = elements$height_cm ) GuideLegend$measure_grobs(grobs, params, elements) diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index 83cdf53508..809f5a4e32 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -50,7 +50,7 @@ guide_coloursteps <- function( theme = NULL, alpha = NA, angle = NULL, - even.steps = TRUE, + even.steps = TRUE, show.limits = NULL, direction = NULL, position = NULL, @@ -59,7 +59,6 @@ guide_coloursteps <- function( available_aes = c("colour", "color", "fill"), ... ) { - theme <- deprecated_guide_args(theme, ...) check_number_decimal(alpha, min = 0, max = 1, allow_na = TRUE) @@ -68,7 +67,7 @@ guide_coloursteps <- function( theme = theme, alpha = alpha, angle = angle, - even.steps = even.steps, + even.steps = even.steps, show.limits = show.limits, position = position, direction = direction, @@ -88,7 +87,8 @@ guide_colorsteps <- guide_coloursteps #' @usage NULL #' @export GuideColoursteps <- ggproto( - "GuideColoursteps", GuideColourbar, + "GuideColoursteps", + GuideColourbar, params = c( list(even.steps = TRUE, show.limits = NULL), @@ -96,7 +96,6 @@ GuideColoursteps <- ggproto( ), extract_key = function(scale, aesthetic, even.steps, ...) { - breaks <- scale$get_breaks() if (!(even.steps || !is.numeric(breaks))) { @@ -121,7 +120,7 @@ GuideColoursteps <- ggproto( key <- vec_slice(key, !is.na(breaks)) if (breaks[1] %in% limits) { - key$.value <- key$.value - 1L + key$.value <- key$.value - 1L key[[1]][1] <- NA } if (breaks[length(breaks)] %in% limits) { @@ -134,16 +133,22 @@ GuideColoursteps <- ggproto( key }, - extract_decor = function(scale, aesthetic, key, - reverse = FALSE, even.steps = TRUE, - nbin = 100, alpha = NA,...) { - + extract_decor = function( + scale, + aesthetic, + key, + reverse = FALSE, + even.steps = TRUE, + nbin = 100, + alpha = NA, + ... + ) { parsed <- attr(key, "parsed") breaks <- parsed$breaks %||% scale$get_breaks() limits <- parsed$limits %||% scale$get_limits() breaks <- sort(unique0(c(limits, breaks))) - n <- length(breaks) + n <- length(breaks) bin_at <- parsed$bin_at %||% ((breaks[-1] + breaks[-n]) / 2) if (even.steps) { @@ -152,25 +157,35 @@ GuideColoursteps <- ggproto( data_frame0( colour = alpha(scale$map(bin_at), alpha), - min = breaks[-n], - max = breaks[-1], - .size = length(bin_at) + min = breaks[-n], + max = breaks[-1], + .size = length(bin_at) ) }, - extract_params = function(scale, params, direction = "vertical", title = waiver(), ...) { - + extract_params = function( + scale, + params, + direction = "vertical", + title = waiver(), + ... + ) { show.limits <- params$show.limits %||% scale$show.limits %||% FALSE - if (show.limits && - (is.character(scale$labels) || is.numeric(scale$labels))) { - cli::cli_warn(c(paste0( - "{.arg show.limits} is ignored when {.arg labels} are given as a ", - "character vector." - ), "i" = paste0( - "Either add the limits to {.arg breaks} or provide a function for ", - "{.arg labels}." - ))) + if ( + show.limits && + (is.character(scale$labels) || is.numeric(scale$labels)) + ) { + cli::cli_warn(c( + paste0( + "{.arg show.limits} is ignored when {.arg labels} are given as a ", + "character vector." + ), + "i" = paste0( + "Either add the limits to {.arg breaks} or provide a function for ", + "{.arg labels}." + ) + )) show.limits <- FALSE } @@ -198,29 +213,36 @@ GuideColoursteps <- ggproto( limits <- rev(limits) } params$key$.value <- rescale(params$key$.value, from = limits) - params$decor$min <- rescale(params$decor$min, from = limits) - params$decor$max <- rescale(params$decor$max, from = limits) + params$decor$min <- rescale(params$decor$min, from = limits) + params$decor$max <- rescale(params$decor$max, from = limits) params$key <- vec_slice(params$key, !is.na(oob_censor_any(params$key$.value))) params }, build_decor = function(decor, grobs, elements, params) { - size <- abs(decor$max - decor$min) just <- as.numeric(decor$min > decor$max) - gp <- gg_par(col = NA, fill = decor$colour) + gp <- gg_par(col = NA, fill = decor$colour) if (params$direction == "vertical") { grob <- rectGrob( - x = 0, y = decor$min, - width = 1, height = size, - vjust = just, hjust = 0, gp = gp + x = 0, + y = decor$min, + width = 1, + height = size, + vjust = just, + hjust = 0, + gp = gp ) } else { grob <- rectGrob( - x = decor$min, y = 0, - height = 1, width = size, - hjust = just, vjust = 0, gp = gp + x = decor$min, + y = 0, + height = 1, + width = size, + hjust = just, + vjust = 0, + gp = gp ) } diff --git a/R/guide-custom.R b/R/guide-custom.R index d679a16759..82a58aeb2b 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -36,18 +36,26 @@ #' grob = grid::circleGrob(r = unit(1, "cm")) #' )) guide_custom <- function( - grob, width = grobWidth(grob), height = grobHeight(grob), - title = NULL, theme = NULL, - position = NULL, order = 0 + grob, + width = grobWidth(grob), + height = grobHeight(grob), + title = NULL, + theme = NULL, + position = NULL, + order = 0 ) { check_object(grob, is.grob, "a {.cls grob} object") check_object(width, is.unit, "a {.cls unit} object") check_object(height, is.unit, "a {.cls unit} object") if (length(width) != 1) { - cli::cli_abort("{.arg width} must be a single {.cls unit}, not a unit vector.") + cli::cli_abort( + "{.arg width} must be a single {.cls unit}, not a unit vector." + ) } if (length(height) != 1) { - cli::cli_abort("{.arg height} must be a single {.cls unit}, not a unit vector.") + cli::cli_abort( + "{.arg height} must be a single {.cls unit}, not a unit vector." + ) } new_guide( @@ -69,7 +77,8 @@ guide_custom <- function( #' @usage NULL #' @export GuideCustom <- ggproto( - "GuideCustom", Guide, + "GuideCustom", + Guide, params = c(Guide$params, list(grob = NULL, width = NULL, height = NULL)), @@ -77,8 +86,8 @@ GuideCustom <- ggproto( elements = list( background = "legend.background", - margin = "legend.margin", - title = "legend.title", + margin = "legend.margin", + title = "legend.title", title_position = "legend.title.position" ), @@ -90,9 +99,13 @@ GuideCustom <- ggproto( params }, - draw = function(self, theme, position = NULL, direction = NULL, - params = self$params) { - + draw = function( + self, + theme, + position = NULL, + direction = NULL, + params = self$params + ) { # Render title params <- replace_null(params, position = position, direction = direction) elems <- GuideLegend$setup_elements(params, self$elements, theme) @@ -105,14 +118,15 @@ GuideCustom <- ggproto( title_position <- elems$title_position # Start with putting the main grob in a gtable - width <- convertWidth(params$width, "cm", valueOnly = TRUE) + width <- convertWidth(params$width, "cm", valueOnly = TRUE) height <- convertHeight(params$height, "cm", valueOnly = TRUE) gt <- gtable(widths = unit(width, "cm"), heights = unit(height, "cm")) gt <- gtable_add_grob(gt, params$grob, t = 1, l = 1, clip = "off") - gt <- self$add_title( - gt, title, title_position, + gt, + title, + title_position, rotate_just(element = elems$title) ) @@ -120,9 +134,14 @@ GuideCustom <- ggproto( gt <- gtable_add_padding(gt, elems$margin %||% margin()) gt <- gtable_add_grob( - gt, element_grob(elems$background), - t = 1, l = 1, r = -1, b = -1, - z = -Inf, clip = "off" + gt, + element_grob(elems$background), + t = 1, + l = 1, + r = -1, + b = -1, + z = -Inf, + clip = "off" ) gt diff --git a/R/guide-legend.R b/R/guide-legend.R index 6378300c6d..b13ef38303 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -108,16 +108,15 @@ guide_legend <- function( theme = NULL, # General - position = NULL, - direction = NULL, + position = NULL, + direction = NULL, override.aes = list(), - nrow = NULL, - ncol = NULL, - reverse = FALSE, - order = 0, + nrow = NULL, + ncol = NULL, + reverse = FALSE, + order = 0, ... ) { - theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { @@ -140,7 +139,7 @@ guide_legend <- function( # Fixed parameters available_aes = "any", - name = "legend", + name = "legend", super = GuideLegend ) } @@ -150,7 +149,8 @@ guide_legend <- function( #' @usage NULL #' @export GuideLegend <- ggproto( - "GuideLegend", Guide, + "GuideLegend", + Guide, params = list( title = waiver(), @@ -163,8 +163,8 @@ GuideLegend <- ggproto( reverse = FALSE, order = 0, - name = "legend", - hash = character(), + name = "legend", + hash = character(), position = NULL, direction = NULL ), @@ -174,23 +174,22 @@ GuideLegend <- ggproto( hashables = exprs(title, key$.label, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - key_just = "legend.key.justification", - text = "legend.text", - theme.title = "legend.title", - spacing_x = "legend.key.spacing.x", - spacing_y = "legend.key.spacing.y", - text_position = "legend.text.position", + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + key_just = "legend.key.justification", + text = "legend.text", + theme.title = "legend.title", + spacing_x = "legend.key.spacing.x", + spacing_y = "legend.key.spacing.y", + text_position = "legend.text.position", title_position = "legend.title.position", - byrow = "legend.byrow" + byrow = "legend.byrow" ), - extract_params = function(scale, params, - title = waiver(), ...) { + extract_params = function(scale, params, title = waiver(), ...) { params$title <- scale$make_title(params$title, scale$name, title) if (isTRUE(params$reverse %||% FALSE)) { params$key <- params$key[nrow(params$key):1, , drop = FALSE] @@ -217,11 +216,14 @@ GuideLegend <- ggproto( # Arrange common data for vertical and horizontal legends process_layers = function(self, params, layers, data = NULL, theme = NULL) { - - include <- vapply(layers, function(layer) { - aes <- matched_aes(layer, params) - include_layer_in_guide(layer, aes) - }, logical(1)) + include <- vapply( + layers, + function(layer) { + aes <- matched_aes(layer, params) + include_layer_in_guide(layer, aes) + }, + logical(1) + ) if (!any(include)) { return(NULL) @@ -231,14 +233,12 @@ GuideLegend <- ggproto( }, get_layer_key = function(params, layers, data, theme = NULL) { - # Return empty guides as-is if (nrow(params$key) < 1) { return(params) } decor <- Map(layer = layers, df = data, f = function(layer, df) { - # Subset key to the column with aesthetic matching the layer matched_aes <- matched_aes(layer, params) key <- params$key[matched_aes] @@ -253,7 +253,12 @@ GuideLegend <- ggproto( # Filter non-existing levels if (length(matched_aes) > 0) { - key$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend) + key$.draw <- keep_key_data( + params$key, + df, + matched_aes, + layer$show.legend + ) } # Apply overrides @@ -261,8 +266,8 @@ GuideLegend <- ggproto( list( draw_key = layer$geom$draw_key, - data = key, - params = c(layer$computed_geom_params, layer$computed_stat_params) + data = key, + params = c(layer$computed_geom_params, layer$computed_stat_params) ) }) @@ -274,13 +279,17 @@ GuideLegend <- ggproto( setup_params = function(params) { params$direction <- arg_match0( params$direction, - c("horizontal", "vertical"), arg_nm = "direction" + c("horizontal", "vertical"), + arg_nm = "direction" ) params$n_breaks <- n_breaks <- nrow(params$key) # Resolve shape - if (!is.null(params$nrow) && !is.null(params$ncol) && - params$nrow * params$ncol < n_breaks) { + if ( + !is.null(params$nrow) && + !is.null(params$ncol) && + params$nrow * params$ncol < n_breaks + ) { cli::cli_abort(paste0( "{.arg nrow} * {.arg ncol} needs to be larger than the number of ", "breaks ({n_breaks})." @@ -303,11 +312,13 @@ GuideLegend <- ggproto( params$theme <- NULL # Resolve text positions - text_position <- theme$legend.text.position %||% "right" - title_position <- theme$legend.title.position %||% switch( - params$direction, - vertical = "top", horizontal = "left" - ) + text_position <- theme$legend.text.position %||% "right" + title_position <- theme$legend.title.position %||% + switch( + params$direction, + vertical = "top", + horizontal = "left" + ) theme$legend.text.position <- arg_match0(text_position, .trbl, arg_nm = "legend.text.position") theme$legend.title.position <- @@ -327,23 +338,26 @@ GuideLegend <- ggproto( # that any settings declared in `legend.title` will be honoured but we have # custom defaults for the guide. margin <- try_prop(calc_element("text", theme), "margin") - title <- theme(text = element_text( - hjust = 0, vjust = 0.5, - margin = position_margin(title_position, margin, gap) - )) + title <- theme( + text = element_text( + hjust = 0, + vjust = 0.5, + margin = position_margin(title_position, margin, gap) + ) + ) elements$title <- calc_element("legend.title", add_theme(theme, title)) # Resolve text, setting default justification and margins. Again, the # trick here is to set the main text element to propagate defaults while # honouring the `legend.text` settings. margin <- position_margin(text_position, margin, gap) - text <- theme( + text <- theme( text = switch( text_position, - top = element_text(hjust = 0.5, vjust = 0.0, margin = margin), + top = element_text(hjust = 0.5, vjust = 0.0, margin = margin), bottom = element_text(hjust = 0.5, vjust = 1.0, margin = margin), - left = element_text(hjust = 1.0, vjust = 0.5, margin = margin), - right = element_text(hjust = 0.0, vjust = 0.5, margin = margin) + left = element_text(hjust = 1.0, vjust = 0.5, margin = margin), + right = element_text(hjust = 0.0, vjust = 0.5, margin = margin) ) ) elements$text <- calc_element("legend.text", add_theme(theme, text)) @@ -351,13 +365,12 @@ GuideLegend <- ggproto( }, override_elements = function(params, elements, theme) { - if (any(c("key_width", "key_height") %in% names(elements))) { # Determine if the key is stretched elements$stretch_x <- unitType(elements$key_width) == "null" elements$stretch_y <- unitType(elements$key_height) == "null" # Convert key sizes to cm - elements$width_cm <- width_cm(elements$key_width) + elements$width_cm <- width_cm(elements$key_width) elements$height_cm <- height_cm(elements$key_height) } @@ -394,7 +407,6 @@ GuideLegend <- ggproto( }, build_decor = function(decor, grobs, elements, params) { - key_size <- c(elements$width_cm, elements$height_cm) just <- elements$key_just idx <- seq_len(params$n_breaks) @@ -409,21 +421,30 @@ GuideLegend <- ggproto( set_key_size(key, data$linewidth, data$size, key_size) }) - width <- vapply(glyph, get_attr, which = "width", default = 0, numeric(1)) - width <- max(width, 0, key_size[1], na.rm = TRUE) - height <- vapply(glyph, get_attr, which = "height", default = 0, numeric(1)) + width <- vapply(glyph, get_attr, which = "width", default = 0, numeric(1)) + width <- max(width, 0, key_size[1], na.rm = TRUE) + height <- vapply( + glyph, + get_attr, + which = "height", + default = 0, + numeric(1) + ) height <- max(height, 0, key_size[2], na.rm = TRUE) vp <- NULL if (!is.null(just)) { vp <- viewport( - x = just[1], y = just[2], just = just, - width = unit(width, "cm"), height = unit(height, "cm") + x = just[1], + y = just[2], + just = just, + width = unit(width, "cm"), + height = unit(height, "cm") ) } grob <- gTree(children = inject(gList(elements$key, !!!glyph)), vp = vp) - attr(grob, "width") <- width + attr(grob, "width") <- width attr(grob, "height") <- height grob }) @@ -441,7 +462,7 @@ GuideLegend <- ggproto( "guide.label", element_grob( elements$text, - label = lab, + label = lab, margin_x = TRUE, margin_y = TRUE ) @@ -450,31 +471,46 @@ GuideLegend <- ggproto( }, measure_grobs = function(grobs, params, elements) { - - byrow <- elements$byrow %||% FALSE + byrow <- elements$byrow %||% FALSE n_breaks <- params$n_breaks %||% 1L - dim <- c(params$nrow %||% 1L, params$ncol %||% 1L) + dim <- c(params$nrow %||% 1L, params$ncol %||% 1L) # A guide may have already specified the size of the decoration, only # measure when it hasn't already. - sizes <- params$sizes %||% measure_legend_keys( - grobs$decor, n = n_breaks, dim = dim, byrow = byrow, - default_width = elements$width_cm, - default_height = elements$height_cm - ) - widths <- sizes$widths + sizes <- params$sizes %||% + measure_legend_keys( + grobs$decor, + n = n_breaks, + dim = dim, + byrow = byrow, + default_width = elements$width_cm, + default_height = elements$height_cm + ) + widths <- sizes$widths heights <- sizes$heights # Measure label sizes - zeroes <- rep(0, prod(dim) - n_breaks) # size vector padding - label_widths <- apply(matrix( - c(width_cm(grobs$labels), zeroes), - nrow = dim[1], ncol = dim[2], byrow = byrow - ), 2, max) - label_heights <- apply(matrix( - c(height_cm(grobs$labels), zeroes), - nrow = dim[1], ncol = dim[2], byrow = byrow - ), 1, max) + zeroes <- rep(0, prod(dim) - n_breaks) # size vector padding + label_widths <- apply( + matrix( + c(width_cm(grobs$labels), zeroes), + nrow = dim[1], + ncol = dim[2], + byrow = byrow + ), + 2, + max + ) + label_heights <- apply( + matrix( + c(height_cm(grobs$labels), zeroes), + nrow = dim[1], + ncol = dim[2], + byrow = byrow + ), + 1, + max + ) # Interleave gaps between keys and labels, which depends on the label # position. For unclear reasons, we need to adjust some gaps based on the @@ -482,16 +518,16 @@ GuideLegend <- ggproto( hgap <- elements$spacing_x %||% 0 widths <- switch( elements$text_position, - "left" = list(label_widths, widths, hgap), - "right" = list(widths, label_widths, hgap), + "left" = list(label_widths, widths, hgap), + "right" = list(widths, label_widths, hgap), list(pmax(label_widths, widths), hgap) ) - widths <- head(vec_interleave(!!!widths), -1) + widths <- head(vec_interleave(!!!widths), -1) vgap <- elements$spacing_y %||% 0 heights <- switch( elements$text_position, - "top" = list(label_heights, heights, vgap), + "top" = list(label_heights, heights, vgap), "bottom" = list(heights, label_heights, vgap), list(pmax(label_heights, heights), vgap) ) @@ -501,7 +537,6 @@ GuideLegend <- ggproto( }, arrange_layout = function(key, sizes, params, elements) { - break_seq <- seq_len(params$n_breaks %||% 1L) dim <- c(params$nrow %||% 1L, params$ncol %||% 1L) @@ -519,19 +554,20 @@ GuideLegend <- ggproto( # Make gaps for key-label spacing depending on label position position <- elements$text_position - key_row <- key_row + switch(position, top = row, bottom = row - 1, 0) - lab_row <- key_row + switch(position, top = -1, bottom = 1, 0) - key_col <- key_col + switch(position, left = col, right = col - 1, 0) - lab_col <- key_col + switch(position, left = -1, right = 1, 0) + key_row <- key_row + switch(position, top = row, bottom = row - 1, 0) + lab_row <- key_row + switch(position, top = -1, bottom = 1, 0) + key_col <- key_col + switch(position, left = col, right = col - 1, 0) + lab_col <- key_col + switch(position, left = -1, right = 1, 0) data_frame0( - key_row = key_row, key_col = key_col, - label_row = lab_row, label_col = lab_col + key_row = key_row, + key_col = key_col, + label_row = lab_row, + label_col = lab_col ) }, assemble_drawing = function(self, grobs, layout, sizes, params, elements) { - widths <- unit(sizes$widths, "cm") if (isTRUE(elements$stretch_x)) { widths[unique0(layout$key_col)] <- elements$key_width @@ -552,28 +588,42 @@ GuideLegend <- ggproto( # Add keys gt <- gtable_add_grob( - gt, grobs$decor, + gt, + grobs$decor, name = names(grobs$decor) %||% - paste("key", key_rows, key_cols, c("bg", seq_len(n_key_layers - 1)), - sep = "-"), + paste( + "key", + key_rows, + key_cols, + c("bg", seq_len(n_key_layers - 1)), + sep = "-" + ), clip = "off", - t = key_rows, r = key_cols, b = key_rows, l = key_cols + t = key_rows, + r = key_cols, + b = key_rows, + l = key_cols ) } if (!is_zero(grobs$labels)) { gt <- gtable_add_grob( - gt, grobs$labels, + gt, + grobs$labels, name = names(labels) %||% paste("label", layout$label_row, layout$label_col, sep = "-"), clip = "off", - t = layout$label_row, r = layout$label_col, - b = layout$label_row, l = layout$label_col + t = layout$label_row, + r = layout$label_col, + b = layout$label_row, + l = layout$label_col ) } gt <- self$add_title( - gt, grobs$title, elements$title_position, + gt, + grobs$title, + elements$title_position, rotate_just(element = elements$title) ) @@ -582,9 +632,15 @@ GuideLegend <- ggproto( # Add background if (!is_zero(elements$background)) { gt <- gtable_add_grob( - gt, elements$background, - name = "background", clip = "off", - t = 1, r = -1, b = -1, l =1, z = -Inf + gt, + elements$background, + name = "background", + clip = "off", + t = 1, + r = -1, + b = -1, + l = 1, + z = -Inf ) } gt @@ -592,8 +648,14 @@ GuideLegend <- ggproto( ) -measure_legend_keys <- function(keys, n, dim, byrow = FALSE, - default_width = 1, default_height = 1) { +measure_legend_keys <- function( + keys, + n, + dim, + byrow = FALSE, + default_width = 1, + default_height = 1 +) { if (is.null(keys)) { ans <- list(widths = NULL, heights = NULL) return(ans) @@ -603,15 +665,15 @@ measure_legend_keys <- function(keys, n, dim, byrow = FALSE, padding_zeroes <- rep(0, prod(dim) - n) # For every layer, extract the size in cm - widths <- c(get_key_size(keys, "width", n), padding_zeroes) + widths <- c(get_key_size(keys, "width", n), padding_zeroes) heights <- c(get_key_size(keys, "height", n), padding_zeroes) # Apply legend layout - widths <- matrix(widths, nrow = dim[1], ncol = dim[2], byrow = byrow) + widths <- matrix(widths, nrow = dim[1], ncol = dim[2], byrow = byrow) heights <- matrix(heights, nrow = dim[1], ncol = dim[2], byrow = byrow) list( - widths = pmax(default_width, apply(widths, 2, max)), + widths = pmax(default_width, apply(widths, 2, max)), heights = pmax(default_height, apply(heights, 1, max)) ) } @@ -628,15 +690,15 @@ set_key_size <- function(key, linewidth = NULL, size = NULL, default = NULL) { return(key) } if (!is.null(size) || !is.null(linewidth)) { - size <- size %||% 0 + size <- size %||% 0 linewidth <- linewidth %||% 0 - size <- if (is.na(size)[1]) 0 else size[1] + size <- if (is.na(size)[1]) 0 else size[1] linewidth <- if (is.na(linewidth)[1]) 0 else linewidth[1] size <- (size + linewidth) / 10 # From mm to cm } else { size <- NULL } - attr(key, "width") <- attr(key, "width", TRUE) %||% size %||% default[1] + attr(key, "width") <- attr(key, "width", TRUE) %||% size %||% default[1] attr(key, "height") <- attr(key, "height", TRUE) %||% size %||% default[2] key } @@ -652,7 +714,7 @@ keep_key_data <- function(key, data, aes, show) { return(TRUE) } if (is_named(show)) { - aes <- intersect(aes, names(show)) + aes <- intersect(aes, names(show)) show <- show[aes] } else { show <- show[rep(1L, length(aes))] @@ -693,10 +755,10 @@ position_margin <- function(position, margin = NULL, gap = unit(0, "pt")) { margin <- margin %||% margin() margin <- switch( position, - top = replace(margin, 3, margin[3] + gap), + top = replace(margin, 3, margin[3] + gap), bottom = replace(margin, 1, margin[1] + gap), - left = replace(margin, 2, margin[2] + gap), - right = replace(margin, 4, margin[4] + gap) + left = replace(margin, 2, margin[2] + gap), + right = replace(margin, 4, margin[4] + gap) ) # We have to manually reconstitute the class because the 'simpleUnit' class # might be dropped by the replacement operation. @@ -709,18 +771,33 @@ position_margin <- function(position, margin = NULL, gap = unit(0, "pt")) { deprecated_guide_args <- function( theme = NULL, title.position = NULL, - title.theme = NULL, title.hjust = NULL, title.vjust = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, label = NULL, label.position = NULL, - label.theme = NULL, label.hjust = NULL, label.vjust = NULL, - keywidth = NULL, keyheight = NULL, barwidth = NULL, barheight = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, + keywidth = NULL, + keyheight = NULL, + barwidth = NULL, + barheight = NULL, byrow = NULL, - frame.colour = NULL, frame.linewidth = NULL, frame.linetype = NULL, - ticks = NULL, ticks.colour = NULL, ticks.linewidth = NULL, - axis = NULL, axis.colour = NULL, axis.linewidth = NULL, axis.arrow = NULL, + frame.colour = NULL, + frame.linewidth = NULL, + frame.linetype = NULL, + ticks = NULL, + ticks.colour = NULL, + ticks.linewidth = NULL, + axis = NULL, + axis.colour = NULL, + axis.linewidth = NULL, + axis.arrow = NULL, default.unit = "line", ..., - .call = caller_call()) { + .call = caller_call() +) { warn_dots_used(call = .call) args <- names(formals(deprecated_guide_args)) @@ -753,10 +830,10 @@ deprecated_guide_args <- function( theme <- replace_null( theme, legend.title.position = title.position, - legend.text.position = label.position, - legend.byrow = byrow, - legend.key.width = def_unit(keywidth %||% barwidth), - legend.key.height = def_unit(keyheight %||% barheight) + legend.text.position = label.position, + legend.byrow = byrow, + legend.key.width = def_unit(keywidth %||% barwidth), + legend.key.height = def_unit(keyheight %||% barheight) ) # Set legend.text @@ -785,11 +862,12 @@ deprecated_guide_args <- function( # Set legend.frame if (!is.null(frame.colour %||% frame.linewidth %||% frame.linetype)) { - frame <- theme$legend.frame %||% element_rect( - colour = frame.colour, - linewidth = frame.linewidth, - linetype = frame.linetype - ) + frame <- theme$legend.frame %||% + element_rect( + colour = frame.colour, + linewidth = frame.linewidth, + linetype = frame.linetype + ) theme$legend.frame <- theme$legend.frame %||% frame } diff --git a/R/guide-none.R b/R/guide-none.R index 71a0f2f78e..1c2d07dc64 100644 --- a/R/guide-none.R +++ b/R/guide-none.R @@ -23,7 +23,8 @@ guide_none <- function(title = waiver(), position = waiver()) { #' @usage NULL #' @export GuideNone <- ggproto( - "GuideNone", Guide, + "GuideNone", + Guide, # Perform no training train = function(self, params = self$params, scale, aesthetic = NULL, ...) { diff --git a/R/guide-old.R b/R/guide-old.R index 8f8be86ba1..c1d52f5e09 100644 --- a/R/guide-old.R +++ b/R/guide-old.R @@ -1,4 +1,3 @@ - #' The previous S3 guide system #' #' The guide system has been overhauled to use the ggproto infrastructure to @@ -74,7 +73,8 @@ old_guide <- function(guide) { ) ggproto( - NULL, GuideOld, + NULL, + GuideOld, params = guide, available_aes = guide$available_aes %||% NULL ) @@ -85,10 +85,17 @@ old_guide <- function(guide) { #' @usage NULL #' @export GuideOld <- ggproto( - "GuideOld", Guide, - - train = function(self, params, scale, aesthetic = NULL, - title = waiver(), direction = NULL) { + "GuideOld", + Guide, + + train = function( + self, + params, + scale, + aesthetic = NULL, + title = waiver(), + direction = NULL + ) { params$title <- scale$make_title(params$title, scale$name, title) params$direction <- params$direction %||% direction %||% "vertical" params <- guide_train(params, scale, aesthetic) @@ -109,12 +116,13 @@ GuideOld <- ggproto( draw = function(self, theme, position = NULL, direction = NULL, params) { params$direction <- params$direction %||% direction %||% "placeholder" - params$title.position <- params$title.position %||% switch( - params$direction, - vertical = "top", horizontal = "left", - NULL - ) + params$title.position <- params$title.position %||% + switch( + params$direction, + vertical = "top", + horizontal = "left", + NULL + ) guide_gengrob(params, theme) } ) - diff --git a/R/guides-.R b/R/guides-.R index e4a96242d1..7df7ba08fc 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -73,12 +73,17 @@ guides <- function(...) { return(NULL) } - if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]] + if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) { + args <- args[[1]] + } args <- rename_aes(args) idx_false <- vapply(args, isFALSE, FUN.VALUE = logical(1L)) if (isTRUE(any(idx_false))) { - deprecate_warn0("3.3.4", "guides(`` = 'cannot be `FALSE`. Use \"none\" instead')") + deprecate_warn0( + "3.3.4", + "guides(`` = 'cannot be `FALSE`. Use \"none\" instead')" + ) args[idx_false] <- "none" } @@ -119,7 +124,8 @@ guides_list <- function(guides = NULL) { } Guides <- ggproto( - "Guides", NULL, + "Guides", + NULL, ## Fields -------------------------------------------------------------------- @@ -170,9 +176,9 @@ Guides <- ggproto( # Function for dropping GuideNone objects from the Guides object. Typically # called after training the guides on scales. subset_guides = function(self, i) { - self$guides <- self$guides[i] + self$guides <- self$guides[i] self$aesthetics <- self$aesthetics[i] - self$params <- self$params[i] + self$params <- self$params[i] invisible() }, @@ -225,7 +231,7 @@ Guides <- ggproto( # Pair up guides and parameters params <- self$params[idx] - pairs <- Map(list, guide = self$guides[idx], params = params) + pairs <- Map(list, guide = self$guides[idx], params = params) # Merge pairs sequentially order <- order(vapply(params, function(p) as.numeric(p$order), numeric(1))) @@ -275,7 +281,6 @@ Guides <- ggproto( # The resulting guide is then drawn in ggplot_gtable build = function(self, scales, layers, labels, layer_data, theme = NULL) { - # Empty guides list custom <- self$get_custom() no_guides <- custom @@ -288,7 +293,7 @@ Guides <- ggproto( # Ensure a 1:1 mapping between aesthetics and scales aesthetics <- lapply(scales, `[[`, "aesthetics") - scales <- rep.int(scales, lengths(aesthetics)) + scales <- rep.int(scales, lengths(aesthetics)) aesthetics <- unlist(aesthetics, recursive = FALSE, use.names = FALSE) # Setup and train scales @@ -329,7 +334,9 @@ Guides <- ggproto( # correctly pick the primary and secondary guides. setup = function( - self, scales, aesthetics = NULL, + self, + scales, + aesthetics = NULL, default = self$missing, missing = self$missing ) { @@ -337,15 +344,20 @@ Guides <- ggproto( # For every aesthetic-scale combination, find and validate guide new_guides <- lapply(seq_along(scales), function(idx) { - # Find guide for aesthetic-scale combination # Hierarchy is in the order: # plot + guides(XXX) + scale_ZZZ(guide = XXX) > default(i.e., legend) - guide <- guides[[aesthetics[idx]]] %||% scales[[idx]]$guide %|W|% - default %||% missing + guide <- guides[[aesthetics[idx]]] %||% + scales[[idx]]$guide %|W|% + default %||% + missing if (isFALSE(guide)) { - deprecate_warn0("3.3.4", I("The `guide` argument in `scale_*()` cannot be `FALSE`. This "), I('"none"')) + deprecate_warn0( + "3.3.4", + I("The `guide` argument in `scale_*()` cannot be `FALSE`. This "), + I('"none"') + ) guide <- "none" } @@ -360,13 +372,17 @@ Guides <- ggproto( # Check compatibility of scale and guide, e.g. you cannot use GuideAxis # to display the "colour" aesthetic. scale_aes <- scales[[idx]]$aesthetics - if (!any(c("x", "y") %in% scale_aes)) scale_aes <- c(scale_aes, "any") + if (!any(c("x", "y") %in% scale_aes)) { + scale_aes <- c(scale_aes, "any") + } if (!any(scale_aes %in% guide$available_aes)) { warn_aes <- guide$available_aes warn_aes[warn_aes == "any"] <- "any non position aesthetic" cli::cli_warn(c( - paste0("{.fn {snake_class(guide)}} cannot be used for ", - "{.or {.field {head(scales[[idx]]$aesthetics, 4)}}}."), + paste0( + "{.fn {snake_class(guide)}} cannot be used for ", + "{.or {.field {head(scales[[idx]]$aesthetics, 4)}}}." + ), i = "Use {?one of} {.or {.field {warn_aes}}} instead." )) guide <- missing @@ -377,10 +393,11 @@ Guides <- ggproto( # Create updated child ggproto( - NULL, self, - guides = new_guides, + NULL, + self, + guides = new_guides, # Extract the guide's params to manage separately - params = lapply(new_guides, `[[`, "params"), + params = lapply(new_guides, `[[`, "params"), aesthetics = aesthetics ) }, @@ -388,17 +405,18 @@ Guides <- ggproto( # Loop over every guide-scale combination to perform training # A strong assumption here is that `scales` is parallel to the guides train = function(self, scales, labels) { - params <- Map( function(guide, param, scale, aes) { guide$train( - param, scale, aes, + param, + scale, + aes, title = labels[[aes]] ) }, guide = self$guides, param = self$params, - aes = self$aesthetics, + aes = self$aesthetics, scale = scales ) self$update_params(params) @@ -427,21 +445,24 @@ Guides <- ggproto( # Split by hashes indices <- split(seq_along(pairs), hashes) indices <- vapply(indices, `[[`, 0L, 1L, USE.NAMES = FALSE) # First index - groups <- split(pairs, hashes) - lens <- lengths(groups) + groups <- split(pairs, hashes) + lens <- lengths(groups) # Merge groups with >1 member groups[lens > 1] <- lapply(groups[lens > 1], function(group) { - Reduce(function(old, new) { - old$guide$merge(old$params, new$guide, new$params) - }, group) + Reduce( + function(old, new) { + old$guide$merge(old$params, new$guide, new$params) + }, + group + ) }) groups[lens == 1] <- unlist(groups[lens == 1], FALSE) # Update the Guides object self$guides <- lapply(groups, `[[`, "guide") self$params <- lapply(groups, `[[`, "params") - self$aesthetics <- self$aesthetics[indices] + self$aesthetics <- self$aesthetics[indices] invisible() }, @@ -472,7 +493,6 @@ Guides <- ggproto( # into a guide box which will be inserted into the main gtable # Combining multiple guides in a guide box assemble = function(self, theme, params = self$params, guides = self$guides) { - if (length(self$guides) < 1) { return(zeroGrob()) } @@ -489,7 +509,8 @@ Guides <- ggproto( positions <- vapply( params, function(p) p$position[1] %||% default_position, - character(1), USE.NAMES = FALSE + character(1), + USE.NAMES = FALSE ) grobs <- self$draw(theme, positions, theme$legend.direction) @@ -505,8 +526,8 @@ Guides <- ggproto( groups <- data_frame0( positions = positions, - justs = list(NULL), - coords = list(NULL) + justs = list(NULL), + coords = list(NULL) ) # we grouped the legends by the positions, for inside legends, they'll be @@ -530,7 +551,7 @@ Guides <- ggproto( names(grobs) <- groups$key$positions # Set spacing - theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") + theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") theme$legend.spacing.y <- calc_element("legend.spacing.y", theme) theme$legend.spacing.x <- calc_element("legend.spacing.x", theme) @@ -553,8 +574,11 @@ Guides <- ggproto( if (sum(is_inside) > 1) { inside <- gtable(unit(1, "npc"), unit(1, "npc")) inside <- gtable_add_grob( - inside, grobs[is_inside], - t = 1, l = 1, clip = "off", + inside, + grobs[is_inside], + t = 1, + l = 1, + clip = "off", name = paste0("guide-box-inside-", seq_len(sum(is_inside))) ) grobs <- grobs[!is_inside] @@ -568,9 +592,14 @@ Guides <- ggproto( }, # Render the guides into grobs - draw = function(self, theme, positions, direction = NULL, - params = self$params, - guides = self$guides) { + draw = function( + self, + theme, + positions, + direction = NULL, + params = self$params, + guides = self$guides + ) { directions <- rep(direction %||% "vertical", length(positions)) if (is.null(direction)) { directions[positions %in% c("top", "bottom")] <- "horizontal" @@ -579,8 +608,10 @@ Guides <- ggproto( grobs <- vector("list", length(guides)) for (i in seq_along(grobs)) { grobs[[i]] <- guides[[i]]$draw( - theme = theme, position = positions[i], - direction = directions[i], params = params[[i]] + theme = theme, + position = positions[i], + direction = directions[i], + params = params[[i]] ) } grobs @@ -590,7 +621,6 @@ Guides <- ggproto( # won't break current implement of patchwork, which depends on the top three # arguments to collect guides package_box = function(grobs, position, theme) { - if (is_zero(grobs) || length(grobs) == 0) { return(zeroGrob()) } @@ -599,19 +629,20 @@ Guides <- ggproto( direction <- switch(position, top = , bottom = "horizontal", "vertical") # Populate missing theme arguments - theme$legend.box <- theme$legend.box %||% direction - theme$legend.box.just <- theme$legend.box.just %||% switch( - direction, - vertical = c("left", "top"), - horizontal = c("center", "top") - ) + theme$legend.box <- theme$legend.box %||% direction + theme$legend.box.just <- theme$legend.box.just %||% + switch( + direction, + vertical = c("left", "top"), + horizontal = c("center", "top") + ) # Measure guides - widths <- lapply(grobs, `[[`, "widths") + widths <- lapply(grobs, `[[`, "widths") heights <- lapply(grobs, `[[`, "heights") # Check whether legends are stretched in some direction - stretch_x <- any(unlist(lapply(widths, unitType)) == "null") + stretch_x <- any(unlist(lapply(widths, unitType)) == "null") stretch_y <- any(unlist(lapply(heights, unitType)) == "null") # Global justification of the complete legend box @@ -621,24 +652,26 @@ Guides <- ggproto( if (position == "inside") { # The position of inside legends are set by their justification inside_position <- theme$legend.position.inside %||% global_just - global_xjust <- inside_position[1] - global_yjust <- inside_position[2] + global_xjust <- inside_position[1] + global_yjust <- inside_position[2] global_margin <- margin() } else { - global_xjust <- global_just[1] - global_yjust <- global_just[2] + global_xjust <- global_just[1] + global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification # relative to the plot panel global_margin <- margin( - t = 1 - global_yjust, b = global_yjust, - r = 1 - global_xjust, l = global_xjust, + t = 1 - global_yjust, + b = global_yjust, + r = 1 - global_xjust, + l = global_xjust, unit = "null" ) } # Set the justification of each legend within the legend box # First value is xjust, second value is yjust - box_just <- valid.just(theme$legend.box.just) + box_just <- valid.just(theme$legend.box.just) box_xjust <- box_just[1] box_yjust <- box_just[2] @@ -650,8 +683,12 @@ Guides <- ggproto( for (i in seq_along(grobs)) { grobs[[i]] <- editGrob( grobs[[i]], - vp = viewport(x = box_xjust, y = box_yjust, just = box_just, - height = heightDetails(grobs[[i]])) + vp = viewport( + x = box_xjust, + y = box_yjust, + just = box_just, + height = heightDetails(grobs[[i]]) + ) ) } spacing <- theme$legend.spacing.x @@ -662,37 +699,45 @@ Guides <- ggproto( heights <- unit(height_cm(lapply(heights, sum)), "cm") if (stretch_x || stretch_spacing) { - widths <- redistribute_null_units(widths, spacing, margin, "width") + widths <- redistribute_null_units(widths, spacing, margin, "width") vp_width <- unit(1, "npc") } else { - widths <- inject(unit.c(!!!lapply(widths, sum))) + widths <- inject(unit.c(!!!lapply(widths, sum))) vp_width <- sum(widths, spacing * (length(grobs) - 1L)) } # Set global justification vp <- viewport( - x = global_xjust, y = global_yjust, just = global_just, + x = global_xjust, + y = global_yjust, + just = global_just, height = max(heights), - width = vp_width + width = vp_width ) # Initialise gtable as legends in a row guides <- gtable_row( - name = "guides", grobs = grobs, - widths = widths, height = max(heights), + name = "guides", + grobs = grobs, + widths = widths, + height = max(heights), vp = vp ) # Add space between the guide-boxes guides <- gtable_add_col_space(guides, spacing) - - } else { # theme$legend.box == "vertical" + } else { + # theme$legend.box == "vertical" # Set justification for each legend within the box for (i in seq_along(grobs)) { grobs[[i]] <- editGrob( grobs[[i]], - vp = viewport(x = box_xjust, y = box_yjust, just = box_just, - width = widthDetails(grobs[[i]])) + vp = viewport( + x = box_xjust, + y = box_yjust, + just = box_just, + width = widthDetails(grobs[[i]]) + ) ) } @@ -701,27 +746,31 @@ Guides <- ggproto( if (!stretch_spacing) { spacing <- convertWidth(spacing, "cm") } - widths <- unit(width_cm(lapply(widths, sum)), "cm") + widths <- unit(width_cm(lapply(widths, sum)), "cm") if (stretch_y || stretch_spacing) { - heights <- redistribute_null_units(heights, spacing, margin, "height") + heights <- redistribute_null_units(heights, spacing, margin, "height") vp_height <- unit(1, "npc") } else { - heights <- inject(unit.c(!!!lapply(heights, sum))) + heights <- inject(unit.c(!!!lapply(heights, sum))) vp_height <- sum(heights, spacing * (length(grobs) - 1L)) } # Set global justification vp <- viewport( - x = global_xjust, y = global_yjust, just = global_just, + x = global_xjust, + y = global_yjust, + just = global_just, height = vp_height, - width = max(widths) + width = max(widths) ) # Initialise gtable as legends in a column guides <- gtable_col( - name = "guides", grobs = grobs, - width = max(widths), heights = heights, + name = "guides", + grobs = grobs, + width = max(widths), + heights = heights, vp = vp ) @@ -736,9 +785,14 @@ Guides <- ggproto( background <- element_grob(theme$legend.box.background %||% element_blank()) guides <- gtable_add_grob( - guides, background, - t = 1, l = 1, b = -1, r = -1, - z = -Inf, clip = "off", + guides, + background, + t = 1, + l = 1, + b = -1, + r = -1, + z = -Inf, + clip = "off", name = "legend.box.background" ) @@ -757,7 +811,6 @@ Guides <- ggproto( ## Utilities ----------------------------------------------------------------- print = function(self) { - guides <- self$guides header <- paste0("\n") @@ -828,7 +881,6 @@ Guides <- ggproto( #' polar <- p + coord_polar() #' get_guide_data(polar, "theta", panel = 2) get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { - check_string(aesthetic, allow_empty = FALSE) aesthetic <- standardise_aes_names(aesthetic) @@ -837,7 +889,11 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { if (!aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) { # Non position guides: check if aesthetic in colnames of key keys <- lapply(plot@plot@guides$params, `[[`, "key") - keep <- vapply(keys, function(x) any(colnames(x) %in% aesthetic), logical(1)) + keep <- vapply( + keys, + function(x) any(colnames(x) %in% aesthetic), + logical(1) + ) keys <- switch(sum(keep) + 1, NULL, keys[[which(keep)]], keys[keep]) return(keys) } @@ -855,7 +911,11 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { # that doesn't use the guide system. if (is.null(params$guides)) { # Old system: just return relevant parameters - aesthetic <- paste(aesthetic, c("major", "minor", "labels", "range"), sep = ".") + aesthetic <- paste( + aesthetic, + c("major", "minor", "labels", "range"), + sep = "." + ) params <- params[intersect(names(params), aesthetic)] return(params) } else { @@ -872,7 +932,9 @@ matched_aes <- function(layer, guide) { geom <- c(layer$geom$required_aes, names(layer$geom$default_aes)) # Make sure that size guides are shown if a renaming layer is used - if (layer$geom$rename_size && "size" %in% all && !"linewidth" %in% all) geom <- c(geom, "size") + if (layer$geom$rename_size && "size" %in% all && !"linewidth" %in% all) { + geom <- c(geom, "size") + } matched <- intersect(intersect(all, geom), names(guide$key)) matched <- setdiff(matched, names(layer$computed_geom_params)) setdiff(matched, names(layer$aes_params)) @@ -914,8 +976,11 @@ include_layer_in_guide <- function(layer, matched) { validate_guide <- function(guide) { # if guide is specified by character, then find the corresponding guide if (is.character(guide)) { - fun <- find_global(paste0("guide_", guide), env = global_env(), - mode = "function") + fun <- find_global( + paste0("guide_", guide), + env = global_env(), + mode = "function" + ) if (is.function(fun)) { guide <- fun() } @@ -930,7 +995,6 @@ validate_guide <- function(guide) { } redistribute_null_units <- function(units, spacing, margin, type = "width") { - has_null <- vapply(units, function(x) any(unitType(x) == "null"), logical(1)) # Early exit when we needn't bother with null units @@ -941,7 +1005,7 @@ redistribute_null_units <- function(units, spacing, margin, type = "width") { } # Get spacing between guides and margins in absolute units - size <- switch(type, width = width_cm, height = height_cm) + size <- switch(type, width = width_cm, height = height_cm) if (length(units) < 2) { # When we have 1 guide, we don't need any spacing spacing <- unit(0, "cm") @@ -949,8 +1013,8 @@ redistribute_null_units <- function(units, spacing, margin, type = "width") { spacing <- sum(rep(spacing, length.out = length(units) - 1)) } - margin <- switch(type, width = margin[c(2, 4)], height = margin[c(1, 3)]) - margin <- sum(size(margin)) + margin <- switch(type, width = margin[c(2, 4)], height = margin[c(1, 3)]) + margin <- sum(size(margin)) # Get the absolute parts of the unit absolute <- vapply(units, function(u) sum(size(absolute.size(u))), numeric(1)) diff --git a/R/guides-grid.R b/R/guides-grid.R index 9e70adaf37..a76a86be22 100644 --- a/R/guides-grid.R +++ b/R/guides-grid.R @@ -4,7 +4,6 @@ # # Any minor lines coinciding with major lines will be removed guide_grid <- function(theme, panel_params, coord, square = TRUE) { - x_major <- panel_params$x$mapped_breaks() x_minor <- setdiff(panel_params$x$mapped_breaks_minor(), x_major) @@ -46,15 +45,18 @@ breaks_as_grid <- function(var, type, transform, theme) { return(NULL) } df <- data_frame0( - var = rep(var, each = 2), - alt = rep(c(-Inf, Inf), n), + var = rep(var, each = 2), + alt = rep(c(-Inf, Inf), n), group = rep(seq_along(var), each = 2) ) colnames(df)[1:2] <- switch(type, major.y = , minor.y = c("y", "x"), c("x", "y")) df <- transform(df) element_render( - theme, paste0("panel.grid.", type), x = df$x, y = df$y, + theme, + paste0("panel.grid.", type), + x = df$x, + y = df$y, id.lengths = vec_unrep(df$group)$times ) } diff --git a/R/hexbin.R b/R/hexbin.R index 3f6fabc7ec..a7cc521e12 100644 --- a/R/hexbin.R +++ b/R/hexbin.R @@ -12,7 +12,15 @@ hex_bounds <- function(x, binwidth) { ) } -hexBinSummarise <- function(x, y, z, binwidth, fun = mean, fun.args = list(), drop = TRUE) { +hexBinSummarise <- function( + x, + y, + z, + binwidth, + fun = mean, + fun.args = list(), + drop = TRUE +) { if (length(binwidth) == 1) { binwidth <- rep(binwidth, 2) } @@ -26,8 +34,12 @@ hexBinSummarise <- function(x, y, z, binwidth, fun = mean, fun.args = list(), dr # Call hexbin hb <- hexbin::hexbin( - x, xbnds = xbnds, xbins = xbins, - y, ybnds = ybnds, shape = ybins / xbins, + x, + xbnds = xbnds, + xbins = xbins, + y, + ybnds = ybnds, + shape = ybins / xbins, IDs = TRUE ) @@ -40,6 +52,8 @@ hexBinSummarise <- function(x, y, z, binwidth, fun = mean, fun.args = list(), dr out$width <- binwidth[1] out$height <- binwidth[2] - if (drop) out <- stats::na.omit(out) + if (drop) { + out <- stats::na.omit(out) + } out } diff --git a/R/labeller.R b/R/labeller.R index 9a80fca9ea..ec74ce4419 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -91,11 +91,17 @@ NULL collapse_labels_lines <- function(labels) { - is_exp <- vapply(labels, function(l) length(l) > 0 && is.expression(l[[1]]), logical(1)) + is_exp <- vapply( + labels, + function(l) length(l) > 0 && is.expression(l[[1]]), + logical(1) + ) out <- inject(mapply(paste, !!!labels, sep = ", ", SIMPLIFY = FALSE)) label <- list(unname(unlist(out))) if (all(is_exp)) { - label <- lapply(label, function(l) list(parse(text = paste0("list(", l, ")")))) + label <- lapply(label, function(l) { + list(parse(text = paste0("list(", l, ")"))) + }) } label } @@ -190,8 +196,7 @@ class(label_parsed) <- c("function", "labeller") #' p + facet_grid(vs ~ ., labeller = label_bquote(alpha ^ .(vs))) #' p + facet_grid(. ~ vs, labeller = label_bquote(cols = .(vs) ^ .(vs))) #' p + facet_grid(. ~ vs + am, labeller = label_bquote(cols = .(am) ^ .(vs))) -label_bquote <- function(rows = NULL, cols = NULL, - default) { +label_bquote <- function(rows = NULL, cols = NULL, default) { cols_quoted <- substitute(cols) rows_quoted <- substitute(rows) @@ -237,7 +242,9 @@ resolve_labeller <- function(rows, cols, labels) { if (attr(labels, "facet") == "wrap") { # Return either rows or cols for facet_wrap() if (!is.null(cols) && !is.null(rows)) { - cli::cli_abort("Cannot supply both {.arg rows} and {.arg cols} to {.fn facet_wrap}.") + cli::cli_abort( + "Cannot supply both {.arg rows} and {.arg cols} to {.fn facet_wrap}." + ) } cols %||% rows } else { @@ -407,9 +414,14 @@ as_labeller <- function(x, default = label_value, multi_line = TRUE) { #' p2 + facet_grid(vore ~ conservation, labeller = global_labeller) #' p3 + facet_wrap(~conservation2, labeller = global_labeller) #' } -labeller <- function(..., .rows = NULL, .cols = NULL, - keep.as.numeric = deprecated(), .multi_line = TRUE, - .default = label_value) { +labeller <- function( + ..., + .rows = NULL, + .cols = NULL, + keep.as.numeric = deprecated(), + .multi_line = TRUE, + .default = label_value +) { if (lifecycle::is_present(keep.as.numeric)) { lifecycle::deprecate_stop("2.0.0", "labeller(keep.as.numeric)") } @@ -426,13 +438,18 @@ labeller <- function(..., .rows = NULL, .cols = NULL, if (is.null(margin_labeller)) { labellers <- lapply(dots, as_labeller, default = .default) } else { - margin_labeller <- as_labeller(margin_labeller, default = .default, - multi_line = .multi_line) + margin_labeller <- as_labeller( + margin_labeller, + default = .default, + multi_line = .multi_line + ) # Check that variable-specific labellers do not overlap with # margin-wide labeller if (any(names(dots) %in% names(labels))) { - cli::cli_abort("Conflict between {.var {paste0('.', attr(labels, 'type'))}} and {.var {names(dots)}}.") + cli::cli_abort( + "Conflict between {.var {paste0('.', attr(labels, 'type'))}} and {.var {names(dots)}}." + ) } } @@ -477,11 +494,13 @@ build_strip <- function(label_df, labeller, theme, horizontal) { # No labelling data, so return empty row/col if (empty(label_df)) { - return(if (horizontal) { - list(top = NULL, bottom = NULL) - } else { - list(left = NULL, right = NULL) - }) + return( + if (horizontal) { + list(top = NULL, bottom = NULL) + } else { + list(left = NULL, right = NULL) + } + ) } # Create labels @@ -496,35 +515,73 @@ build_strip <- function(label_df, labeller, theme, horizontal) { clip <- c("on", "off", "inherit")[clip] if (horizontal) { - grobs_top <- lapply(labels_vec, element_render, theme = theme, - element = "strip.text.x.top", margin_x = TRUE, - margin_y = TRUE) - grobs_top <- assemble_strips(matrix(grobs_top, ncol = ncol, nrow = nrow), - theme, horizontal, clip = clip) - - grobs_bottom <- lapply(labels_vec, element_render, theme = theme, - element = "strip.text.x.bottom", margin_x = TRUE, - margin_y = TRUE) - grobs_bottom <- assemble_strips(matrix(grobs_bottom, ncol = ncol, nrow = nrow), - theme, horizontal, clip = clip) + grobs_top <- lapply( + labels_vec, + element_render, + theme = theme, + element = "strip.text.x.top", + margin_x = TRUE, + margin_y = TRUE + ) + grobs_top <- assemble_strips( + matrix(grobs_top, ncol = ncol, nrow = nrow), + theme, + horizontal, + clip = clip + ) + + grobs_bottom <- lapply( + labels_vec, + element_render, + theme = theme, + element = "strip.text.x.bottom", + margin_x = TRUE, + margin_y = TRUE + ) + grobs_bottom <- assemble_strips( + matrix(grobs_bottom, ncol = ncol, nrow = nrow), + theme, + horizontal, + clip = clip + ) list( top = grobs_top, bottom = grobs_bottom ) } else { - grobs_left <- lapply(labels_vec, element_render, theme = theme, - element = "strip.text.y.left", margin_x = TRUE, - margin_y = TRUE) - grobs_left <- assemble_strips(matrix(grobs_left, ncol = ncol, nrow = nrow), - theme, horizontal, clip = clip) - - grobs_right <- lapply(unlist(labels[, rev(seq_len(ncol(labels))), drop = FALSE], use.names = FALSE), - element_render, theme = theme, - element = "strip.text.y.right", margin_x = TRUE, - margin_y = TRUE) - grobs_right <- assemble_strips(matrix(grobs_right, ncol = ncol, nrow = nrow), - theme, horizontal, clip = clip) + grobs_left <- lapply( + labels_vec, + element_render, + theme = theme, + element = "strip.text.y.left", + margin_x = TRUE, + margin_y = TRUE + ) + grobs_left <- assemble_strips( + matrix(grobs_left, ncol = ncol, nrow = nrow), + theme, + horizontal, + clip = clip + ) + + grobs_right <- lapply( + unlist( + labels[, rev(seq_len(ncol(labels))), drop = FALSE], + use.names = FALSE + ), + element_render, + theme = theme, + element = "strip.text.y.right", + margin_x = TRUE, + margin_y = TRUE + ) + grobs_right <- assemble_strips( + matrix(grobs_right, ncol = ncol, nrow = nrow), + theme, + horizontal, + clip = clip + ) list( left = grobs_left, @@ -573,13 +630,18 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) { } else { mat <- matrix(x, nrow = 1) } - gtable_matrix("strip", mat, rep(width, ncol(mat)), rep(height, nrow(mat)), clip = clip) + gtable_matrix( + "strip", + mat, + rep(width, ncol(mat)), + rep(height, nrow(mat)), + clip = clip + ) }) } # Reject old school labeller validate_labeller <- function(labeller) { - labeller <- match.fun(labeller) is_deprecated <- all(c("variable", "value") %in% names(formals(labeller))) diff --git a/R/labels.R b/R/labels.R index a0991fed03..1848172035 100644 --- a/R/labels.R +++ b/R/labels.R @@ -50,7 +50,8 @@ setup_plot_labels <- function(plot, layers, data) { # Search for label attribute in symbolic mappings symbolic <- vapply( - mapping, FUN.VALUE = logical(1), + mapping, + FUN.VALUE = logical(1), function(x) is_quosure(x) && quo_is_symbol(x) ) symbols <- intersect(names(mapping)[symbolic], names(data[[i]])) @@ -65,7 +66,11 @@ setup_plot_labels <- function(plot, layers, data) { # 2. The labels of this layer, including fallback labels # 3. Existing fallback labels current <- labels - fallbacks <- vapply(current, function(l) isTRUE(attr(l, "fallback")), logical(1)) + fallbacks <- vapply( + current, + function(l) isTRUE(attr(l, "fallback")), + logical(1) + ) labels <- defaults(current[!fallbacks], layer_labels) if (any(fallbacks)) { @@ -76,13 +81,12 @@ setup_plot_labels <- function(plot, layers, data) { # Warn for spurious labels that don't have a mapping. # Note: sometimes, 'x' and 'y' might not have a mapping, like in # `geom_function()`. We can display these labels anyway, so we include them. - plot_labels <- plot@labels + plot_labels <- plot@labels known_labels <- c(names(labels), fn_fmls_names(labs), "x", "y") extra_labels <- names(plot_labels)[lengths(plot_labels) > 0] extra_labels <- setdiff(extra_labels, known_labels) if (length(extra_labels) > 0) { - warn_labels <- plot_labels[extra_labels] warn_labels <- ifelse( vapply(warn_labels, is.function, logical(1)), @@ -190,13 +194,28 @@ setup_plot_labels <- function(plot, layers, data) { #' p + #' labs(title = "title") + #' labs(title = NULL) -labs <- function(..., title = waiver(), subtitle = waiver(), - caption = waiver(), tag = waiver(), dictionary = waiver(), - alt = waiver(), alt_insight = waiver()) { +labs <- function( + ..., + title = waiver(), + subtitle = waiver(), + caption = waiver(), + tag = waiver(), + dictionary = waiver(), + alt = waiver(), + alt_insight = waiver() +) { # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ... - args <- dots_list(..., title = title, subtitle = subtitle, caption = caption, - tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, - dictionary = dictionary, .ignore_empty = "all") + args <- dots_list( + ..., + title = title, + subtitle = subtitle, + caption = caption, + tag = tag, + alt = allow_lambda(alt), + alt_insight = alt_insight, + dictionary = dictionary, + .ignore_empty = "all" + ) is_waive <- vapply(args, is_waiver, logical(1)) args <- args[!is_waive] @@ -242,10 +261,16 @@ get_labs <- function(plot = get_last_plot()) { labs <- plot@plot@labels xy_labs <- rename( - c(x = plot@layout$resolve_label(plot@layout$panel_scales_x[[1]], labs), - y = plot@layout$resolve_label(plot@layout$panel_scales_y[[1]], labs)), - c(x.primary = "x", x.secondary = "x.sec", - y.primary = "y", y.secondary = "y.sec") + c( + x = plot@layout$resolve_label(plot@layout$panel_scales_x[[1]], labs), + y = plot@layout$resolve_label(plot@layout$panel_scales_y[[1]], labs) + ), + c( + x.primary = "x", + x.secondary = "x.sec", + y.primary = "y", + y.secondary = "y.sec" + ) ) labs <- defaults(xy_labs, labs) @@ -257,9 +282,9 @@ get_labs <- function(plot = get_last_plot()) { for (aes in guides$aesthetics) { param <- guides$get_params(aes) - aes <- param$aesthetic # Can have length > 1 when guide was merged + aes <- param$aesthetic # Can have length > 1 when guide was merged title <- vec_set_names(rep(list(param$title), length(aes)), aes) - labs <- defaults(title, labs) + labs <- defaults(title, labs) } labs } @@ -377,9 +402,13 @@ generate_alt_text <- function(p) { title <- "" } - # Get axes descriptions - axes <- paste0(" showing ", scale_description(p, "x"), " and ", scale_description(p, "y")) + axes <- paste0( + " showing ", + scale_description(p, "x"), + " and ", + scale_description(p, "y") + ) axes <- safe_string(axes) # Get layer types @@ -410,7 +439,9 @@ scale_description <- function(p, name) { } else { lab <- scale$make_title(scale$name %|W|% p@labels[[name]]) type <- "a continuous" - if (scale$is_discrete()) type <- "a discrete" + if (scale$is_discrete()) { + type <- "a discrete" + } if (inherits(scale, "ScaleBinned")) type <- "a binned" } if (is.null(lab)) { diff --git a/R/layer-sf.R b/R/layer-sf.R index 3695084aa9..f3f23b3b78 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -8,11 +8,18 @@ #' @inheritParams layer #' @keywords internal #' @export -layer_sf <- function(geom = NULL, stat = NULL, - data = NULL, mapping = NULL, - position = NULL, params = list(), - inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE, - show.legend = NA) { +layer_sf <- function( + geom = NULL, + stat = NULL, + data = NULL, + mapping = NULL, + position = NULL, + params = list(), + inherit.aes = TRUE, + check.aes = TRUE, + check.param = TRUE, + show.legend = NA +) { call_env <- caller_env() if (is.character(show.legend)) { legend_key_type <- show.legend @@ -22,20 +29,31 @@ layer_sf <- function(geom = NULL, stat = NULL, } # inherit from LayerSf class to add `legend_key_type` slot - layer_class <- ggproto(NULL, LayerSf, + layer_class <- ggproto( + NULL, + LayerSf, constructor = frame_call(call_env), legend_key_type = legend_key_type ) layer( - geom = geom, stat = stat, data = data, mapping = mapping, - position = position, params = params, inherit.aes = inherit.aes, - check.aes = check.aes, check.param = check.param, - show.legend = show.legend, layer_class = layer_class + geom = geom, + stat = stat, + data = data, + mapping = mapping, + position = position, + params = params, + inherit.aes = inherit.aes, + check.aes = check.aes, + check.param = check.param, + show.legend = show.legend, + layer_class = layer_class ) } -LayerSf <- ggproto("LayerSf", Layer, +LayerSf <- ggproto( + "LayerSf", + Layer, legend_key_type = NULL, setup_layer = function(self, data, plot) { @@ -58,7 +76,9 @@ LayerSf <- ggproto("LayerSf", Layer, if (is.null(legend_type)) { legend_type <- switch( detect_sf_type(data$geometry), - point = "point", line = "line", "other" + point = "point", + line = "line", + "other" ) } @@ -68,7 +88,9 @@ LayerSf <- ggproto("LayerSf", Layer, }, compute_geom_2 = function(self, data, params = self$aes_params, ...) { - if (empty(data)) return(data) + if (empty(data)) { + return(data) + } data$geometry <- data$geometry %||% self$computed_geom_params$legend ggproto_parent(Layer, self)$compute_geom_2(data, params, ...) } @@ -86,8 +108,9 @@ geom_column <- function(data) { } } else { # this may not be best in case more than one geometry list-column is present: - if (length(w) > 1) + if (length(w) > 1) { cli::cli_warn("More than one geometry column present: taking the first") + } w[[1]] } } @@ -108,6 +131,8 @@ detect_sf_type <- function(sf) { return("other") } geometry_type <- unique0(as.character(sf::st_geometry_type(sf))) - if (length(geometry_type) != 1) geometry_type <- "GEOMETRY" + if (length(geometry_type) != 1) { + geometry_type <- "GEOMETRY" + } sf_types[geometry_type] } diff --git a/R/layer.R b/R/layer.R index d241f69af5..5f861e171f 100644 --- a/R/layer.R +++ b/R/layer.R @@ -96,18 +96,30 @@ #' data = head, params = list(na.rm = FALSE) #' ) #' -layer <- function(geom = NULL, stat = NULL, - data = NULL, mapping = NULL, - position = NULL, params = list(), - inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE, - show.legend = NA, key_glyph = NULL, layout = NULL, layer_class = Layer) { +layer <- function( + geom = NULL, + stat = NULL, + data = NULL, + mapping = NULL, + position = NULL, + params = list(), + inherit.aes = TRUE, + check.aes = TRUE, + check.param = TRUE, + show.legend = NA, + key_glyph = NULL, + layout = NULL, + layer_class = Layer +) { call_env <- caller_env() user_env <- caller_env(2) # Handle show_guide/show.legend if (!is.null(params$show_guide)) { lifecycle::deprecate_stop( - "2.0.0", "layer(show_guide)", "layer(show.legend)" + "2.0.0", + "layer(show_guide)", + "layer(show.legend)" ) } @@ -123,19 +135,33 @@ layer <- function(geom = NULL, stat = NULL, geom <- validate_subclass(geom, "Geom", env = parent.frame(), call = call_env) stat <- validate_subclass(stat, "Stat", env = parent.frame(), call = call_env) - position <- validate_subclass(position, "Position", env = parent.frame(), call = call_env) + position <- validate_subclass( + position, + "Position", + env = parent.frame(), + call = call_env + ) # Special case for na.rm parameter needed by all layers params$na.rm <- params$na.rm %||% FALSE # Split up params between aesthetics, geom, and stat params <- rename_aes(params) - aes_params <- params[intersect(names(params), union(geom$aesthetics(), position$aesthetics()))] + aes_params <- params[intersect( + names(params), + union(geom$aesthetics(), position$aesthetics()) + )] geom_params <- params[intersect(names(params), geom$parameters(TRUE))] stat_params <- params[intersect(names(params), stat$parameters(TRUE))] ignore <- c("key_glyph", "name", "layout") - all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics(), position$aesthetics(), ignore) + all <- c( + geom$parameters(TRUE), + stat$parameters(TRUE), + geom$aesthetics(), + position$aesthetics(), + ignore + ) # Take care of plain patterns provided as aesthetic pattern <- vapply(aes_params, is_pattern, logical(1)) @@ -155,13 +181,25 @@ layer <- function(geom = NULL, stat = NULL, # Warn about extra params and aesthetics extra_param <- setdiff(names(params), all) # Take care of size->linewidth renaming in layer params - if (geom$rename_size && "size" %in% extra_param && !"linewidth" %in% mapped_aesthetics(mapping)) { + if ( + geom$rename_size && + "size" %in% extra_param && + !"linewidth" %in% mapped_aesthetics(mapping) + ) { aes_params <- c(aes_params, params["size"]) extra_param <- setdiff(extra_param, "size") - deprecate_warn0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`"), user_env = user_env) + deprecate_warn0( + "3.4.0", + I("Using `size` aesthetic for lines"), + I("`linewidth`"), + user_env = user_env + ) } if (check.param && length(extra_param) > 0) { - cli::cli_warn("Ignoring unknown parameters: {.arg {extra_param}}", call = call_env) + cli::cli_warn( + "Ignoring unknown parameters: {.arg {extra_param}}", + call = call_env + ) } extra_aes <- setdiff( @@ -169,21 +207,37 @@ layer <- function(geom = NULL, stat = NULL, c(geom$aesthetics(), stat$aesthetics(), position$aesthetics()) ) # Take care of size->linewidth aes renaming - if (geom$rename_size && "size" %in% extra_aes && !"linewidth" %in% mapped_aesthetics(mapping)) { + if ( + geom$rename_size && + "size" %in% extra_aes && + !"linewidth" %in% mapped_aesthetics(mapping) + ) { extra_aes <- setdiff(extra_aes, "size") - deprecate_warn0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`"), user_env = user_env) + deprecate_warn0( + "3.4.0", + I("Using `size` aesthetic for lines"), + I("`linewidth`"), + user_env = user_env + ) } if (check.aes && length(extra_aes) > 0) { - cli::cli_warn("Ignoring unknown aesthetics: {.field {extra_aes}}", call = call_env) + cli::cli_warn( + "Ignoring unknown aesthetics: {.field {extra_aes}}", + call = call_env + ) } # adjust the legend draw key if requested geom <- set_draw_key(geom, key_glyph %||% params$key_glyph) - fr_call <- layer_class$constructor %||% frame_call(call_env) %||% current_call() + fr_call <- layer_class$constructor %||% + frame_call(call_env) %||% + current_call() attr(fr_call, "srcref") <- NULL - ggproto("LayerInstance", layer_class, + ggproto( + "LayerInstance", + layer_class, constructor = fr_call, geom = geom, geom_params = geom_params, @@ -216,7 +270,10 @@ validate_mapping <- function(mapping, call = caller_env()) { # Native pipe have higher precedence than + so any type of gg object can be # expected here, not just ggplot if (S7::S7_inherits(mapping, class_gg)) { - msg <- c(msg, "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?") + msg <- c( + msg, + "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?" + ) } cli::cli_abort(msg, call = call) @@ -386,7 +443,9 @@ validate_mapping <- function(mapping, call = caller_env()) { #' @keywords internal #' @examples #' # None: Layer is not intended to be extended -Layer <- ggproto("Layer", NULL, +Layer <- ggproto( + "Layer", + NULL, # Fields ------------------------------------------------------------------ @@ -495,15 +554,24 @@ Layer <- ggproto("Layer", NULL, setup_layer = function(self, data, plot) { # For annotation geoms, it is useful to be able to ignore the default aes if (isTRUE(self$inherit.aes)) { - self$computed_mapping <- class_mapping(defaults(self$mapping, plot@mapping)) + self$computed_mapping <- class_mapping(defaults( + self$mapping, + plot@mapping + )) # Inherit size as linewidth from global mapping - if (self$geom$rename_size && + if ( + self$geom$rename_size && "size" %in% names(plot@mapping) && !"linewidth" %in% names(self$computed_mapping) && - "linewidth" %in% self$geom$aesthetics()) { + "linewidth" %in% self$geom$aesthetics() + ) { self$computed_mapping$size <- plot@mapping$size - deprecate_warn0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`")) + deprecate_warn0( + "3.4.0", + I("Using `size` aesthetic for lines"), + I("`linewidth`") + ) } } else { self$computed_mapping <- self$mapping @@ -559,9 +627,10 @@ Layer <- ggproto("Layer", NULL, # Check aesthetic values check_nondata_cols( - evaled, aesthetics, + evaled, + aesthetics, problem = "Aesthetics are not valid data columns.", - hint = "Did you mistype the name of a data column or forget to add {.fn after_stat}?" + hint = "Did you mistype the name of a data column or forget to add {.fn after_stat}?" ) n <- nrow(data) @@ -574,13 +643,20 @@ Layer <- ggproto("Layer", NULL, n <- if (min(aes_n) == 0) 0L else max(aes_n) } } - if ((self$geom$check_constant_aes %||% TRUE) - && length(aes_n) > 0 && all(aes_n == 1) && n > 1) { - cli::cli_warn(c( - "All aesthetics have length 1, but the data has {n} rows.", - i = "Please consider using {.fn annotate} or provide this layer \\ + if ( + (self$geom$check_constant_aes %||% TRUE) && + length(aes_n) > 0 && + all(aes_n == 1) && + n > 1 + ) { + cli::cli_warn( + c( + "All aesthetics have length 1, but the data has {n} rows.", + i = "Please consider using {.fn annotate} or provide this layer \\ with data containing a single row." - ), call = self$constructor) + ), + call = self$constructor + ) } check_aesthetics(evaled, n) @@ -617,7 +693,9 @@ Layer <- ggproto("Layer", NULL, #' A data frame with layer data. As a side effect the `computed_stat_params` #' field is populated. compute_statistic = function(self, data, layout) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } ptype <- vec_ptype(data) self$computed_stat_params <- self$stat$setup_params(data, self$stat_params) @@ -651,7 +729,9 @@ Layer <- ggproto("Layer", NULL, #' #' A data frame with layer data map_statistic = function(self, data, plot) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } # Make sure data columns are converted to correct names. If not done, a # column with e.g. a color name will not be found in an after_stat() @@ -663,22 +743,28 @@ Layer <- ggproto("Layer", NULL, aesthetics <- defaults(aesthetics, self$stat$default_aes) aesthetics <- compact(aesthetics) - new <- strip_dots(aesthetics[is_calculated_aes(aesthetics) | is_staged_aes(aesthetics)]) - if (length(new) == 0) return(data) + new <- strip_dots(aesthetics[ + is_calculated_aes(aesthetics) | is_staged_aes(aesthetics) + ]) + if (length(new) == 0) { + return(data) + } # data needs to be non-scaled data_orig <- plot@scales$backtransform_df(data) # Add map stat output to aesthetics stat_data <- eval_aesthetics( - substitute_aes(new), data_orig, + substitute_aes(new), + data_orig, mask = list(stage = stage_calculated) ) # Check that all columns in aesthetic stats are valid data check_nondata_cols( - stat_data, aesthetics, + stat_data, + aesthetics, problem = "Aesthetics must be valid computed stats.", - hint = "Did you map your stat in the wrong layer?" + hint = "Did you map your stat in the wrong layer?" ) stat_data <- data_frame0(!!!stat_data) @@ -716,7 +802,9 @@ Layer <- ggproto("Layer", NULL, #' A data frame with layer data. As a side effect the `computed_geom_params` #' field is populated. compute_geom_1 = function(self, data) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } ptype <- vec_ptype(data) check_required_aesthetics( @@ -724,7 +812,10 @@ Layer <- ggproto("Layer", NULL, c(names(data), names(self$aes_params)), snake_class(self$geom) ) - self$computed_geom_params <- self$geom$setup_params(data, c(self$geom_params, self$aes_params)) + self$computed_geom_params <- self$geom$setup_params( + data, + c(self$geom_params, self$aes_params) + ) data <- self$geom$setup_data(data, self$computed_geom_params) merge_attrs(data, ptype) }, @@ -749,7 +840,9 @@ Layer <- ggproto("Layer", NULL, #' #' A data frame with layer data. compute_position = function(self, data, layout) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } ptype <- vec_ptype(data) data <- self$position$use_defaults(data, self$aes_params) params <- self$position$setup_params(data) @@ -780,12 +873,24 @@ Layer <- ggproto("Layer", NULL, #' **Value** #' #' A data frame with layer data. - compute_geom_2 = function(self, data, params = self$aes_params, theme = NULL, ...) { + compute_geom_2 = function( + self, + data, + params = self$aes_params, + theme = NULL, + ... + ) { # Combine aesthetics, defaults, & params - if (empty(data)) return(data) + if (empty(data)) { + return(data) + } aesthetics <- self$computed_mapping - modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics) | is_themed_aes(aesthetics)] + modifiers <- aesthetics[ + is_scaled_aes(aesthetics) | + is_staged_aes(aesthetics) | + is_themed_aes(aesthetics) + ] self$geom$use_defaults(data, params, modifiers, theme = theme, ...) }, @@ -861,10 +966,20 @@ Layer <- ggproto("Layer", NULL, if (!is.null(self$mapping)) { cat("mapping:", clist(self$mapping), "\n") } - cat(snakeize(class(self$geom)[[1]]), ": ", clist(self$geom_params), "\n", - sep = "") - cat(snakeize(class(self$stat)[[1]]), ": ", clist(self$stat_params), "\n", - sep = "") + cat( + snakeize(class(self$geom)[[1]]), + ": ", + clist(self$geom_params), + "\n", + sep = "" + ) + cat( + snakeize(class(self$stat)[[1]]), + ": ", + clist(self$stat_params), + "\n", + sep = "" + ) cat(snakeize(class(self$position)[[1]]), "\n") } ) @@ -874,19 +989,27 @@ Layer <- ggproto("Layer", NULL, #' @export #' @rdname is_tests is_layer <- function(x) inherits(x, "Layer") -is.layer <- function(x) lifecycle::deprecate_stop("3.5.2", "is.layer()", "is_layer()") - -validate_subclass <- function(x, subclass, - argname = to_lower_ascii(subclass), - x_arg = caller_arg(x), - env = parent.frame(), - call = caller_env()) { +is.layer <- function(x) { + lifecycle::deprecate_stop("3.5.2", "is.layer()", "is_layer()") +} +validate_subclass <- function( + x, + subclass, + argname = to_lower_ascii(subclass), + x_arg = caller_arg(x), + env = parent.frame(), + call = caller_env() +) { if (inherits(x, subclass)) { return(x) } if (!is_scalar_character(x)) { - stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object"), arg = x_arg) + stop_input_type( + x, + as_cli("either a string or a {.cls {subclass}} object"), + arg = x_arg + ) } # Try getting class object directly @@ -907,9 +1030,11 @@ validate_subclass <- function(x, subclass, cnd$call <- call(name) cli::cli_abort( "Failed to retrieve a {.cls {subclass}} object from {.fn {name}}.", - parent = cnd, call = call + parent = cnd, + call = call ) - }) + } + ) } # Position constructors return classes directly if (inherits(obj, subclass)) { diff --git a/R/layout.R b/R/layout.R index 3149c2ec74..2b414a632c 100644 --- a/R/layout.R +++ b/R/layout.R @@ -46,7 +46,8 @@ create_layout <- function(facet, coord, layout = NULL) { #' # Use in custom `ggplot_build()` methods #' layout <- ggproto(NULL, Layout, facet = facet, coord = coord) Layout <- ggproto( - "Layout", NULL, + "Layout", + NULL, # Fields ---------------------------------------------------------------- @@ -111,7 +112,12 @@ Layout <- ggproto( #' A list of data frames from the `data` argument with a `PANEL` variable #' corresponding to rows in the `layout` field. #' Also called for the side effects of populating fields. - setup = function(self, data, plot_data = data_frame0(), plot_env = emptyenv()) { + setup = function( + self, + data, + plot_data = data_frame0(), + plot_env = emptyenv() + ) { data <- c(list(plot_data), data) # Setup facets @@ -129,7 +135,9 @@ Layout <- ggproto( check_layout(self$layout) # Add panel coordinates to the data for each layer - lapply(data[-1], self$facet$map_data, + lapply( + data[-1], + self$facet$map_data, layout = self$layout, params = self$facet_params ) @@ -161,12 +169,18 @@ Layout <- ggproto( # Initialise scales if needed, and possible. layout <- self$layout if (is.null(self$panel_scales_x)) { - self$panel_scales_x <- self$facet$init_scales(layout, x_scale = x_scale, - params = self$facet_params)$x + self$panel_scales_x <- self$facet$init_scales( + layout, + x_scale = x_scale, + params = self$facet_params + )$x } if (is.null(self$panel_scales_y)) { - self$panel_scales_y <- self$facet$init_scales(layout, y_scale = y_scale, - params = self$facet_params)$y + self$panel_scales_y <- self$facet$init_scales( + layout, + y_scale = y_scale, + params = self$facet_params + )$y } self$facet$train_scales( @@ -206,23 +220,41 @@ Layout <- ggproto( # Loop through each variable, mapping across each scale, then joining # back together - x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names(layer_data)) + x_vars <- intersect( + self$panel_scales_x[[1]]$aesthetics, + names(layer_data) + ) if (length(x_vars) > 0) { match_id <- match(layer_data$PANEL, layout$PANEL) names(x_vars) <- x_vars SCALE_X <- layout$SCALE_X[match_id] - new_x <- scale_apply(layer_data, x_vars, "map", SCALE_X, self$panel_scales_x) + new_x <- scale_apply( + layer_data, + x_vars, + "map", + SCALE_X, + self$panel_scales_x + ) layer_data[, x_vars] <- new_x } - y_vars <- intersect(self$panel_scales_y[[1]]$aesthetics, names(layer_data)) + y_vars <- intersect( + self$panel_scales_y[[1]]$aesthetics, + names(layer_data) + ) if (length(y_vars) > 0) { if (is.null(match_id)) { match_id <- match(layer_data$PANEL, layout$PANEL) } names(y_vars) <- y_vars SCALE_Y <- layout$SCALE_Y[match_id] - new_y <- scale_apply(layer_data, y_vars, "map", SCALE_Y, self$panel_scales_y) + new_y <- scale_apply( + layer_data, + y_vars, + "map", + SCALE_Y, + self$panel_scales_y + ) layer_data[, y_vars] <- new_y } @@ -248,7 +280,9 @@ Layout <- ggproto( #' #' Nothing, it is called for the side-effect of resetting scale ranges. reset_scales = function(self) { - if (!self$facet$shrink) return() + if (!self$facet$shrink) { + return() + } lapply(self$panel_scales_x, function(s) s$reset()) lapply(self$panel_scales_y, function(s) s$reset()) invisible() @@ -285,7 +319,8 @@ Layout <- ggproto( panel_params <- Map( self$coord$setup_panel_params, - scales_x, scales_y, + scales_x, + scales_y, MoreArgs = list(params = self$coord_params) )[order] # `[order]` does the repeating @@ -322,7 +357,6 @@ Layout <- ggproto( #' Nothing, it is called for the side effect of augmenting each entry of the #' `panel_params` field with position guides. setup_panel_guides = function(self, guides, layers) { - # Like in `setup_panel_params`, we only need to setup guides for unique # combinations of x/y scales. index <- vec_unique_loc(self$layout$COORD) @@ -364,7 +398,9 @@ Layout <- ggproto( #' #' A list of data frames with layer data. finish_data = function(self, data) { - lapply(data, self$facet$finish_data, + lapply( + data, + self$facet$finish_data, layout = self$layout, x_scales = self$panel_scales_x, y_scales = self$panel_scales_y, @@ -489,14 +525,14 @@ Layout <- ggproto( if (!is.null(params)) { prim_guide <- params[[1]]$title seco_guide <- params[[2]]$title - position <- scale$position + position <- scale$position if ((params[[1]]$position %||% position) != position) { order <- rev(order) } } } - primary <- scale$make_title(prim_guide, prim_scale, prim_label) + primary <- scale$make_title(prim_guide, prim_scale, prim_label) secondary <- scale$make_sec_title(seco_guide, seco_scale, seco_label) if (is_derived(secondary)) { secondary <- primary @@ -537,8 +573,9 @@ Layout <- ggproto( } else { switch(label, x = ".bottom", y = ".right") } - if (is.null(labels[[label]][[i]]) || is_waiver(labels[[label]][[i]])) + if (is.null(labels[[label]][[i]]) || is_waiver(labels[[label]][[i]])) { return(zeroGrob()) + } element_render( theme = theme, @@ -592,8 +629,12 @@ Layout <- ggproto( # data set. Implement in such a way to minimize copying and hence maximise # speed scale_apply <- function(data, vars, method, scale_id, scales) { - if (length(vars) == 0) return() - if (nrow(data) == 0) return() + if (length(vars) == 0) { + return() + } + if (nrow(data) == 0) { + return() + } if (anyNA(scale_id)) { cli::cli_abort("{.arg scale_id} must not contain any {.val NA}.") diff --git a/R/legend-draw.R b/R/legend-draw.R index 25aedae0f7..847488161f 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -27,7 +27,9 @@ draw_key_point <- function(data, params, size) { data$shape <- translate_shape_string(data$shape %||% 19) # NULL means the default stroke size, and NA means no stroke. - pointsGrob(0.5, 0.5, + pointsGrob( + 0.5, + 0.5, pch = data$shape, gp = gg_par( col = alpha(data$colour %||% "black", data$alpha), @@ -41,7 +43,11 @@ draw_key_point <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_abline <- function(data, params, size) { - segmentsGrob(0, 0, 1, 1, + segmentsGrob( + 0, + 0, + 1, + 1, gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), lwd = data$linewidth %||% 0.5, @@ -55,16 +61,17 @@ draw_key_abline <- function(data, params, size) { #' @rdname draw_key draw_key_rect <- function(data, params, size) { colour <- if (is.na(data$fill %||% NA)) data$colour - rectGrob(gp = gg_par( - col = NA, - fill = fill_alpha(colour %||% "grey20", data$alpha), - lty = data$linetype %||% 1 - )) + rectGrob( + gp = gg_par( + col = NA, + fill = fill_alpha(colour %||% "grey20", data$alpha), + lty = data$linetype %||% 1 + ) + ) } #' @export #' @rdname draw_key draw_key_polygon <- function(data, params, size) { - lwd <- data$linewidth %||% 0 grob <- rectGrob( @@ -77,11 +84,12 @@ draw_key_polygon <- function(data, params, size) { lwd = lwd, linejoin = params$linejoin %||% "mitre", lineend = params$lineend %||% "butt" - )) + ) + ) # Magic number is 5 because we convert mm to cm (divide by 10) but we # draw two lines in each direction (times 2) - attr(grob, "width") <- lwd / 5 + attr(grob, "width") <- lwd / 5 attr(grob, "height") <- lwd / 5 grob } @@ -176,7 +184,6 @@ draw_key_crossbar <- function(data, params, size) { lwd = params$box_gp$linewidth ) - if (isTRUE(params$flipped_aes)) { grobTree( rectGrob(height = 0.75, width = 0.5, gp = box), @@ -198,11 +205,17 @@ draw_key_path <- function(data, params, size) { if (is.null(data$linetype)) { data$linetype <- 0 } - grob <- segmentsGrob(0.1, 0.5, 0.9, 0.5, + grob <- segmentsGrob( + 0.1, + 0.5, + 0.9, + 0.5, gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - fill = alpha(params$arrow.fill %||% data$colour - %||% data$fill %||% "black", data$alpha), + fill = alpha( + params$arrow.fill %||% data$colour %||% data$fill %||% "black", + data$alpha + ), lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt" @@ -212,7 +225,7 @@ draw_key_path <- function(data, params, size) { if (!is.null(params[["arrow"]])) { angle <- deg2rad(params[["arrow"]]$angle) length <- convertUnit(params[["arrow"]]$length, "cm", valueOnly = TRUE) - attr(grob, "width") <- cos(angle) * length * 1.25 + attr(grob, "width") <- cos(angle) * length * 1.25 attr(grob, "height") <- sin(angle) * length * 2 } grob @@ -221,7 +234,11 @@ draw_key_path <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_vpath <- function(data, params, size) { - grob <- segmentsGrob(0.5, 0.1, 0.5, 0.9, + grob <- segmentsGrob( + 0.5, + 0.1, + 0.5, + 0.9, gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), lwd = data$linewidth %||% 0.5, @@ -233,7 +250,7 @@ draw_key_vpath <- function(data, params, size) { if (!is.null(params[["arrow"]])) { angle <- deg2rad(params[["arrow"]]$angle) length <- convertUnit(params[["arrow"]]$length, "cm", valueOnly = TRUE) - attr(grob, "width") <- sin(angle) * length * 2 + attr(grob, "width") <- sin(angle) * length * 2 attr(grob, "height") <- cos(angle) * length * 1.25 } grob @@ -242,7 +259,10 @@ draw_key_vpath <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_dotplot <- function(data, params, size) { - pointsGrob(0.5, 0.5, size = unit(0.5, "npc"), + pointsGrob( + 0.5, + 0.5, + size = unit(0.5, "npc"), pch = 21, gp = gg_par( col = alpha(data$colour %||% "black", data$alpha), @@ -271,7 +291,7 @@ draw_key_pointrange <- function(data, params, size) { linerange, draw_key_point(transform(data, size = (data$size %||% 1.5) * 4), params) ) - attr(grob, "width") <- attr(linerange, "width") + attr(grob, "width") <- attr(linerange, "width") attr(grob, "height") <- attr(linerange, "height") grob } @@ -296,27 +316,33 @@ draw_key_smooth <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_text <- function(data, params, size) { - data <- replace_null(unclass(data), label = "a", angle = 0) + data <- replace_null(unclass(data), label = "a", angle = 0) hjust <- compute_just(data$hjust %||% 0.5) vjust <- compute_just(data$vjust %||% 0.5) - just <- rotate_just(data$angle, hjust, vjust) - grob <- titleGrob( + just <- rotate_just(data$angle, hjust, vjust) + grob <- titleGrob( data$label, - x = unit(just$hjust, "npc"), y = unit(just$vjust, "npc"), + x = unit(just$hjust, "npc"), + y = unit(just$vjust, "npc"), angle = data$angle, hjust = hjust, vjust = vjust, gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - fontfamily = data$family %||% "", - fontface = data$fontface %||% 1, - fontsize = (data$size %||% 3.88) * .pt + fontfamily = data$family %||% "", + fontface = data$fontface %||% 1, + fontsize = (data$size %||% 3.88) * .pt ), margin = margin_auto(0.1, unit = "lines"), - margin_x = TRUE, margin_y = TRUE + margin_x = TRUE, + margin_y = TRUE + ) + attr(grob, "width") <- convertWidth(grobWidth(grob), "cm", valueOnly = TRUE) + attr(grob, "height") <- convertHeight( + grobHeight(grob), + "cm", + valueOnly = TRUE ) - attr(grob, "width") <- convertWidth(grobWidth(grob), "cm", valueOnly = TRUE) - attr(grob, "height") <- convertHeight(grobHeight(grob), "cm", valueOnly = TRUE) grob } @@ -326,7 +352,7 @@ draw_key_label <- function(data, params, size) { data <- replace_null(unclass(data), label = "a", angle = 0) hjust <- compute_just(data$hjust %||% 0.5) vjust <- compute_just(data$vjust %||% 0.5) - just <- rotate_just(data$angle, hjust, vjust) + just <- rotate_just(data$angle, hjust, vjust) padding <- rep(params$label.padding %||% unit(0.25, "lines"), length.out = 4) descent <- font_descent( family = data$family %||% "", @@ -344,24 +370,28 @@ draw_key_label <- function(data, params, size) { r = params$label.r %||% unit(0.15, "lines"), text.gp = gg_par( col = params$text.colour %||% data$colour %||% "black", - fontfamily = data$family %||% "", - fontface = data$fontface %||% 1, - fontsize = (data$size %||% 3.88) * .pt + fontfamily = data$family %||% "", + fontface = data$fontface %||% 1, + fontsize = (data$size %||% 3.88) * .pt ), rect.gp = gg_par( - col = if (isTRUE(all.equal(lwd, 0))) NA else params$border.colour %||% data$colour %||% "black", + col = if (isTRUE(all.equal(lwd, 0))) { + NA + } else { + params$border.colour %||% data$colour %||% "black" + }, fill = alpha(data$fill %||% "white", data$alpha), - lwd = lwd, - lty = data$linetype %||% 1L + lwd = lwd, + lty = data$linetype %||% 1L ) ) - angle <- deg2rad(data$angle %||% 0) - text <- grob$children[[2]] - width <- convertWidth(grobWidth(text), "cm", valueOnly = TRUE) + angle <- deg2rad(data$angle %||% 0) + text <- grob$children[[2]] + width <- convertWidth(grobWidth(text), "cm", valueOnly = TRUE) height <- convertHeight(grobHeight(text), "cm", valueOnly = TRUE) x <- c(0, 0, width, width) y <- c(0, height, height, 0) - attr(grob, "width") <- diff(range(x * cos(angle) - y * sin(angle))) + attr(grob, "width") <- diff(range(x * cos(angle) - y * sin(angle))) attr(grob, "height") <- diff(range(x * sin(angle) + y * cos(angle))) grob } @@ -369,7 +399,11 @@ draw_key_label <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_vline <- function(data, params, size) { - segmentsGrob(0.5, 0, 0.5, 1, + segmentsGrob( + 0.5, + 0, + 0.5, + 1, gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), lwd = data$linewidth %||% 0.5, diff --git a/R/make-constructor.R b/R/make-constructor.R index 8dc4c5f454..4c9b287cb3 100644 --- a/R/make-constructor.R +++ b/R/make-constructor.R @@ -62,17 +62,29 @@ make_constructor <- function(x, ...) { #' @export #' @rdname make_constructor -make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(), - env = caller_env()) { - +make_constructor.Geom <- function( + x, + ..., + checks = exprs(), + omit = character(), + env = caller_env() +) { # Check that we can independently find the geom geom <- gsub("^geom_", "", snake_class(x)) validate_subclass(geom, "Geom", env = env) # Split additional arguments into required and extra ones args <- enexprs(...) - fixed_fmls_names <- c("mapping", "data", "stat", "position", "...", - "na.rm", "show.legend", "inherit.aes") + fixed_fmls_names <- c( + "mapping", + "data", + "stat", + "position", + "...", + "na.rm", + "show.legend", + "inherit.aes" + ) extra_args <- setdiff(names(args), fixed_fmls_names) if ("geom" %in% extra_args) { cli::cli_abort("{.arg geom} is a reserved argument.") @@ -80,7 +92,13 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(), # Fill in values for parameters from draw functions known_params <- - unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics(), omit)) + unique(c( + names(args), + fixed_fmls_names, + "flipped_aes", + x$aesthetics(), + omit + )) missing_params <- setdiff(x$parameters(), known_params) if (length(missing_params) > 0) { draw_args <- ggproto_formals(x$draw_panel) @@ -106,13 +124,13 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(), # Build function formals fmls <- pairlist2( - mapping = args$mapping, - data = args$data, - stat = args$stat %||% "identity", + mapping = args$mapping, + data = args$data, + stat = args$stat %||% "identity", position = args$position %||% "identity", `...` = missing_arg(), !!!args[extra_args], - na.rm = args$na.rm %||% FALSE, + na.rm = args$na.rm %||% FALSE, show.legend = args$show.legend %||% NA, inherit.aes = args$inherit.aes %||% TRUE ) @@ -147,23 +165,42 @@ make_constructor.Geom <- function(x, ..., checks = exprs(), omit = character(), #' @export #' @rdname make_constructor -make_constructor.Stat <- function(x, ..., checks = exprs(), omit = character(), - env = caller_env()) { +make_constructor.Stat <- function( + x, + ..., + checks = exprs(), + omit = character(), + env = caller_env() +) { # Check that we can independently find the stat stat <- gsub("^stat_", "", snake_class(x)) validate_subclass(stat, "Stat", env = env) # Split additional arguments into required and extra ones args <- enexprs(...) - fixed_fmls_names <- c("mapping", "data", "geom", "position", "...", - "na.rm", "show.legend", "inherit.aes") + fixed_fmls_names <- c( + "mapping", + "data", + "geom", + "position", + "...", + "na.rm", + "show.legend", + "inherit.aes" + ) extra_args <- setdiff(names(args), fixed_fmls_names) if ("stat" %in% extra_args) { cli::cli_abort("{.arg stat} is a reversed argument.") } known_params <- - unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics(), omit)) + unique(c( + names(args), + fixed_fmls_names, + "flipped_aes", + x$aesthetics(), + omit + )) missing_params <- setdiff(x$parameters(), known_params) # Fill in missing parameters from the compute methods @@ -191,11 +228,11 @@ make_constructor.Stat <- function(x, ..., checks = exprs(), omit = character(), # Build function formals fmls <- pairlist2( - mapping = args$mapping, - data = args$data, - geom = args$geom %||% cli::cli_abort("{.arg geom} is required."), + mapping = args$mapping, + data = args$data, + geom = args$geom %||% cli::cli_abort("{.arg geom} is required."), position = args$position %||% "identity", - `...` = missing_arg(), + `...` = missing_arg(), !!!args[extra_args], na.rm = args$na.rm %||% FALSE, show.legend = args$show.legend %||% NA, @@ -229,4 +266,3 @@ make_constructor.Stat <- function(x, ..., checks = exprs(), omit = character(), new_function(fmls, body, new_env) } - diff --git a/R/margins.R b/R/margins.R index af52156d5d..e493e37482 100644 --- a/R/margins.R +++ b/R/margins.R @@ -6,7 +6,8 @@ #' @rdname element #' @export margin <- S7::new_class( - "margin", parent = S7::new_S3_class(c("simpleUnit", "unit", "unit_v2")), + "margin", + parent = S7::new_S3_class(c("simpleUnit", "unit", "unit_v2")), constructor = function(t = 0, r = 0, b = 0, l = 0, unit = "pt", ...) { warn_dots_empty() lens <- c(length(t), length(r), length(b), length(l)) @@ -31,7 +32,9 @@ margin <- S7::new_class( #' @export #' @rdname is_tests is_margin <- function(x) S7::S7_inherits(x, margin) -is.margin <- function(x) lifecycle::deprecate_stop("3.5.2", "is.margin()", "is_margin()") +is.margin <- function(x) { + lifecycle::deprecate_stop("3.5.2", "is.margin()", "is_margin()") +} #' @rdname element #' @export @@ -85,9 +88,20 @@ as_margin <- function(x, x_arg = caller_arg(x), call = caller_env()) { #' is anchored. #' #' @noRd -titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), - margin = NULL, margin_x = FALSE, margin_y = FALSE, - debug = FALSE, check.overlap = FALSE) { +titleGrob <- function( + label, + x, + y, + hjust, + vjust, + angle = 0, + gp = gpar(), + margin = NULL, + margin_x = FALSE, + margin_y = FALSE, + debug = FALSE, + check.overlap = FALSE +) { if (is.null(label)) { return(zeroGrob()) } @@ -107,9 +121,14 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), } grob <- textGrob( - label, x, y, - hjust = hjust, vjust = vjust, - rot = angle, gp = gp, check.overlap = check.overlap + label, + x, + y, + hjust = hjust, + vjust = vjust, + rot = angle, + gp = gp, + check.overlap = check.overlap ) # The grob dimensions don't include the text descenders, so these need to be added @@ -128,7 +147,7 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), y_descent <- abs(cos(rad)) * descent # Set text size to actual size including descenders - width <- unit(1, "grobwidth", grob) + x_descent + width <- unit(1, "grobwidth", grob) + x_descent height <- unit(1, "grobheight", grob) + y_descent # Resolve margin @@ -141,7 +160,7 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), # Initialise new values for position and dimensions new_x <- NULL new_y <- NULL - new_width <- NULL + new_width <- NULL new_height <- NULL # Calculate new x/width @@ -158,12 +177,12 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), # If only one margin is set, the other dimension is a null unit if (xor(margin_x, margin_y)) { - new_width <- new_width %||% unit(1, "null") + new_width <- new_width %||% unit(1, "null") new_height <- new_height %||% unit(1, "null") } # If we haven't touched the new positions/dimensions, use the previous ones - new_width <- new_width %||% width + new_width <- new_width %||% width new_height <- new_height %||% height x <- new_x %||% x y <- new_y %||% y @@ -176,8 +195,12 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), if (isTRUE(debug)) { children <- gList( rectGrob( - x = x, y = y, width = width, height = height, - hjust = just$hjust, vjust = just$vjust, + x = x, + y = y, + width = width, + height = height, + hjust = just$hjust, + vjust = just$vjust, gp = gg_par(fill = "cornsilk", col = NA) ), pointsGrob(x, y, pch = 20, gp = gg_par(col = "gold")), @@ -189,8 +212,8 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), gTree( children = children, - widths = new_width, - heights = new_height, + widths = new_width, + heights = new_height, cl = "titleGrob" ) } @@ -213,7 +236,12 @@ heightDetails.titleGrob <- function(x) { #' @return A list with two components, `hjust` and `vjust`, containing the rotated hjust and vjust values #' #' @noRd -rotate_just <- function(angle = NULL, hjust = NULL, vjust = NULL, element = NULL) { +rotate_just <- function( + angle = NULL, + hjust = NULL, + vjust = NULL, + element = NULL +) { ## Ideally we would like to do something like the following commented-out lines, ## but it currently yields unexpected results for angles other than 0, 90, 180, 270. ## Problems arise in particular in cases where the horizontal and the vertical @@ -249,7 +277,7 @@ rotate_just <- function(angle = NULL, hjust = NULL, vjust = NULL, element = NULL } # Apply recycle rules - size <- vec_size_common(angle, hjust, vjust) + size <- vec_size_common(angle, hjust, vjust) angle <- vec_recycle(angle, size) hjust <- vec_recycle(hjust, size) vjust <- vec_recycle(vjust, size) @@ -280,7 +308,7 @@ descent_cache <- new.env(parent = emptyenv()) font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { cur_dev <- names(grDevices::dev.cur()) if (cur_dev == "null device") { - cache <- FALSE # don't cache if no device open + cache <- FALSE # don't cache if no device open } else { cache <- TRUE } @@ -291,15 +319,18 @@ font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { descent <- descent_cache[[key]] if (is.null(descent)) { - descent <- convertHeight(grobDescent(textGrob( - label = "gjpqyQ", - gp = gg_par( - fontsize = size, - cex = cex, - fontfamily = family, - fontface = face - ) - )), 'inches') + descent <- convertHeight( + grobDescent(textGrob( + label = "gjpqyQ", + gp = gg_par( + fontsize = size, + cex = cex, + fontfamily = family, + fontface = face + ) + )), + 'inches' + ) if (cache) { descent_cache[[key]] <- descent diff --git a/R/performance.R b/R/performance.R index 7676ed31d6..428e788f64 100644 --- a/R/performance.R +++ b/R/performance.R @@ -1,7 +1,9 @@ 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 + if (!is.null(col_names)) { + names(x) <- col_names + } x } @@ -12,7 +14,9 @@ mat_2_df <- function(x, col_names = colnames(x)) { # More performant modifyList without recursion modify_list <- function(old, new) { - for (i in names(new)) old[[i]] <- new[[i]] + for (i in names(new)) { + old[[i]] <- new[[i]] + } old } modifyList <- function(...) { diff --git a/R/plot-build.R b/R/plot-build.R index 5379d9b6b6..028aa14237 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -53,8 +53,18 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { # Allow all layers to make any final adjustments based # on raw input data and plot info - data <- by_layer(function(l, d) l$layer_data(plot@data), layers, data, "computing layer data") - data <- by_layer(function(l, d) l$setup_layer(d, plot), layers, data, "setting up layer") + data <- by_layer( + function(l, d) l$layer_data(plot@data), + layers, + data, + "computing layer data" + ) + data <- by_layer( + function(l, d) l$setup_layer(d, plot), + layers, + data, + "setting up layer" + ) # Initialise panels, add extra data for margins & missing faceting # variables, and add on a PANEL variable to data @@ -62,7 +72,12 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { data <- layout$setup(data, plot@data, plot@plot_env) # Compute aesthetics to produce data with generalised variable names - data <- by_layer(function(l, d) l$compute_aesthetics(d, plot), layers, data, "computing aesthetics") + data <- by_layer( + function(l, d) l$compute_aesthetics(d, plot), + layers, + data, + "computing aesthetics" + ) plot@labels <- setup_plot_labels(plot, layers, data) data <- .ignore_data(data) @@ -79,17 +94,37 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { data <- .expose_data(data) # Apply and map statistics - data <- by_layer(function(l, d) l$compute_statistic(d, layout), layers, data, "computing stat") - data <- by_layer(function(l, d) l$map_statistic(d, plot), layers, data, "mapping stat to aesthetics") + data <- by_layer( + function(l, d) l$compute_statistic(d, layout), + layers, + data, + "computing stat" + ) + data <- by_layer( + function(l, d) l$map_statistic(d, plot), + layers, + data, + "mapping stat to aesthetics" + ) # Make sure missing (but required) aesthetics are added plot@scales$add_missing(c("x", "y"), plot@plot_env) # Reparameterise geoms from (e.g.) y and width to ymin and ymax - data <- by_layer(function(l, d) l$compute_geom_1(d), layers, data, "setting up geom") + data <- by_layer( + function(l, d) l$compute_geom_1(d), + layers, + data, + "setting up geom" + ) # Apply position adjustments - data <- by_layer(function(l, d) l$compute_position(d, layout), layers, data, "computing position") + data <- by_layer( + function(l, d) l$compute_position(d, layout), + layers, + data, + "computing position" + ) # Reset position scales, then re-train and map. This ensures that facets # have control over the range of a plot: is it generated from what is @@ -111,7 +146,13 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { if (npscales$n() > 0) { npscales$set_palettes(plot@theme) lapply(data, npscales$train_df) - plot@guides <- plot@guides$build(npscales, plot@layers, plot@labels, data, plot@theme) + plot@guides <- plot@guides$build( + npscales, + plot@layers, + plot@labels, + data, + plot@theme + ) data <- lapply(data, npscales$map_df) } else { # Only keep custom guides if there are no non-position scales @@ -122,11 +163,18 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { # Fill in defaults etc. data <- by_layer( function(l, d) l$compute_geom_2(d, theme = plot@theme), - layers, data, "setting up geom aesthetics" + layers, + data, + "setting up geom aesthetics" ) # Let layer stat have a final say before rendering - data <- by_layer(function(l, d) l$finish_statistics(d), layers, data, "finishing layer stat") + data <- by_layer( + function(l, d) l$finish_statistics(d), + layers, + data, + "finishing layer stat" + ) # Let Layout modify data before rendering data <- layout$finish_data(data) @@ -135,7 +183,10 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) { plot@labels$alt <- get_alt_text(plot) build <- class_ggplot_built(data = data, layout = layout, plot = plot) - class(build) <- union(c("ggplot2::ggplot_built", "ggplot_built"), class(build)) + class(build) <- union( + c("ggplot2::ggplot_built", "ggplot_built"), + class(build) + ) build } @@ -211,7 +262,12 @@ S7::method(ggplot_gtable, class_ggplot_built) <- function(data) { data <- data@data theme <- plot@theme - geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot@layers, data, "converting geom to grob") + geom_grobs <- by_layer( + function(l, d) l$draw_geom(d, layout), + plot@layers, + data, + "converting geom to grob" + ) plot_table <- layout$render(geom_grobs, data, theme, plot@labels) @@ -221,22 +277,31 @@ S7::method(ggplot_gtable, class_ggplot_built) <- function(data) { # Title title <- element_render( - theme, "plot.title", plot@labels$title, - margin_y = TRUE, margin_x = TRUE + theme, + "plot.title", + plot@labels$title, + margin_y = TRUE, + margin_x = TRUE ) title_height <- grobHeight(title) # Subtitle subtitle <- element_render( - theme, "plot.subtitle", plot@labels$subtitle, - margin_y = TRUE, margin_x = TRUE + theme, + "plot.subtitle", + plot@labels$subtitle, + margin_y = TRUE, + margin_x = TRUE ) subtitle_height <- grobHeight(subtitle) # whole plot annotation caption <- element_render( - theme, "plot.caption", plot@labels$caption, - margin_y = TRUE, margin_x = TRUE + theme, + "plot.caption", + plot@labels$caption, + margin_y = TRUE, + margin_x = TRUE ) caption_height <- grobHeight(caption) @@ -258,7 +323,11 @@ S7::method(ggplot_gtable, class_ggplot_built) <- function(data) { error_call = expr(theme()) ) - pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE] + pans <- plot_table$layout[ + grepl("^panel", plot_table$layout$name), + , + drop = FALSE + ] if (title_pos == "panel") { title_l <- min(pans$l) title_r <- max(pans$r) @@ -275,29 +344,65 @@ S7::method(ggplot_gtable, class_ggplot_built) <- function(data) { } plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0) - plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle", - t = 1, b = 1, l = title_l, r = title_r, clip = "off") + plot_table <- gtable_add_grob( + plot_table, + subtitle, + name = "subtitle", + t = 1, + b = 1, + l = title_l, + r = title_r, + clip = "off" + ) plot_table <- gtable_add_rows(plot_table, title_height, pos = 0) - plot_table <- gtable_add_grob(plot_table, title, name = "title", - t = 1, b = 1, l = title_l, r = title_r, clip = "off") + plot_table <- gtable_add_grob( + plot_table, + title, + name = "title", + t = 1, + b = 1, + l = title_l, + r = title_r, + clip = "off" + ) plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1) - plot_table <- gtable_add_grob(plot_table, caption, name = "caption", - t = -1, b = -1, l = caption_l, r = caption_r, clip = "off") + plot_table <- gtable_add_grob( + plot_table, + caption, + name = "caption", + t = -1, + b = -1, + l = caption_l, + r = caption_r, + clip = "off" + ) plot_table <- table_add_tag(plot_table, plot@labels$tag, theme) # Margins plot_margin <- calc_element("plot.margin", theme) %||% margin() - plot_table <- gtable_add_padding(plot_table, plot_margin) + plot_table <- gtable_add_padding(plot_table, plot_margin) if (is_theme_element(theme$plot.background)) { - plot_table <- gtable_add_grob(plot_table, + plot_table <- gtable_add_grob( + plot_table, element_render(theme, "plot.background"), - t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf) - plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),] - plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))] + t = 1, + l = 1, + b = -1, + r = -1, + name = "background", + z = -Inf + ) + plot_table$layout <- plot_table$layout[ + c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)), + ] + plot_table$grobs <- plot_table$grobs[c( + nrow(plot_table$layout), + 1:(nrow(plot_table$layout) - 1) + )] } # add alt-text as attribute @@ -327,9 +432,11 @@ by_layer <- function(f, layers, data, step = NULL) { out[[i]] <- f(l = layers[[i]], d = data[[i]]) }, error = function(cnd) { - cli::cli_abort(c( - "Problem while {step}.", - "i" = "Error occurred in the {ordinal(i)} layer."), + cli::cli_abort( + c( + "Problem while {step}.", + "i" = "Error occurred in the {ordinal(i)} layer." + ), call = layers[[i]]$constructor, parent = cnd ) @@ -359,14 +466,18 @@ table_add_tag <- function(table, label, theme) { if (is.numeric(position)) { if (location == "margin") { - cli::cli_abort(paste0( - "A {.cls numeric} {.arg plot.tag.position} cannot be used with ", - "`{.val margin}` as {.arg plot.tag.location}." - ), - call = expr(theme())) + cli::cli_abort( + paste0( + "A {.cls numeric} {.arg plot.tag.position} cannot be used with ", + "`{.val margin}` as {.arg plot.tag.location}." + ), + call = expr(theme()) + ) } check_length( - position, 2L, call = expr(theme()), + position, + 2L, + call = expr(theme()), arg = I("A {.cls numeric} {.arg plot.tag.position}") ) top <- left <- right <- bottom <- FALSE @@ -374,21 +485,29 @@ table_add_tag <- function(table, label, theme) { # Break position into top/left/right/bottom position <- arg_match0( position[1], - c("topleft", "top", "topright", "left", - "right", "bottomleft", "bottom", "bottomright"), + c( + "topleft", + "top", + "topright", + "left", + "right", + "bottomleft", + "bottom", + "bottomright" + ), arg_nm = "plot.tag.position", error_call = expr(theme()) ) - top <- position %in% c("topleft", "top", "topright") - left <- position %in% c("topleft", "left", "bottomleft") - right <- position %in% c("topright", "right", "bottomright") + top <- position %in% c("topleft", "top", "topright") + left <- position %in% c("topleft", "left", "bottomleft") + right <- position %in% c("topright", "right", "bottomright") bottom <- position %in% c("bottomleft", "bottom", "bottomright") } # Resolve tag and sizes tag <- element_grob(element, label = label, margin_y = TRUE, margin_x = TRUE) height <- grobHeight(tag) - width <- grobWidth(tag) + width <- grobWidth(tag) if (location %in% c("plot", "panel")) { if (!is.numeric(position)) { @@ -416,13 +535,23 @@ table_add_tag <- function(table, label, theme) { } # Re-render with manual positions tag <- element_grob( - element, x = x, y = y, label = label, - margin_y = TRUE, margin_x = TRUE + element, + x = x, + y = y, + label = label, + margin_y = TRUE, + margin_x = TRUE ) if (location == "plot") { table <- gtable_add_grob( - table, tag, name = "tag", clip = "off", - t = 1, b = nrow(table), l = 1, r = ncol(table) + table, + tag, + name = "tag", + clip = "off", + t = 1, + b = nrow(table), + l = 1, + r = ncol(table) ) return(table) } @@ -434,28 +563,49 @@ table_add_tag <- function(table, label, theme) { n_col <- ncol(table) n_row <- nrow(table) # Actually fill margin with relevant units - if (top) table$heights <- unit.c(height, table$heights[-1]) - if (left) table$widths <- unit.c(width, table$widths[-1]) - if (right) table$widths <- unit.c(table$widths[-n_col], width) - if (bottom) table$heights <- unit.c(table$heights[-n_row], height) + if (top) { + table$heights <- unit.c(height, table$heights[-1]) + } + if (left) { + table$widths <- unit.c(width, table$widths[-1]) + } + if (right) { + table$widths <- unit.c(table$widths[-n_col], width) + } + if (bottom) { + table$heights <- unit.c(table$heights[-n_row], height) + } place <- data_frame0(t = 1L, r = n_col, b = n_row, l = 1L) } # Shrink placement to position - if (top) place$b <- place$t - if (left) place$r <- place$l - if (right) place$l <- place$r - if (bottom) place$t <- place$b + if (top) { + place$b <- place$t + } + if (left) { + place$r <- place$l + } + if (right) { + place$l <- place$r + } + if (bottom) { + place$t <- place$b + } gtable_add_grob( - table, tag, name = "tag", clip = "off", - t = place$t, l = place$l, b = place$b, r = place$r + table, + tag, + name = "tag", + clip = "off", + t = place$t, + l = place$l, + b = place$b, + r = place$r ) } # Add the legends to the gtable table_add_legends <- function(table, legends, theme) { - if (is_zero(legends)) { legends <- rep(list(zeroGrob()), 5) names(legends) <- c(.trbl, "inside") @@ -468,12 +618,12 @@ table_add_legends <- function(table, legends, theme) { ) empty <- vapply(legends, is_zero, logical(1)) - widths[!empty] <- lapply(legends[!empty], gtable_width) + widths[!empty] <- lapply(legends[!empty], gtable_width) heights[!empty] <- lapply(legends[!empty], gtable_height) spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, "cm") # If legend is missing, set spacing to zero for that legend - zero <- unit(0, "pt") + zero <- unit(0, "pt") spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing) location <- switch( @@ -486,19 +636,29 @@ table_add_legends <- function(table, legends, theme) { # Add right legend table <- gtable_add_cols(table, spacing$right, pos = -1) - table <- gtable_add_cols(table, widths$right, pos = -1) + table <- gtable_add_cols(table, widths$right, pos = -1) table <- gtable_add_grob( - table, legends$right, clip = "off", - t = place$t, b = place$b, l = -1, r = -1, + table, + legends$right, + clip = "off", + t = place$t, + b = place$b, + l = -1, + r = -1, name = "guide-box-right" ) # Add left legend table <- gtable_add_cols(table, spacing$left, pos = 0) - table <- gtable_add_cols(table, widths$left, pos = 0) + table <- gtable_add_cols(table, widths$left, pos = 0) table <- gtable_add_grob( - table, legends$left, clip = "off", - t = place$t, b = place$b, l = 1, r = 1, + table, + legends$left, + clip = "off", + t = place$t, + b = place$b, + l = 1, + r = 1, name = "guide-box-left" ) @@ -508,8 +668,13 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$bottom, pos = -1) table <- gtable_add_rows(table, heights$bottom, pos = -1) table <- gtable_add_grob( - table, legends$bottom, clip = "off", - t = -1, b = -1, l = place$l, r = place$r, + table, + legends$bottom, + clip = "off", + t = -1, + b = -1, + l = place$l, + r = place$r, name = "guide-box-bottom" ) @@ -517,16 +682,26 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$top, pos = 0) table <- gtable_add_rows(table, heights$top, pos = 0) table <- gtable_add_grob( - table, legends$top, clip = "off", - t = 1, b = 1, l = place$l, r = place$r, + table, + legends$top, + clip = "off", + t = 1, + b = 1, + l = place$l, + r = place$r, name = "guide-box-top" ) # Add manual legend place <- find_panel(table) table <- gtable_add_grob( - table, legends$inside, clip = "off", - t = place$t, b = place$b, l = place$l, r = place$r, + table, + legends$inside, + clip = "off", + t = place$t, + b = place$b, + l = place$l, + r = place$r, name = "guide-box-inside" ) diff --git a/R/plot-construction.R b/R/plot-construction.R index 188e5cc574..069a3cc3a2 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -42,7 +42,7 @@ add_gg <- function(e1, e2) { if (missing(e2)) { cli::cli_abort(c( - "Cannot use {.code +} with a single argument.", + "Cannot use {.code +} with a single argument.", "i" = "Did you accidentally put {.code +} on a new line?" )) } @@ -51,10 +51,12 @@ add_gg <- function(e1, e2) { # can be displayed in error messages e2name <- deparse(substitute(e2)) - if (is_theme(e1)) add_theme(e1, e2, e2name) - # The `add_ggplot()` branch here is for backward compatibility with R < 4.3.0 - else if (is_ggplot(e1)) add_ggplot(e1, e2, e2name) - else if (is_ggproto(e1)) { + if (is_theme(e1)) { + add_theme(e1, e2, e2name) + } else if (is_ggplot(e1)) { + # The `add_ggplot()` branch here is for backward compatibility with R < 4.3.0 + add_ggplot(e1, e2, e2name) + } else if (is_ggproto(e1)) { cli::cli_abort(c( "Cannot add {.cls ggproto} objects together.", "i" = "Did you forget to add this object to a {.cls ggplot} object?" @@ -87,7 +89,9 @@ S7::method(`+`, list(class_theme, S7::class_any)) <- function(e1, e2) { } add_ggplot <- function(p, object, objectname) { - if (is.null(object)) return(p) + if (is.null(object)) { + return(p) + } p <- plot_clone(p) p <- ggplot_add(object, p, objectname) @@ -134,7 +138,6 @@ update_ggplot <- S7::new_generic("update_ggplot", c("object", "plot")) S7::method(update_ggplot, list(S7::class_any, class_ggplot)) <- function(object, plot, object_name, ...) { - if (!S7::S7_inherits(object) && inherits(object, "theme")) { # This is a contingency for patchwork/#438 if (length(object) == 0) { @@ -164,10 +167,14 @@ S7::method(update_ggplot, list(S7::class_function, class_ggplot)) <- } S7::method(update_ggplot, list(NULL, class_ggplot)) <- - function(object, plot, ...) { plot } + function(object, plot, ...) { + plot + } S7::method(update_ggplot, list(S7::class_data.frame, class_ggplot)) <- - function(object, plot, ...) { S7::set_props(plot, data = object) } + function(object, plot, ...) { + S7::set_props(plot, data = object) + } S7::method(update_ggplot, list(class_scale, class_ggplot)) <- function(object, plot, ...) { @@ -176,7 +183,9 @@ S7::method(update_ggplot, list(class_scale, class_ggplot)) <- } S7::method(update_ggplot, list(class_labels, class_ggplot)) <- - function(object, plot, ...) { update_labels(plot, object) } + function(object, plot, ...) { + update_labels(plot, object) + } S7::method(update_ggplot, list(class_guides, class_ggplot)) <- function(object, plot, ...) { @@ -209,7 +218,9 @@ S7::method(update_ggplot, list(class_coord, class_ggplot)) <- } S7::method(update_ggplot, list(class_facet, class_ggplot)) <- - function(object, plot, ...) { S7::set_props(plot, facet = object) } + function(object, plot, ...) { + S7::set_props(plot, facet = object) + } S7::method(update_ggplot, list(class_layer, class_ggplot)) <- function(object, plot, ...) { @@ -246,7 +257,6 @@ ggplot_add.default <- function(object, plot, ...) { } new_layer_names <- function(layer, existing) { - empty <- !nzchar(existing) if (any(empty)) { existing[empty] <- "unknown" diff --git a/R/plot.R b/R/plot.R index 1b84a1e1b2..fccf328ac3 100644 --- a/R/plot.R +++ b/R/plot.R @@ -115,35 +115,34 @@ ggplot <- function( #' @export ggplot.default <- function(data, mapping = aes(), ..., environment = parent.frame()) { + if (!missing(mapping)) { + mapping <- validate_mapping(mapping) + } + if (missing(data)) { + data <- NULL + } - if (!missing(mapping)) { - mapping <- validate_mapping(mapping) - } - if (missing(data)) { - data <- NULL - } - - data <- fortify(data, ...) + data <- fortify(data, ...) - p <- class_ggplot( - data = data, - mapping = mapping, - plot_env = environment - ) - class(p) <- union(union(c("ggplot2::ggplot", "ggplot"), class(p)), "gg") + p <- class_ggplot( + data = data, + mapping = mapping, + plot_env = environment + ) + class(p) <- union(union(c("ggplot2::ggplot", "ggplot"), class(p)), "gg") - set_last_plot(p) - p -} + set_last_plot(p) + p + } #' @export ggplot.function <- function(data, ...) { - # Added to avoid functions end in ggplot.default - cli::cli_abort(c( - "{.arg data} cannot be a function.", - "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}?" - )) - } + # Added to avoid functions end in ggplot.default + cli::cli_abort(c( + "{.arg data} cannot be a function.", + "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}?" + )) +} plot_clone <- function(plot) { p <- plot @@ -198,7 +197,9 @@ local({ S7::method(print, class_ggplot) <- S7::method(plot, class_ggplot) <- function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) - if (newpage) grid.newpage() + if (newpage) { + grid.newpage() + } # Record dependency on 'ggplot2' on the display list # (AFTER grid.newpage()) @@ -214,7 +215,11 @@ local({ if (is.null(vp)) { grid.draw(gtable) } else { - if (is.character(vp)) seekViewport(vp) else pushViewport(vp) + if (is.character(vp)) { + seekViewport(vp) + } else { + pushViewport(vp) + } grid.draw(gtable) upViewport() } diff --git a/R/position-.R b/R/position-.R index 845b095862..d044530a49 100644 --- a/R/position-.R +++ b/R/position-.R @@ -101,13 +101,15 @@ Position <- ggproto( #' #' A data frame with completed layer data use_defaults = function(self, data, params = list()) { - aes <- self$aesthetics() defaults <- self$default_aes params <- params[intersect(names(params), aes)] params <- params[setdiff(names(params), names(data))] - defaults <- defaults[setdiff(names(defaults), c(names(params), names(data)))] + defaults <- defaults[setdiff( + names(defaults), + c(names(params), names(data)) + )] if ((length(params) + length(defaults)) < 1) { return(data) @@ -119,7 +121,6 @@ Position <- ggproto( data[names(new)] <- new data - }, #' @field setup_params @@ -194,7 +195,9 @@ Position <- ggproto( #' A data frame with layer data compute_layer = function(self, data, params, layout) { dapply(data, "PANEL", function(data) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } scales <- layout$get_scales(data$PANEL[1]) self$compute_panel(data = data, params = params, scales = scales) diff --git a/R/position-collide.R b/R/position-collide.R index 402f6ad7eb..1e5d237278 100644 --- a/R/position-collide.R +++ b/R/position-collide.R @@ -1,7 +1,13 @@ # Detect and prevent collisions. # Powers dodging, stacking and filling. -collide_setup <- function(data, width = NULL, name, strategy, - check.width = TRUE, reverse = FALSE) { +collide_setup <- function( + data, + width = NULL, + name, + strategy, + check.width = TRUE, + reverse = FALSE +) { # Determine width if (!is.null(width)) { # Width set manually @@ -19,18 +25,25 @@ collide_setup <- function(data, width = NULL, name, strategy, widths <- unique0(data$xmax - data$xmin) widths <- widths[!is.na(widths)] -# # Suppress warning message since it's not reliable -# if (!zero_range(range(widths))) { -# warn(name, " requires constant width: output may be incorrect") -# } + # # Suppress warning message since it's not reliable + # if (!zero_range(range(widths))) { + # warn(name, " requires constant width: output may be incorrect") + # } width <- widths[1] } list(data = data, width = width) } -collide <- function(data, width = NULL, name, strategy, - ..., check.width = TRUE, reverse = FALSE) { +collide <- function( + data, + width = NULL, + name, + strategy, + ..., + check.width = TRUE, + reverse = FALSE +) { dlist <- collide_setup(data, width, name, strategy, check.width, reverse) data <- dlist$data width <- dlist$width @@ -67,8 +80,15 @@ collide <- function(data, width = NULL, name, strategy, } # Alternate version of collide() used by position_dodge2() -collide2 <- function(data, width = NULL, name, strategy, - ..., check.width = TRUE, reverse = FALSE) { +collide2 <- function( + data, + width = NULL, + name, + strategy, + ..., + check.width = TRUE, + reverse = FALSE +) { dlist <- collide_setup(data, width, name, strategy, check.width, reverse) data <- dlist$data width <- dlist$width diff --git a/R/position-dodge.R b/R/position-dodge.R index 9382bb2815..6ef0a62e7f 100644 --- a/R/position-dodge.R +++ b/R/position-dodge.R @@ -86,10 +86,16 @@ #' #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + #' geom_bar(position = position_dodge2(preserve = "total")) -position_dodge <- function(width = NULL, preserve = "total", orientation = "x", - reverse = FALSE) { +position_dodge <- function( + width = NULL, + preserve = "total", + orientation = "x", + reverse = FALSE +) { check_bool(reverse) - ggproto(NULL, PositionDodge, + ggproto( + NULL, + PositionDodge, width = width, preserve = arg_match0(preserve, c("total", "single")), orientation = arg_match0(orientation, c("x", "y")), @@ -101,7 +107,9 @@ position_dodge <- function(width = NULL, preserve = "total", orientation = "x", #' @format NULL #' @usage NULL #' @export -PositionDodge <- ggproto("PositionDodge", Position, +PositionDodge <- ggproto( + "PositionDodge", + Position, width = NULL, preserve = "total", orientation = "x", @@ -109,11 +117,11 @@ PositionDodge <- ggproto("PositionDodge", Position, default_aes = aes(order = NULL), setup_params = function(self, data) { - flipped_aes <- has_flipped_aes(data, default = self$orientation == "y") check_required_aesthetics( if (flipped_aes) "y|ymin" else "x|xmin", - names(data), snake_class(self) + names(data), + snake_class(self) ) data <- flip_data(data, flipped_aes) @@ -149,15 +157,18 @@ PositionDodge <- ggproto("PositionDodge", Position, data$x <- (data$xmin + data$xmax) / 2 } - data$order <- xtfrm( # xtfrm makes anything 'sortable' + data$order <- xtfrm( + # xtfrm makes anything 'sortable' data$order %||% ave(data$group, data$x, data$PANEL, FUN = match_sorted) ) if (isTRUE(params$reverse)) { data$order <- -data$order } - if (is.null(params$n)) { # preserve = "total" + if (is.null(params$n)) { + # preserve = "total" data$order <- ave(data$order, data$x, data$PANEL, FUN = match_sorted) - } else { # preserve = "single" + } else { + # preserve = "single" data$order <- match_sorted(data$order) } flip_data(data, params$flipped_aes) @@ -185,8 +196,9 @@ pos_dodge <- function(df, width, n = NULL) { n <- vec_unique_count(df$group) } - if (n == 1) + if (n == 1) { return(df) + } if (!all(c("xmin", "xmax") %in% names(df))) { df$xmin <- df$x diff --git a/R/position-dodge2.R b/R/position-dodge2.R index 168bc6c287..df768b9b41 100644 --- a/R/position-dodge2.R +++ b/R/position-dodge2.R @@ -2,9 +2,15 @@ #' @rdname position_dodge #' @param padding Padding between elements at the same position. Elements are #' shrunk by this proportion to allow space between them. Defaults to 0.1. -position_dodge2 <- function(width = NULL, preserve = "total", - padding = 0.1, reverse = FALSE) { - ggproto(NULL, PositionDodge2, +position_dodge2 <- function( + width = NULL, + preserve = "total", + padding = 0.1, + reverse = FALSE +) { + ggproto( + NULL, + PositionDodge2, width = width, preserve = arg_match0(preserve, c("total", "single")), padding = padding, @@ -16,7 +22,9 @@ position_dodge2 <- function(width = NULL, preserve = "total", #' @format NULL #' @usage NULL #' @export -PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, +PositionDodge2 <- ggproto( + "PositionDodge2", + PositionDodge, preserve = "total", padding = 0.1, reverse = FALSE, @@ -25,7 +33,9 @@ PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { - cli::cli_warn("Width not defined. Set with {.code position_dodge2(width = ...)}") + cli::cli_warn( + "Width not defined. Set with {.code position_dodge2(width = ...)}" + ) } if (identical(self$preserve, "total")) { @@ -132,12 +142,11 @@ pos_dodge2 <- function(df, width, n = NULL, padding = 0.1) { # Find groups of overlapping elements that need to be dodged from one another find_x_overlaps <- function(df) { - - start <- df$xmin + start <- df$xmin nonzero <- df$xmax != df$xmin missing <- is.na(df$xmin) | is.na(df$xmax) - start <- vec_fill_missing(start, "downup") - end <- vec_fill_missing(df$xmax, "downup") + start <- vec_fill_missing(start, "downup") + end <- vec_fill_missing(df$xmax, "downup") # For end we take largest end seen so far of previous observation end <- cummax(c(end[1], end[-nrow(df)])) diff --git a/R/position-identity.R b/R/position-identity.R index baa50ee113..3a581ee8c8 100644 --- a/R/position-identity.R +++ b/R/position-identity.R @@ -10,7 +10,9 @@ position_identity <- function() { #' @format NULL #' @usage NULL #' @export -PositionIdentity <- ggproto("PositionIdentity", Position, +PositionIdentity <- ggproto( + "PositionIdentity", + Position, compute_layer = function(self, data, params, layout) { data } diff --git a/R/position-jitter.R b/R/position-jitter.R index e4b98e175c..cbe42fb557 100644 --- a/R/position-jitter.R +++ b/R/position-jitter.R @@ -46,18 +46,16 @@ #' geom_point(position = jitter) + #' geom_point(position = jitter, color = "red", aes(am + 0.2, vs + 0.2)) position_jitter <- function(width = NULL, height = NULL, seed = NA) { - ggproto(NULL, PositionJitter, - width = width, - height = height, - seed = seed - ) + ggproto(NULL, PositionJitter, width = width, height = height, seed = seed) } #' @rdname Position #' @format NULL #' @usage NULL #' @export -PositionJitter <- ggproto("PositionJitter", Position, +PositionJitter <- ggproto( + "PositionJitter", + Position, seed = NA, required_aes = c("x", "y"), @@ -80,11 +78,10 @@ PositionJitter <- ggproto("PositionJitter", Position, ) compute_jitter <- function(data, width = NULL, height = NULL, seed = NA) { - - width <- width %||% (resolution(data$x, zero = FALSE, TRUE) * 0.4) + width <- width %||% (resolution(data$x, zero = FALSE, TRUE) * 0.4) height <- height %||% (resolution(data$y, zero = FALSE, TRUE) * 0.4) - trans_x <- if (width > 0) function(x) jitter(x, amount = width) + trans_x <- if (width > 0) function(x) jitter(x, amount = width) trans_y <- if (height > 0) function(x) jitter(x, amount = height) x_aes <- intersect(ggplot_global$x_aes, names(data)) diff --git a/R/position-jitterdodge.R b/R/position-jitterdodge.R index 35fed2cd72..9ba6d6e961 100644 --- a/R/position-jitterdodge.R +++ b/R/position-jitterdodge.R @@ -19,15 +19,21 @@ #' ggplot(dsub, aes(x = cut, y = carat, fill = clarity)) + #' geom_boxplot(outlier.size = 0) + #' geom_point(pch = 21, position = position_jitterdodge()) -position_jitterdodge <- function(jitter.width = NULL, jitter.height = 0, - dodge.width = 0.75, reverse = FALSE, - seed = NA) { +position_jitterdodge <- function( + jitter.width = NULL, + jitter.height = 0, + dodge.width = 0.75, + reverse = FALSE, + seed = NA +) { if (!is.null(seed) && is.na(seed)) { seed <- sample.int(.Machine$integer.max, 1L) } check_bool(reverse) - ggproto(NULL, PositionJitterdodge, + ggproto( + NULL, + PositionJitterdodge, jitter.width = jitter.width, jitter.height = jitter.height, dodge.width = dodge.width, @@ -40,7 +46,9 @@ position_jitterdodge <- function(jitter.width = NULL, jitter.height = 0, #' @format NULL #' @usage NULL #' @export -PositionJitterdodge <- ggproto("PositionJitterdodge", Position, +PositionJitterdodge <- ggproto( + "PositionJitterdodge", + Position, jitter.width = NULL, jitter.height = NULL, dodge.width = NULL, @@ -51,7 +59,8 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, setup_params = function(self, data) { flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) - width <- self$jitter.width %||% (resolution(data$x, zero = FALSE, TRUE) * 0.4) + width <- self$jitter.width %||% + (resolution(data$x, zero = FALSE, TRUE) * 0.4) ndodge <- vec_unique(data[c("group", "PANEL", "x")]) ndodge <- vec_group_id(ndodge[c("PANEL", "x")]) @@ -77,7 +86,12 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, check.width = FALSE, reverse = !params$reverse # for consistency with `position_dodge2()` ) - data <- compute_jitter(data, params$jitter.width, params$jitter.height, params$seed) + data <- compute_jitter( + data, + params$jitter.width, + params$jitter.height, + params$seed + ) flip_data(data, params$flipped_aes) } ) diff --git a/R/position-nudge.R b/R/position-nudge.R index c70c31f3ee..db2fab63ff 100644 --- a/R/position-nudge.R +++ b/R/position-nudge.R @@ -33,17 +33,16 @@ #' geom_point() + #' geom_text(aes(label = y, nudge_y = c(-0.1, 0.1, -0.1, 0.1))) position_nudge <- function(x = NULL, y = NULL) { - ggproto(NULL, PositionNudge, - x = x, - y = y - ) + ggproto(NULL, PositionNudge, x = x, y = y) } #' @rdname Position #' @format NULL #' @usage NULL #' @export -PositionNudge <- ggproto("PositionNudge", Position, +PositionNudge <- ggproto( + "PositionNudge", + Position, x = NULL, y = NULL, diff --git a/R/position-stack.R b/R/position-stack.R index 50a0ef4ac7..c57688ac68 100644 --- a/R/position-stack.R +++ b/R/position-stack.R @@ -144,7 +144,9 @@ position_fill <- function(vjust = 1, reverse = FALSE) { #' @format NULL #' @usage NULL #' @export -PositionStack <- ggproto("PositionStack", Position, +PositionStack <- ggproto( + "PositionStack", + Position, type = NULL, vjust = 1, fill = FALSE, @@ -154,7 +156,7 @@ PositionStack <- ggproto("PositionStack", Position, flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) var <- self$var %||% stack_var(data) - if (!vec_duplicate_any(data$x) && !isTRUE(self$fill)) { + if (!vec_duplicate_any(data$x) && !isTRUE(self$fill)) { # We skip stacking when all data have different x positions so that # there is nothing to stack var <- NULL @@ -174,7 +176,8 @@ PositionStack <- ggproto("PositionStack", Position, return(data) } - data$ymax <- switch(params$var, + data$ymax <- switch( + params$var, y = data$y, ymax = as.numeric(ifelse(data$ymax == 0, data$ymin, data$ymax)) ) @@ -199,21 +202,31 @@ PositionStack <- ggproto("PositionStack", Position, pos <- data[!negative, , drop = FALSE] if (any(negative)) { - neg <- collide(neg, NULL, "position_stack", pos_stack, + neg <- collide( + neg, + NULL, + "position_stack", + pos_stack, vjust = params$vjust, fill = params$fill, reverse = params$reverse ) } if (!all(negative)) { - pos <- collide(pos, NULL, "position_stack", pos_stack, + pos <- collide( + pos, + NULL, + "position_stack", + pos_stack, vjust = params$vjust, fill = params$fill, reverse = params$reverse ) } - data <- vec_rbind0(neg, pos)[match(seq_len(nrow(data)), c(which(negative), which(!negative))),] + data <- vec_rbind0(neg, pos)[ + match(seq_len(nrow(data)), c(which(negative), which(!negative))), + ] flip_data(data, params$flipped_aes) } ) @@ -229,7 +242,7 @@ pos_stack <- function(df, width, vjust = 1, fill = FALSE) { heights <- heights / total } } -# We need to preserve ymin/ymax order. If ymax is lower than ymin in input, it should remain that way + # We need to preserve ymin/ymax order. If ymax is lower than ymin in input, it should remain that way if (!is.null(df$ymin) && !is.null(df$ymax)) { max_is_lower <- df$ymax < df$ymin } else { @@ -248,9 +261,7 @@ pos_stack <- function(df, width, vjust = 1, fill = FALSE) { #' @format NULL #' @usage NULL #' @export -PositionFill <- ggproto("PositionFill", PositionStack, - fill = TRUE -) +PositionFill <- ggproto("PositionFill", PositionStack, fill = TRUE) stack_var <- function(data) { if (!is.null(data$ymax)) { diff --git a/R/properties.R b/R/properties.R index 7b828161a9..e30cb4e39b 100644 --- a/R/properties.R +++ b/R/properties.R @@ -77,8 +77,8 @@ property_colour <- function( # TODO: remove numeric option for editioning class <- S7::new_union( S7::class_character, # Hex codes and colour names, e.g. #FF000 or "red" - S7::class_logical, # For allowing NA, which means 'transparent' - S7::class_numeric # For `grDevices::palette()` indexing + S7::class_logical, # For allowing NA, which means 'transparent' + S7::class_numeric # For `grDevices::palette()` indexing ) if (isTRUE(pattern)) { class <- S7::new_union(class, S7::new_S3_class("GridPattern")) @@ -98,4 +98,3 @@ property_colour <- function( default = default ) } - diff --git a/R/quick-plot.R b/R/quick-plot.R index 61e983843b..5704963a01 100644 --- a/R/quick-plot.R +++ b/R/quick-plot.R @@ -56,18 +56,34 @@ #' qplot(factor(cyl), wt, data = mtcars, geom = c("boxplot", "jitter")) #' qplot(mpg, data = mtcars, geom = "dotplot") #' } -qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, - geom = "auto", xlim = c(NA, NA), - ylim = c(NA, NA), log = "", main = NULL, - xlab = NULL, ylab = NULL, - asp = NA, stat = deprecated(), position = deprecated()) { - +qplot <- function( + x, + y, + ..., + data, + facets = NULL, + margins = FALSE, + geom = "auto", + xlim = c(NA, NA), + ylim = c(NA, NA), + log = "", + main = NULL, + xlab = NULL, + ylab = NULL, + asp = NA, + stat = deprecated(), + position = deprecated() +) { deprecate_warn0("3.4.0", "qplot()") caller_env <- parent.frame() - if (lifecycle::is_present(stat)) lifecycle::deprecate_stop("2.0.0", "qplot(stat)") - if (lifecycle::is_present(position)) lifecycle::deprecate_stop("2.0.0", "qplot(position)") + if (lifecycle::is_present(stat)) { + lifecycle::deprecate_stop("2.0.0", "qplot(stat)") + } + if (lifecycle::is_present(position)) { + lifecycle::deprecate_stop("2.0.0", "qplot(position)") + } check_character(geom) exprs <- enquos(x = x, y = y, ...) @@ -78,14 +94,16 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, is_constant <- (!names(exprs) %in% ggplot_global$all_aesthetics) | vapply(exprs, quo_is_call, logical(1), name = "I") - mapping <- class_mapping(exprs[!is_missing & !is_constant], env = parent.frame()) + mapping <- class_mapping( + exprs[!is_missing & !is_constant], + env = parent.frame() + ) consts <- exprs[is_constant] aes_names <- names(mapping) mapping <- rename_aes(mapping) - if (is.null(xlab)) { # Avoid label (#4170) if (quo_is_missing(exprs$x)) { @@ -145,7 +163,9 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, p <- p + facet_grid(rows = deparse(facets), margins = margins) } - if (!is.null(main)) p <- p + ggtitle(main) + if (!is.null(main)) { + p <- p + ggtitle(main) + } # Add geoms/statistics for (g in geom) { @@ -156,16 +176,30 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, logv <- function(var) var %in% strsplit(log, "")[[1]] - if (logv("x")) p <- p + scale_x_log10() - if (logv("y")) p <- p + scale_y_log10() + if (logv("x")) { + p <- p + scale_x_log10() + } + if (logv("y")) { + p <- p + scale_y_log10() + } - if (!is.na(asp)) p <- p + theme(aspect.ratio = asp) + if (!is.na(asp)) { + p <- p + theme(aspect.ratio = asp) + } - if (!missing(xlab)) p <- p + xlab(xlab) - if (!missing(ylab)) p <- p + ylab(ylab) + if (!missing(xlab)) { + p <- p + xlab(xlab) + } + if (!missing(ylab)) { + p <- p + ylab(ylab) + } - if (!missing(xlim) && !all(is.na(xlim))) p <- p + xlim(xlim) - if (!missing(ylim) && !all(is.na(ylim))) p <- p + ylim(ylim) + if (!missing(xlim) && !all(is.na(xlim))) { + p <- p + xlim(xlim) + } + if (!missing(ylim) && !all(is.na(ylim))) { + p <- p + ylim(ylim) + } p } diff --git a/R/reshape-add-margins.R b/R/reshape-add-margins.R index 4603268214..6fe484eef7 100644 --- a/R/reshape-add-margins.R +++ b/R/reshape-add-margins.R @@ -3,7 +3,9 @@ reshape_add_margins <- function(df, vars, margins = TRUE) { margin_vars <- reshape_margins(vars, margins) # Return data frame if no margining necessary - if (length(margin_vars) == 0) return(df) + if (length(margin_vars) == 0) { + return(df) + } # Prepare data frame for addition of margins addAll <- function(x) { @@ -26,7 +28,9 @@ reshape_add_margins <- function(df, vars, margins = TRUE) { } reshape_margins <- function(vars, margins = NULL) { - if (is.null(margins) || identical(margins, FALSE)) return(NULL) + if (is.null(margins) || identical(margins, FALSE)) { + return(NULL) + } all_vars <- unlist(vars) if (isTRUE(margins)) { @@ -37,16 +41,22 @@ reshape_margins <- function(vars, margins = NULL) { dims <- lapply(vars, intersect, margins) # Next, ensure high-level margins include lower-levels - dims <- mapply(function(vars, margin) { - lapply(margin, downto, vars) - }, vars, dims, SIMPLIFY = FALSE, USE.NAMES = FALSE) + dims <- mapply( + function(vars, margin) { + lapply(margin, downto, vars) + }, + vars, + dims, + SIMPLIFY = FALSE, + USE.NAMES = FALSE + ) # Finally, find intersections across all dimensions seq_0 <- function(x) c(0, seq_along(x)) indices <- expand.grid(lapply(dims, seq_0), KEEP.OUT.ATTRS = FALSE) # indices <- indices[rowSums(indices) > 0, ] - lapply(seq_len(nrow(indices)), function(i){ + lapply(seq_len(nrow(indices)), function(i) { unlist(mapply("[", dims, indices[i, ], SIMPLIFY = FALSE)) }) } diff --git a/R/save.R b/R/save.R index b4b1cc7226..0dbcf178e0 100644 --- a/R/save.R +++ b/R/save.R @@ -89,19 +89,33 @@ #' dev.off() #' #' } -ggsave <- function(filename, plot = get_last_plot(), - device = NULL, path = NULL, scale = 1, - width = NA, height = NA, units = c("in", "cm", "mm", "px"), - dpi = 300, limitsize = TRUE, bg = NULL, - create.dir = FALSE, - ...) { +ggsave <- function( + filename, + plot = get_last_plot(), + device = NULL, + path = NULL, + scale = 1, + width = NA, + height = NA, + units = c("in", "cm", "mm", "px"), + dpi = 300, + limitsize = TRUE, + bg = NULL, + create.dir = FALSE, + ... +) { filename <- validate_path(path, filename, create.dir) dpi <- parse_dpi(dpi) dev <- validate_device(device, filename, dpi = dpi) - dim <- plot_dim(c(width, height), scale = scale, units = units, - limitsize = limitsize, dpi = dpi) - bg <- get_plot_background(plot, bg) + dim <- plot_dim( + c(width, height), + scale = scale, + units = units, + limitsize = limitsize, + dpi = dpi + ) + bg <- get_plot_background(plot, bg) old_dev <- grDevices::dev.cur() dev(filename = filename, width = dim[1], height = dim[2], bg = bg, ...) @@ -117,14 +131,15 @@ ggsave <- function(filename, plot = get_last_plot(), invisible(filename) } -validate_path <- function(path, filename, create.dir, - call = caller_env()) { - +validate_path <- function(path, filename, create.dir, call = caller_env()) { if (length(filename) > 1 && is.character(filename)) { - cli::cli_warn(c( - "{.arg filename} must have length 1, not {length(filename)}.", - "!" = "Only the first, {.file {filename[1]}}, will be used." - ), call = call) + cli::cli_warn( + c( + "{.arg filename} must have length 1, not {length(filename)}.", + "!" = "Only the first, {.file {filename[1]}}, will be used." + ), + call = call + ) filename <- filename[1] } check_string(filename, allow_empty = FALSE, call = call) @@ -161,10 +176,13 @@ validate_path <- function(path, filename, create.dir, } } - cli::cli_abort(c( - "Cannot find directory {.path {path}}.", - i = "Please supply an existing directory or use {.code create.dir = TRUE}." - ), call = call) + cli::cli_abort( + c( + "Cannot find directory {.path {path}}.", + i = "Please supply an existing directory or use {.code create.dir = TRUE}." + ), + call = call + ) } #' Parse a DPI input from the user @@ -178,11 +196,7 @@ parse_dpi <- function(dpi, call = caller_env()) { if (is_scalar_character(dpi)) { arg_match0(dpi, c("screen", "print", "retina"), error_call = call) - switch(dpi, - screen = 72, - print = 300, - retina = 320, - ) + switch(dpi, screen = 72, print = 300, retina = 320, ) } else if (is_bare_numeric(dpi, n = 1L)) { dpi } else { @@ -190,11 +204,21 @@ parse_dpi <- function(dpi, call = caller_env()) { } } -plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in", - limitsize = TRUE, dpi = 300, call = caller_env()) { +plot_dim <- function( + dim = c(NA, NA), + scale = 1, + units = "in", + limitsize = TRUE, + dpi = 300, + call = caller_env() +) { units <- arg_match0(units, c("in", "cm", "mm", "px")) - to_inches <- function(x) x / c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units] - from_inches <- function(x) x * c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units] + to_inches <- function(x) { + x / c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units] + } + from_inches <- function(x) { + x * c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units] + } dim <- to_inches(dim) * scale @@ -227,10 +251,14 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in", } else { msg <- paste0(msg, " not pixels).") } - cli::cli_abort(c( - msg, - "i" = "If you're sure you want a plot that big, use {.code limitsize = FALSE}. - "), call = call) + cli::cli_abort( + c( + msg, + "i" = "If you're sure you want a plot that big, use {.code limitsize = FALSE}. + " + ), + call = call + ) } dim @@ -248,7 +276,12 @@ get_plot_background <- function(plot, bg = NULL, default = "transparent") { try_prop(bg, "fill") %||% "transparent" } -validate_device <- function(device, filename = NULL, dpi = 300, call = caller_env()) { +validate_device <- function( + device, + filename = NULL, + dpi = 300, + call = caller_env() +) { force(filename) force(dpi) @@ -273,8 +306,13 @@ validate_device <- function(device, filename = NULL, dpi = 300, call = caller_en } eps <- function(filename, ...) { - grDevices::postscript(file = filename, ..., onefile = FALSE, horizontal = FALSE, - paper = "special") + grDevices::postscript( + file = filename, + ..., + onefile = FALSE, + horizontal = FALSE, + paper = "special" + ) } if (requireNamespace('ragg', quietly = TRUE)) { png_dev <- absorb_grdevice_args(ragg::agg_png) @@ -286,37 +324,47 @@ validate_device <- function(device, filename = NULL, dpi = 300, call = caller_en tiff_dev <- grDevices::tiff } devices <- list( - eps = eps, - ps = eps, - tex = function(filename, ...) grDevices::pictex(file = filename, ...), - pdf = function(filename, ..., version = "1.4") grDevices::pdf(file = filename, ..., version = version), - svg = function(filename, ...) { + eps = eps, + ps = eps, + tex = function(filename, ...) grDevices::pictex(file = filename, ...), + pdf = function(filename, ..., version = "1.4") { + grDevices::pdf(file = filename, ..., version = version) + }, + svg = function(filename, ...) { check_installed("svglite", reason = "to save as SVG.") svglite::svglite(file = filename, ...) }, # win.metafile() doesn't have `bg` arg so we need to absorb it before passing `...` - emf = function(..., bg = NULL) grDevices::win.metafile(...), - wmf = function(..., bg = NULL) grDevices::win.metafile(...), - png = function(...) png_dev(..., res = dpi, units = "in"), - jpg = function(...) jpeg_dev(..., res = dpi, units = "in"), + emf = function(..., bg = NULL) grDevices::win.metafile(...), + wmf = function(..., bg = NULL) grDevices::win.metafile(...), + png = function(...) png_dev(..., res = dpi, units = "in"), + jpg = function(...) jpeg_dev(..., res = dpi, units = "in"), jpeg = function(...) jpeg_dev(..., res = dpi, units = "in"), - bmp = function(...) grDevices::bmp(..., res = dpi, units = "in"), + bmp = function(...) grDevices::bmp(..., res = dpi, units = "in"), tiff = function(...) tiff_dev(..., res = dpi, units = "in"), - tif = function(...) tiff_dev(..., res = dpi, units = "in") + tif = function(...) tiff_dev(..., res = dpi, units = "in") ) if (is.null(device)) { device <- to_lower_ascii(tools::file_ext(filename)) if (identical(device, "")) { - cli::cli_abort(c( - "Can't save to {filename}.", - i = "Either supply {.arg filename} with a file extension or supply {.arg device}."), - call = call) + cli::cli_abort( + c( + "Can't save to {filename}.", + i = "Either supply {.arg filename} with a file extension or supply {.arg device}." + ), + call = call + ) } } if (!is.character(device) || length(device) != 1) { - stop_input_type(device, "a string, function", allow_null = TRUE, call = call) + stop_input_type( + device, + "a string, function", + allow_null = TRUE, + call = call + ) } dev <- devices[[device]] @@ -331,7 +379,9 @@ S7::method(grid.draw, class_ggplot) <- function(x, recording = TRUE) print(x) absorb_grdevice_args <- function(f) { function(..., type, antialias) { if (!missing(type) || !missing(antialias)) { - cli::cli_warn("Using ragg device as default. Ignoring {.arg type} and {.arg antialias} arguments") + cli::cli_warn( + "Using ragg device as default. Ignoring {.arg type} and {.arg antialias} arguments" + ) } f(...) } diff --git a/R/scale-.R b/R/scale-.R index df2046c25e..2113a33fde 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -1,4 +1,3 @@ - #' Continuous scale constructor #' #' @export @@ -101,20 +100,37 @@ #' The `r link_book("new scales section", "extensions#sec-new-scales")` #' #' @keywords internal -continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, name = waiver(), - breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL, - labels = waiver(), limits = NULL, rescaler = rescale, - oob = censor, expand = waiver(), na.value = NA, - transform = "identity", trans = deprecated(), - guide = "legend", position = "left", - call = caller_call(), - super = ScaleContinuous) { +continuous_scale <- function( + aesthetics, + scale_name = deprecated(), + palette, + name = waiver(), + breaks = waiver(), + minor_breaks = waiver(), + n.breaks = NULL, + labels = waiver(), + limits = NULL, + rescaler = rescale, + oob = censor, + expand = waiver(), + na.value = NA, + transform = "identity", + trans = deprecated(), + guide = "legend", + position = "left", + call = caller_call(), + super = ScaleContinuous +) { call <- call %||% current_call() if (lifecycle::is_present(scale_name)) { deprecate_soft0("3.5.0", "continuous_scale(scale_name)") } if (lifecycle::is_present(trans)) { - deprecate_soft0("3.5.0", "continuous_scale(trans)", "continuous_scale(transform)") + deprecate_soft0( + "3.5.0", + "continuous_scale(trans)", + "continuous_scale(transform)" + ) transform <- trans } @@ -132,11 +148,11 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam transform <- as.transform(transform) # Convert formula to function if appropriate - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) + limits <- allow_lambda(limits) + breaks <- allow_lambda(breaks) + labels <- allow_lambda(labels) rescaler <- allow_lambda(rescaler) - oob <- allow_lambda(oob) + oob <- allow_lambda(oob) minor_breaks <- allow_lambda(minor_breaks) if (!is.null(limits) && !is.function(limits)) { @@ -147,7 +163,9 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam } check_continuous_limits(limits, call = call) - ggproto(NULL, super, + ggproto( + NULL, + super, call = call, aesthetics = aesthetics, @@ -206,13 +224,24 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam #' @seealso #' The `r link_book("new scales section", "extensions#sec-new-scales")` #' @keywords internal -discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name = waiver(), - breaks = waiver(), minor_breaks = waiver(), - labels = waiver(), limits = NULL, expand = waiver(), - na.translate = TRUE, na.value = NA, drop = TRUE, - guide = "legend", position = "left", - call = caller_call(), - super = ScaleDiscrete) { +discrete_scale <- function( + aesthetics, + scale_name = deprecated(), + palette, + name = waiver(), + breaks = waiver(), + minor_breaks = waiver(), + labels = waiver(), + limits = NULL, + expand = waiver(), + na.translate = TRUE, + na.value = NA, + drop = TRUE, + guide = "legend", + position = "left", + call = caller_call(), + super = ScaleDiscrete +) { call <- call %||% current_call() if (lifecycle::is_present(scale_name)) { deprecate_soft0("3.5.0", "discrete_scale(scale_name)") @@ -229,10 +258,13 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name minor_breaks <- allow_lambda(minor_breaks) if (!is.function(limits) && (length(limits) > 0) && !is_discrete(limits)) { - cli::cli_warn(c( - "Continuous limits supplied to discrete scale.", - "i" = "Did you mean {.code limits = factor(...)} or {.fn scale_*_continuous}?" - ), call = call) + cli::cli_warn( + c( + "Continuous limits supplied to discrete scale.", + "i" = "Did you mean {.code limits = factor(...)} or {.fn scale_*_continuous}?" + ), + call = call + ) } position <- arg_match0(position, c("left", "right", "top", "bottom")) @@ -246,7 +278,9 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name palette <- seq_len } - ggproto(NULL, super, + ggproto( + NULL, + super, call = call, aesthetics = aesthetics, @@ -296,15 +330,29 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name #' @seealso #' The `r link_book("new scales section", "extensions#sec-new-scales")` #' @keywords internal -binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = waiver(), - breaks = waiver(), labels = waiver(), limits = NULL, - rescaler = rescale, oob = squish, expand = waiver(), - na.value = NA_real_, n.breaks = NULL, nice.breaks = TRUE, - right = TRUE, transform = "identity", - trans = deprecated(), show.limits = FALSE, - guide = "bins", position = "left", - call = caller_call(), - super = ScaleBinned) { +binned_scale <- function( + aesthetics, + scale_name = deprecated(), + palette, + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + rescaler = rescale, + oob = squish, + expand = waiver(), + na.value = NA_real_, + n.breaks = NULL, + nice.breaks = TRUE, + right = TRUE, + transform = "identity", + trans = deprecated(), + show.limits = FALSE, + guide = "bins", + position = "left", + call = caller_call(), + super = ScaleBinned +) { if (lifecycle::is_present(scale_name)) { deprecate_soft0("3.5.0", "binned_scale(scale_name)") } @@ -328,11 +376,11 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = transform <- as.transform(transform) # Convert formula input to function if appropriate - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) + limits <- allow_lambda(limits) + breaks <- allow_lambda(breaks) + labels <- allow_lambda(labels) rescaler <- allow_lambda(rescaler) - oob <- allow_lambda(oob) + oob <- allow_lambda(oob) if (!is.null(limits) && !is.function(limits)) { limits <- transform$transform(limits) @@ -341,7 +389,9 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = } } - ggproto(NULL, super, + ggproto( + NULL, + super, call = call, aesthetics = aesthetics, @@ -438,7 +488,9 @@ is_scale <- function(x) inherits(x, "Scale") #' @examples #' # TODO: find easy to digest example #' NULL -Scale <- ggproto("Scale", NULL, +Scale <- ggproto( + "Scale", + NULL, ## Fields ------------------------------------------------------------------ @@ -542,7 +594,9 @@ Scale <- ggproto("Scale", NULL, #' Nothing, these are called for their side effect of updating the `range` #' field. train_df = function(self, df) { - if (empty(df)) return() + if (empty(df)) { + return() + } aesthetics <- intersect(self$aesthetics, names(df)) for (aesthetic in aesthetics) { @@ -633,7 +687,12 @@ Scale <- ggproto("Scale", NULL, #' **Value** #' #' A vector of values between 0 and 1 for in-bounds values of `x`. - rescale = function(self, x, limits = self$get_limits(), range = self$dimension()) { + rescale = function( + self, + x, + limits = self$get_limits(), + range = self$dimension() + ) { cli::cli_abort("Not implemented.", call = self$call) }, @@ -690,7 +749,11 @@ Scale <- ggproto("Scale", NULL, #' **Value** #' #' A numeric vector of length 2 - dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { + dimension = function( + self, + expand = expansion(0, 0), + limits = self$get_limits() + ) { cli::cli_abort("Not implemented.", call = self$call) }, @@ -725,7 +788,12 @@ Scale <- ggproto("Scale", NULL, cli::cli_abort("Not implemented.", call = self$call) }, - get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { + get_breaks_minor = function( + self, + n = 2, + b = self$break_positions(), + limits = self$get_limits() + ) { cli::cli_abort("Not implemented.", call = self$call) }, @@ -855,7 +923,12 @@ Scale <- ggproto("Scale", NULL, #' **Value** #' #' A scalar character or expression title - make_title = function(self, guide_title = waiver(), scale_title = waiver(), label_title = waiver()) { + make_title = function( + self, + guide_title = waiver(), + scale_title = waiver(), + label_title = waiver() + ) { title <- label_title scale_title <- allow_lambda(scale_title) if (is.function(scale_title)) { @@ -991,7 +1064,9 @@ default_transform <- function(self, x) { #' @format NULL #' @usage NULL #' @export -ScaleContinuous <- ggproto("ScaleContinuous", Scale, +ScaleContinuous <- ggproto( + "ScaleContinuous", + Scale, range = ContinuousRange$new(), na.value = NA_real_, rescaler = rescale, @@ -1013,7 +1088,8 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, is_empty = function(self) { has_data <- !is.null(self$range$range) - has_limits <- is.function(self$limits) || (!is.null(self$limits) && all(is.finite(self$limits))) + has_limits <- is.function(self$limits) || + (!is.null(self$limits) && all(is.finite(self$limits))) !has_data && !has_limits }, @@ -1047,14 +1123,20 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } else if (is.function(self$limits)) { transformation <- self$get_transformation() # if limits is a function, it expects to work in data space - transformation$transform(self$limits(transformation$inverse(self$range$range))) + transformation$transform(self$limits(transformation$inverse( + self$range$range + ))) } else { # NA limits for a continuous scale mean replace with the min/max of data ifelse(is.na(self$limits), self$range$range, self$limits) } }, - dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { + dimension = function( + self, + expand = expansion(0, 0), + limits = self$get_limits() + ) { expand_limits_scale(self, expand, limits) }, @@ -1101,7 +1183,12 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, transformation$transform(breaks) }, - get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { + get_breaks_minor = function( + self, + n = 2, + b = self$break_positions(), + limits = self$get_limits() + ) { if (zero_range(as.numeric(limits))) { return() } @@ -1137,7 +1224,10 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, if (length(arg_names) == 1L) { breaks <- break_fun(transformation$inverse(limits)) } else { - breaks <- break_fun(transformation$inverse(limits), transformation$inverse(b)) + breaks <- break_fun( + transformation$inverse(limits), + transformation$inverse(b) + ) } # Convert breaks to numeric breaks <- transformation$transform(breaks) @@ -1204,7 +1294,9 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, break_info = function(self, range = NULL) { # range - if (is.null(range)) range <- self$dimension() + if (is.null(range)) { + range <- self$dimension() + } # major breaks major <- self$get_breaks(range) @@ -1214,13 +1306,19 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, # minor breaks minor <- self$get_breaks_minor(b = major, limits = range) - if (!is.null(minor)) minor <- minor[!is.na(minor)] + if (!is.null(minor)) { + minor <- minor[!is.na(minor)] + } major <- oob_censor_any(major, range) # drop oob breaks/labels by testing major == NA - if (!is.null(labels)) labels <- labels[!is.na(major)] - if (!is.null(major)) major <- major[!is.na(major)] + if (!is.null(labels)) { + labels <- labels[!is.na(major)] + } + if (!is.null(major)) { + major <- major[!is.na(major)] + } # rescale breaks [0, 1], which are used by coord/guide major_n <- rescale(major, from = range) @@ -1255,7 +1353,9 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, #' @format NULL #' @usage NULL #' @export -ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, +ScaleDiscrete <- ggproto( + "ScaleDiscrete", + Scale, drop = TRUE, na.value = NA, n.breaks.cache = NULL, @@ -1271,9 +1371,9 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, } self$range$train( x, - drop = self$drop, + drop = self$drop, na.rm = !self$na.translate, - call = self$call + call = self$call ) }, @@ -1336,11 +1436,20 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, pal_match }, - rescale = function(self, x, limits = self$get_limits(), range = c(1, length(limits))) { + rescale = function( + self, + x, + limits = self$get_limits(), + range = c(1, length(limits)) + ) { rescale(x, match(as.character(x), limits), from = range) }, - dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { + dimension = function( + self, + expand = expansion(0, 0), + limits = self$get_limits() + ) { expand_limits_discrete(limits, expand = expand) }, @@ -1367,8 +1476,12 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, structure(in_domain, pos = match(in_domain, breaks)) }, - get_breaks_minor = function(self, n = 2, b = self$break_positions(), - limits = self$get_limits()) { + get_breaks_minor = function( + self, + n = 2, + b = self$break_positions(), + limits = self$get_limits() + ) { breaks <- self$minor_breaks # The default is to draw no minor ticks if (is.null(breaks %|W|% NULL)) { @@ -1457,7 +1570,6 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, if (is.null(major)) { labels <- major_n <- NULL } else { - labels <- self$get_labels(major) major <- self$map(major) @@ -1484,7 +1596,9 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, #' @format NULL #' @usage NULL #' @export -ScaleBinned <- ggproto("ScaleBinned", Scale, +ScaleBinned <- ggproto( + "ScaleBinned", + Scale, range = ContinuousRange$new(), na.value = NA_real_, rescaler = rescale, @@ -1525,14 +1639,16 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, breaks <- self$rescale(breaks, limits) if (length(breaks) > 1) { - x_binned <- cut(x, breaks, + x_binned <- cut( + x, + breaks, labels = FALSE, include.lowest = TRUE, right = self$right ) midpoints <- breaks[-1] - diff(breaks) / 2 } else { - x_binned <- 1L + x_binned <- 1L midpoints <- 0.5 } @@ -1561,7 +1677,9 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, }, get_breaks = function(self, limits = self$get_limits()) { - if (self$is_empty()) return(numeric()) + if (self$is_empty()) { + return(numeric()) + } transformation <- self$get_transformation() @@ -1621,8 +1739,12 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, } breaks <- new_limits } - new_limits_trans <- suppressWarnings(transformation$transform(new_limits)) - limits[is.finite(new_limits_trans)] <- new_limits[is.finite(new_limits_trans)] + new_limits_trans <- suppressWarnings(transformation$transform( + new_limits + )) + limits[is.finite(new_limits_trans)] <- new_limits[is.finite( + new_limits_trans + )] if (is_rev) { self$limits <- rev(transformation$transform(limits)) } else { @@ -1663,7 +1785,9 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, }, get_labels = function(self, breaks = self$get_breaks()) { - if (is.null(breaks)) return(NULL) + if (is.null(breaks)) { + return(NULL) + } transformation <- self$get_transformation() breaks <- transformation$inverse(breaks) @@ -1702,7 +1826,9 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, break_info = function(self, range = NULL) { # range - if (is.null(range)) range <- self$dimension() + if (is.null(range)) { + range <- self$dimension() + } # major breaks major <- self$get_breaks(range) @@ -1721,9 +1847,14 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, # labels labels <- self$get_labels(major) - list(range = range, labels = labels, - major = pal, minor = NULL, - major_source = major, minor_source = NULL) + list( + range = range, + labels = labels, + major = pal, + minor = NULL, + major_source = major, + minor_source = NULL + ) } ) @@ -1740,7 +1871,8 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { ) } - bad_labels <- is.atomic(breaks) && is.atomic(labels) && + bad_labels <- is.atomic(breaks) && + is.atomic(labels) && length(breaks) != length(labels) if (bad_labels) { cli::cli_abort( @@ -1753,7 +1885,8 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { has_default_transform <- function(scale) { transform_method <- environment(scale$transform)$f - identical(default_transform, transform_method) || identical(identity, transform_method) + identical(default_transform, transform_method) || + identical(identity, transform_method) } # In place modification of a scale to change the primary axis @@ -1762,7 +1895,13 @@ scale_flip_position <- function(scale) { invisible() } -check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) { +check_transformation <- function( + x, + transformed, + name, + arg = NULL, + call = NULL +) { if (!any(is_finite(x) != is_finite(transformed))) { return(invisible()) } @@ -1771,7 +1910,10 @@ check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) } else { end <- paste0(" in {.arg {arg}}.") } - msg <- paste0("{.field {name}} transformation introduced infinite values", end) + msg <- paste0( + "{.field {name}} transformation introduced infinite values", + end + ) cli::cli_warn(msg, call = call) } @@ -1783,9 +1925,12 @@ support_nbreaks <- function(fun) { "n" %in% fn_fmls_names(fun) } -check_continuous_limits <- function(limits, ..., - arg = caller_arg(limits), - call = caller_env()) { +check_continuous_limits <- function( + limits, + ..., + arg = caller_arg(limits), + call = caller_env() +) { if (is.null(limits) || is.function(limits)) { return(invisible()) } diff --git a/R/scale-alpha.R b/R/scale-alpha.R index c9155db9aa..78da148afb 100644 --- a/R/scale-alpha.R +++ b/R/scale-alpha.R @@ -31,7 +31,12 @@ #' #' # Changing the title #' p + scale_alpha("cylinders") -scale_alpha <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { +scale_alpha <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL continuous_scale(aesthetics, name = name, palette = palette, ...) } @@ -42,7 +47,12 @@ scale_alpha_continuous <- scale_alpha #' @rdname scale_alpha #' @export -scale_alpha_binned <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { +scale_alpha_binned <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL binned_scale(aesthetics, name = name, palette = palette, ...) } @@ -58,7 +68,12 @@ scale_alpha_discrete <- function(...) { #' @rdname scale_alpha #' @export -scale_alpha_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { +scale_alpha_ordinal <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) { palette <- if (!is.null(range)) { function(n) seq(range[1], range[2], length.out = n) } else { @@ -70,21 +85,37 @@ scale_alpha_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { +scale_alpha_datetime <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = aesthetics, transform = "time", name = name, - palette = palette, ... + aesthetics = aesthetics, + transform = "time", + name = name, + palette = palette, + ... ) } #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_date <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha"){ +scale_alpha_date <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = aesthetics, transform = "date", name = name, - palette = palette, ... + aesthetics = aesthetics, + transform = "date", + name = name, + palette = palette, + ... ) } diff --git a/R/scale-binned.R b/R/scale-binned.R index 5f9ec913e3..2cde6d1925 100644 --- a/R/scale-binned.R +++ b/R/scale-binned.R @@ -25,19 +25,41 @@ NULL #' @rdname scale_binned #' #' @export -scale_x_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, - breaks = waiver(), labels = waiver(), limits = NULL, - expand = waiver(), oob = squish, na.value = NA_real_, - right = TRUE, show.limits = FALSE, transform = "identity", - trans = deprecated(), - guide = waiver(), position = "bottom") { +scale_x_binned <- function( + name = waiver(), + n.breaks = 10, + nice.breaks = TRUE, + breaks = waiver(), + labels = waiver(), + limits = NULL, + expand = waiver(), + oob = squish, + na.value = NA_real_, + right = TRUE, + show.limits = FALSE, + transform = "identity", + trans = deprecated(), + guide = waiver(), + position = "bottom" +) { binned_scale( ggplot_global$x_aes, - palette = identity, name = name, breaks = breaks, - labels = labels, limits = limits, expand = expand, oob = oob, - na.value = na.value, n.breaks = n.breaks, nice.breaks = nice.breaks, - right = right, transform = transform, trans = trans, - show.limits = show.limits, guide = guide, position = position, + palette = identity, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + expand = expand, + oob = oob, + na.value = na.value, + n.breaks = n.breaks, + nice.breaks = nice.breaks, + right = right, + transform = transform, + trans = trans, + show.limits = show.limits, + guide = guide, + position = position, super = ScaleBinnedPosition ) } @@ -45,19 +67,42 @@ scale_x_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, #' @rdname scale_binned #' #' @export -scale_y_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, - breaks = waiver(), labels = waiver(), limits = NULL, - expand = waiver(), oob = squish, na.value = NA_real_, - right = TRUE, show.limits = FALSE, transform = "identity", - trans = deprecated(), - guide = waiver(), position = "left") { +scale_y_binned <- function( + name = waiver(), + n.breaks = 10, + nice.breaks = TRUE, + breaks = waiver(), + labels = waiver(), + limits = NULL, + expand = waiver(), + oob = squish, + na.value = NA_real_, + right = TRUE, + show.limits = FALSE, + transform = "identity", + trans = deprecated(), + guide = waiver(), + position = "left" +) { binned_scale( ggplot_global$y_aes, - palette = identity, name = name, breaks = breaks, - labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value, - n.breaks = n.breaks, nice.breaks = nice.breaks, right = right, - transform = transform, trans = trans, show.limits = show.limits, - guide = guide, position = position, super = ScaleBinnedPosition + palette = identity, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + expand = expand, + oob = oob, + na.value = na.value, + n.breaks = n.breaks, + nice.breaks = nice.breaks, + right = right, + transform = transform, + trans = trans, + show.limits = show.limits, + guide = guide, + position = position, + super = ScaleBinnedPosition ) } @@ -65,7 +110,9 @@ scale_y_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE, #' @format NULL #' @usage NULL #' @export -ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, +ScaleBinnedPosition <- ggproto( + "ScaleBinnedPosition", + ScaleBinned, after.stat = FALSE, train = function(self, x) { @@ -76,7 +123,9 @@ ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, ) } - if (length(x) == 0 || self$after.stat) return() + if (length(x) == 0 || self$after.stat) { + return() + } self$range$train(x) }, @@ -87,7 +136,9 @@ ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, if (self$after.stat) { # Backtransform to original scale - x_binned <- cut(x, seq_len(length(all_breaks) + 1) - 0.5, + x_binned <- cut( + x, + seq_len(length(all_breaks) + 1) - 0.5, labels = FALSE, include.lowest = TRUE, right = self$right @@ -96,7 +147,9 @@ ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, } else { x <- as.numeric(self$oob(x, limits)) x <- ifelse(!is.na(x), x, self$na.value) - x_binned <- cut(x, all_breaks, + x_binned <- cut( + x, + all_breaks, labels = FALSE, include.lowest = TRUE, right = self$right diff --git a/R/scale-brewer.R b/R/scale-brewer.R index af115ea13f..1805585fd2 100644 --- a/R/scale-brewer.R +++ b/R/scale-brewer.R @@ -85,10 +85,17 @@ #' # or use blender variants to discretise continuous data #' v + scale_fill_fermenter() #' -scale_colour_brewer <- function(name = waiver(), ..., type = "seq", palette = 1, - direction = 1, aesthetics = "colour") { +scale_colour_brewer <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = 1, + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_brewer(type, palette, direction), ... ) @@ -96,10 +103,17 @@ scale_colour_brewer <- function(name = waiver(), ..., type = "seq", palette = 1, #' @export #' @rdname scale_brewer -scale_fill_brewer <- function(name = waiver(), ..., type = "seq", palette = 1, - direction = 1, aesthetics = "fill") { +scale_fill_brewer <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = 1, + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_brewer(type, palette, direction), ... ) @@ -107,10 +121,18 @@ scale_fill_brewer <- function(name = waiver(), ..., type = "seq", palette = 1, #' @export #' @rdname scale_brewer -scale_colour_distiller <- function(name = waiver(), ..., type = "seq", - palette = 1, direction = -1, values = NULL, - space = "Lab", na.value = "grey50", - guide = "colourbar", aesthetics = "colour") { +scale_colour_distiller <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = -1, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour" +) { # warn about using a qualitative brewer palette to generate the gradient type <- arg_match0(type, c("seq", "div", "qual")) if (type == "qual") { @@ -120,9 +142,16 @@ scale_colour_distiller <- function(name = waiver(), ..., type = "seq", )) } continuous_scale( - aesthetics, name = name, - palette = pal_gradient_n(pal_brewer(type, palette, direction)(7), values, space), - na.value = na.value, guide = guide, ... + aesthetics, + name = name, + palette = pal_gradient_n( + pal_brewer(type, palette, direction)(7), + values, + space + ), + na.value = na.value, + guide = guide, + ... ) # NB: 6-7 colours per palette gives nice gradients; more results in more saturated colours which do not look as good # For diverging scales, you need an odd number to make sure the mid-point is in the center @@ -130,10 +159,18 @@ scale_colour_distiller <- function(name = waiver(), ..., type = "seq", #' @export #' @rdname scale_brewer -scale_fill_distiller <- function(name = waiver(), ..., type = "seq", - palette = 1, direction = -1, values = NULL, - space = "Lab", na.value = "grey50", - guide = "colourbar", aesthetics = "fill") { +scale_fill_distiller <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = -1, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill" +) { type <- arg_match0(type, c("seq", "div", "qual")) if (type == "qual") { cli::cli_warn(c( @@ -142,18 +179,31 @@ scale_fill_distiller <- function(name = waiver(), ..., type = "seq", )) } continuous_scale( - aesthetics, name = name, - palette = pal_gradient_n(pal_brewer(type, palette, direction)(7), values, space), - na.value = na.value, guide = guide, ... + aesthetics, + name = name, + palette = pal_gradient_n( + pal_brewer(type, palette, direction)(7), + values, + space + ), + na.value = na.value, + guide = guide, + ... ) } #' @export #' @rdname scale_brewer -scale_colour_fermenter <- function(name = waiver(), ..., type = "seq", - palette = 1, direction = -1, - na.value = "grey50", guide = "coloursteps", - aesthetics = "colour") { +scale_colour_fermenter <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = -1, + na.value = "grey50", + guide = "coloursteps", + aesthetics = "colour" +) { # warn about using a qualitative brewer palette to generate the gradient type <- arg_match0(type, c("seq", "div", "qual")) if (type == "qual") { @@ -163,18 +213,27 @@ scale_colour_fermenter <- function(name = waiver(), ..., type = "seq", )) } binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_binned(pal_brewer(type, palette, direction)), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } #' @export #' @rdname scale_brewer -scale_fill_fermenter <- function(name = waiver(), ..., type = "seq", palette = 1, - direction = -1, na.value = "grey50", - guide = "coloursteps", aesthetics = "fill") { +scale_fill_fermenter <- function( + name = waiver(), + ..., + type = "seq", + palette = 1, + direction = -1, + na.value = "grey50", + guide = "coloursteps", + aesthetics = "fill" +) { type <- arg_match0(type, c("seq", "div", "qual")) if (type == "qual") { cli::cli_warn(c( @@ -183,9 +242,11 @@ scale_fill_fermenter <- function(name = waiver(), ..., type = "seq", palette = 1 )) } binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_binned(pal_brewer(type, palette, direction)), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } diff --git a/R/scale-colour.R b/R/scale-colour.R index 5f9faab7df..86d2c91fa4 100644 --- a/R/scale-colour.R +++ b/R/scale-colour.R @@ -78,87 +78,132 @@ #' # Restoring the previous theme #' theme_set(old) #' @export -scale_colour_continuous <- function(..., palette = NULL, aesthetics = "colour", - guide = "colourbar", na.value = "grey50", - type = getOption("ggplot2.continuous.colour")) { - +scale_colour_continuous <- function( + ..., + palette = NULL, + aesthetics = "colour", + guide = "colourbar", + na.value = "grey50", + type = getOption("ggplot2.continuous.colour") +) { has_old_args <- any(names(enexprs(...)) %in% c("low", "high")) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., guide = guide, na.value = na.value, scale = type, - aesthetic = "colour", type = "continuous" + ..., + guide = guide, + na.value = na.value, + scale = type, + aesthetic = "colour", + type = "continuous" ) return(scale) } palette <- if (!is.null(palette)) as_continuous_pal(palette) continuous_scale( - aesthetics, palette = palette, guide = guide, na.value = na.value, + aesthetics, + palette = palette, + guide = guide, + na.value = na.value, ... ) } #' @rdname scale_colour_continuous #' @export -scale_fill_continuous <- function(..., palette = NULL, aesthetics = "fill", guide = "colourbar", - na.value = "grey50", - type = getOption("ggplot2.continuous.fill")) { - +scale_fill_continuous <- function( + ..., + palette = NULL, + aesthetics = "fill", + guide = "colourbar", + na.value = "grey50", + type = getOption("ggplot2.continuous.fill") +) { has_old_args <- any(names(enexprs(...)) %in% c("low", "high")) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., guide = guide, na.value = na.value, scale = type, - aesthetic = "fill", type = "continuous" + ..., + guide = guide, + na.value = na.value, + scale = type, + aesthetic = "fill", + type = "continuous" ) return(scale) } palette <- if (!is.null(palette)) as_continuous_pal(palette) continuous_scale( - aesthetics, palette = palette, guide = guide, na.value = na.value, + aesthetics, + palette = palette, + guide = guide, + na.value = na.value, ... ) } #' @export #' @rdname scale_colour_continuous -scale_colour_binned <- function(..., palette = NULL, aesthetics = "colour", guide = "coloursteps", - na.value = "grey50", - type = getOption("ggplot2.binned.colour")) { - +scale_colour_binned <- function( + ..., + palette = NULL, + aesthetics = "colour", + guide = "coloursteps", + na.value = "grey50", + type = getOption("ggplot2.binned.colour") +) { has_old_args <- any(names(enexprs(...)) %in% c("low", "high")) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., guide = guide, na.value = na.value, scale = type, - aesthetic = "colour", type = "binned" + ..., + guide = guide, + na.value = na.value, + scale = type, + aesthetic = "colour", + type = "binned" ) return(scale) } palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette)) binned_scale( - aesthetics, palette = palette, guide = guide, na.value = na.value, + aesthetics, + palette = palette, + guide = guide, + na.value = na.value, ... ) } #' @export #' @rdname scale_colour_continuous -scale_fill_binned <- function(..., palette = NULL, aesthetics = "fill", guide = "coloursteps", - na.value = "grey50", - type = getOption("ggplot2.binned.fill")) { +scale_fill_binned <- function( + ..., + palette = NULL, + aesthetics = "fill", + guide = "coloursteps", + na.value = "grey50", + type = getOption("ggplot2.binned.fill") +) { has_old_args <- any(names(enexprs(...)) %in% c("low", "high")) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., guide = guide, na.value = na.value, scale = type, - aesthetic = "fill", type = "binned" + ..., + guide = guide, + na.value = na.value, + scale = type, + aesthetic = "fill", + type = "binned" ) return(scale) } palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette)) binned_scale( - aesthetics, palette = palette, guide = guide, na.value = na.value, + aesthetics, + palette = palette, + guide = guide, + na.value = na.value, ... ) } @@ -211,70 +256,107 @@ scale_fill_binned <- function(..., palette = NULL, aesthetics = "fill", guide = #' #' # Restoring the previous theme #' theme_set(old) -scale_colour_discrete <- function(..., palette = NULL, aesthetics = "colour", na.value = "grey50", - type = getOption("ggplot2.discrete.colour")) { - - has_old_args <- any(names(enexprs(...)) %in% c("h", "c", "l", "h.start", "direction")) +scale_colour_discrete <- function( + ..., + palette = NULL, + aesthetics = "colour", + na.value = "grey50", + type = getOption("ggplot2.discrete.colour") +) { + has_old_args <- any( + names(enexprs(...)) %in% c("h", "c", "l", "h.start", "direction") + ) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., na.value = na.value, scale = type, - aesthetic = "colour", type = "discrete" + ..., + na.value = na.value, + scale = type, + aesthetic = "colour", + type = "discrete" ) return(scale) } palette <- if (!is.null(palette)) as_discrete_pal(palette) discrete_scale( - aesthetics, palette = palette, na.value = na.value, + aesthetics, + palette = palette, + na.value = na.value, ... ) } #' @rdname scale_colour_discrete #' @export -scale_fill_discrete <- function(..., palette = NULL, aesthetics = "fill", na.value = "grey50", - type = getOption("ggplot2.discrete.fill")) { - - has_old_args <- any(names(enexprs(...)) %in% c("h", "c", "l", "h.start", "direction")) +scale_fill_discrete <- function( + ..., + palette = NULL, + aesthetics = "fill", + na.value = "grey50", + type = getOption("ggplot2.discrete.fill") +) { + has_old_args <- any( + names(enexprs(...)) %in% c("h", "c", "l", "h.start", "direction") + ) if (has_old_args || (!is.null(type) && is.null(palette))) { scale <- scale_backward_compatibility( - ..., na.value = na.value, scale = type, - aesthetic = "fill", type = "discrete" + ..., + na.value = na.value, + scale = type, + aesthetic = "fill", + type = "discrete" ) return(scale) } palette <- if (!is.null(palette)) as_discrete_pal(palette) discrete_scale( - aesthetics, palette = palette, na.value = na.value, + aesthetics, + palette = palette, + na.value = na.value, ... ) } # helper function to make sure that the provided scale is of the correct # type (i.e., is continuous and works with the provided aesthetic) -check_scale_type <- function(scale, name, aesthetic, scale_is_discrete = FALSE, call = caller_env()) { +check_scale_type <- function( + scale, + name, + aesthetic, + scale_is_discrete = FALSE, + call = caller_env() +) { if (!is_ggproto(scale) || !is_scale(scale)) { - cli::cli_abort(c( - "The {.arg type} argument must return a continuous scale for the {.field {aesthetic}} aesthetic.", - "x" = "The provided object is not a scale function." - ), call = call) + cli::cli_abort( + c( + "The {.arg type} argument must return a continuous scale for the {.field {aesthetic}} aesthetic.", + "x" = "The provided object is not a scale function." + ), + call = call + ) } if (!isTRUE(aesthetic %in% scale$aesthetics)) { - cli::cli_abort(c( - "The {.arg type} argument must return a continuous scale for the {.field {aesthetic}} aesthetic.", - "x" = "The provided scale works with the following aesthetics: {.field {scale$aesthetics}}." - ), call = call) + cli::cli_abort( + c( + "The {.arg type} argument must return a continuous scale for the {.field {aesthetic}} aesthetic.", + "x" = "The provided scale works with the following aesthetics: {.field {scale$aesthetics}}." + ), + call = call + ) } if (isTRUE(scale$is_discrete()) != scale_is_discrete) { scale_types <- c("continuous", "discrete") if (scale_is_discrete) { scale_types <- rev(scale_types) } - cli::cli_abort(c( - "The {.arg type} argument must return a {scale_types[1]} scale for the {.field {aesthetic}} aesthetic.", - "x" = "The provided scale is {scale_types[2]}." - ), call = call) + cli::cli_abort( + c( + "The {.arg type} argument must return a {scale_types[1]} scale for the {.field {aesthetic}} aesthetic.", + "x" = "The provided scale is {scale_types[2]}." + ), + call = call + ) } invisible() } @@ -302,7 +384,12 @@ scale_backward_compatibility <- function(..., scale, aesthetic, type) { scale <- switch( scale %||% type, discrete = "hue", - viridis = switch(type, discrete = "viridis_d", binned = "viridis_b", "viridis_c"), + viridis = switch( + type, + discrete = "viridis_d", + binned = "viridis_b", + "viridis_c" + ), continuous = "gradient", scale ) @@ -322,7 +409,7 @@ scale_backward_compatibility <- function(..., scale, aesthetic, type) { scale <- switch( aesthetic, colour = scale_colour_qualitative, - fill = scale_fill_qualitative + fill = scale_fill_qualitative ) } diff --git a/R/scale-continuous.R b/R/scale-continuous.R index 8da2f94428..fc049893a9 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -79,51 +79,88 @@ NULL #' @param sec.axis [sec_axis()] is used to specify a secondary axis. #' #' @export -scale_x_continuous <- function(name = waiver(), breaks = waiver(), - minor_breaks = waiver(), n.breaks = NULL, - labels = waiver(), limits = NULL, - expand = waiver(), oob = censor, - na.value = NA_real_, transform = "identity", - trans = deprecated(), - guide = waiver(), position = "bottom", - sec.axis = waiver()) { +scale_x_continuous <- function( + name = waiver(), + breaks = waiver(), + minor_breaks = waiver(), + n.breaks = NULL, + labels = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + na.value = NA_real_, + transform = "identity", + trans = deprecated(), + guide = waiver(), + position = "bottom", + sec.axis = waiver() +) { call <- caller_call() if (scale_override_call(call)) { call <- current_call() } sc <- continuous_scale( ggplot_global$x_aes, - palette = identity, name = name, breaks = breaks, n.breaks = n.breaks, - minor_breaks = minor_breaks, labels = labels, limits = limits, - expand = expand, oob = oob, na.value = na.value, transform = transform, - trans = trans, guide = guide, position = position, call = call, + palette = identity, + name = name, + breaks = breaks, + n.breaks = n.breaks, + minor_breaks = minor_breaks, + labels = labels, + limits = limits, + expand = expand, + oob = oob, + na.value = na.value, + transform = transform, + trans = trans, + guide = guide, + position = position, + call = call, super = ScaleContinuousPosition ) set_sec_axis(sec.axis, sc) - } #' @rdname scale_continuous #' @export -scale_y_continuous <- function(name = waiver(), breaks = waiver(), - minor_breaks = waiver(), n.breaks = NULL, - labels = waiver(), limits = NULL, - expand = waiver(), oob = censor, - na.value = NA_real_, transform = "identity", - trans = deprecated(), - guide = waiver(), position = "left", - sec.axis = waiver()) { +scale_y_continuous <- function( + name = waiver(), + breaks = waiver(), + minor_breaks = waiver(), + n.breaks = NULL, + labels = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + na.value = NA_real_, + transform = "identity", + trans = deprecated(), + guide = waiver(), + position = "left", + sec.axis = waiver() +) { call <- caller_call() if (scale_override_call(call)) { call <- current_call() } sc <- continuous_scale( ggplot_global$y_aes, - palette = identity, name = name, breaks = breaks, n.breaks = n.breaks, - minor_breaks = minor_breaks, labels = labels, limits = limits, - expand = expand, oob = oob, na.value = na.value, transform = transform, - trans = trans, guide = guide, position = position, call = call, + palette = identity, + name = name, + breaks = breaks, + n.breaks = n.breaks, + minor_breaks = minor_breaks, + labels = labels, + limits = limits, + expand = expand, + oob = oob, + na.value = na.value, + transform = transform, + trans = trans, + guide = guide, + position = position, + call = call, super = ScaleContinuousPosition ) @@ -135,7 +172,9 @@ scale_y_continuous <- function(name = waiver(), breaks = waiver(), #' @format NULL #' @usage NULL #' @export -ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous, +ScaleContinuousPosition <- ggproto( + "ScaleContinuousPosition", + ScaleContinuous, secondary.axis = waiver(), # Position aesthetics don't map, because the coordinate system takes # care of it. But they do need to be made in to doubles, so stat methods @@ -212,4 +251,3 @@ scale_override_call <- function(call = NULL) { } !any(startsWith(as.character(call[[1]]), "scale_")) } - diff --git a/R/scale-date.R b/R/scale-date.R index 3e3eda8a0e..4e11136d7d 100644 --- a/R/scale-date.R +++ b/R/scale-date.R @@ -66,20 +66,21 @@ NULL #' @rdname scale_date #' @export -scale_x_date <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - limits = NULL, - expand = waiver(), - oob = censor, - guide = waiver(), - position = "bottom", - sec.axis = waiver()) { - +scale_x_date <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + guide = waiver(), + position = "bottom", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$x_aes, "date", @@ -103,20 +104,21 @@ scale_x_date <- function(name = waiver(), #' @rdname scale_date #' @export -scale_y_date <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - limits = NULL, - expand = waiver(), - oob = censor, - guide = waiver(), - position = "left", - sec.axis = waiver()) { - +scale_y_date <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + guide = waiver(), + position = "left", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$y_aes, "date", @@ -140,21 +142,22 @@ scale_y_date <- function(name = waiver(), #' @export #' @rdname scale_date -scale_x_datetime <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - timezone = NULL, - limits = NULL, - expand = waiver(), - oob = censor, - guide = waiver(), - position = "bottom", - sec.axis = waiver()) { - +scale_x_datetime <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + timezone = NULL, + limits = NULL, + expand = waiver(), + oob = censor, + guide = waiver(), + position = "bottom", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$x_aes, "time", @@ -180,21 +183,22 @@ scale_x_datetime <- function(name = waiver(), #' @rdname scale_date #' @export -scale_y_datetime <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - timezone = NULL, - limits = NULL, - expand = waiver(), - oob = censor, - guide = waiver(), - position = "left", - sec.axis = waiver()) { - +scale_y_datetime <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + timezone = NULL, + limits = NULL, + expand = waiver(), + oob = censor, + guide = waiver(), + position = "left", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$y_aes, "time", @@ -218,24 +222,24 @@ scale_y_datetime <- function(name = waiver(), } - #' @export #' @rdname scale_date -scale_x_time <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - limits = NULL, - expand = waiver(), - oob = censor, - na.value = NA_real_, - guide = waiver(), - position = "bottom", - sec.axis = waiver()) { - +scale_x_time <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + na.value = NA_real_, + guide = waiver(), + position = "bottom", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$x_aes, "hms", @@ -260,21 +264,22 @@ scale_x_time <- function(name = waiver(), #' @rdname scale_date #' @export -scale_y_time <- function(name = waiver(), - breaks = waiver(), - date_breaks = waiver(), - minor_breaks = waiver(), - date_minor_breaks = waiver(), - labels = waiver(), - date_labels = waiver(), - limits = NULL, - expand = waiver(), - oob = censor, - na.value = NA_real_, - guide = waiver(), - position = "left", - sec.axis = waiver()) { - +scale_y_time <- function( + name = waiver(), + breaks = waiver(), + date_breaks = waiver(), + minor_breaks = waiver(), + date_minor_breaks = waiver(), + labels = waiver(), + date_labels = waiver(), + limits = NULL, + expand = waiver(), + oob = censor, + na.value = NA_real_, + guide = waiver(), + position = "left", + sec.axis = waiver() +) { sc <- datetime_scale( ggplot_global$y_aes, "hms", @@ -306,17 +311,31 @@ scale_y_time <- function(name = waiver(), #' #' @export #' @keywords internal -datetime_scale <- function(aesthetics, transform, trans = deprecated(), - palette, breaks = pretty_breaks(), minor_breaks = waiver(), - labels = waiver(), date_breaks = waiver(), - date_labels = waiver(), - date_minor_breaks = waiver(), timezone = NULL, - guide = "legend", call = caller_call(), ...) { +datetime_scale <- function( + aesthetics, + transform, + trans = deprecated(), + palette, + breaks = pretty_breaks(), + minor_breaks = waiver(), + labels = waiver(), + date_breaks = waiver(), + date_labels = waiver(), + date_minor_breaks = waiver(), + timezone = NULL, + guide = "legend", + call = caller_call(), + ... +) { call <- call %||% current_call() # Backward compatibility - if (is.character(breaks)) breaks <- breaks_width(breaks) - if (is.character(minor_breaks)) minor_breaks <- breaks_width(minor_breaks) + if (is.character(breaks)) { + breaks <- breaks_width(breaks) + } + if (is.character(minor_breaks)) { + minor_breaks <- breaks_width(minor_breaks) + } if (!is_waiver(date_breaks)) { check_string(date_breaks) @@ -351,10 +370,11 @@ datetime_scale <- function(aesthetics, transform, trans = deprecated(), scale_class <- ScaleContinuous } - transform <- switch(transform, + transform <- switch( + transform, date = transform_date(), time = transform_time(timezone), - hms = transform_hms() + hms = transform_hms() ) sc <- continuous_scale( @@ -378,7 +398,9 @@ datetime_scale <- function(aesthetics, transform, trans = deprecated(), #' @format NULL #' @usage NULL #' @export -ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, +ScaleContinuousDatetime <- ggproto( + "ScaleContinuousDatetime", + ScaleContinuous, secondary.axis = waiver(), timezone = NULL, transform = function(self, x) { @@ -389,10 +411,13 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, } if (is_bare_numeric(x)) { x <- self$trans$inverse(x) - cli::cli_warn(c( - "A {.cls numeric} value was passed to a {.field Datetime} scale.", - i = "The value was converted to {obj_type_friendly(x)}." - ), call = self$call) + cli::cli_warn( + c( + "A {.cls numeric} value was passed to a {.field Datetime} scale.", + i = "The value was converted to {obj_type_friendly(x)}." + ), + call = self$call + ) } if (inherits(x, "Date")) { x <- as.POSIXct(x) @@ -424,14 +449,15 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } - ) #' @rdname Scale #' @format NULL #' @usage NULL #' @export -ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, +ScaleContinuousDate <- ggproto( + "ScaleContinuousDate", + ScaleContinuous, secondary.axis = waiver(), map = function(self, x, limits = self$get_limits()) { self$oob(x, limits) @@ -439,10 +465,13 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, transform = function(self, x) { if (is_bare_numeric(x)) { x <- self$trans$inverse(x) - cli::cli_warn(c( - "A {.cls numeric} value was passed to a {.field Date} scale.", - i = "The value was converted to {obj_type_friendly(x)}." - ), call = self$call) + cli::cli_warn( + c( + "A {.cls numeric} value was passed to a {.field Date} scale.", + i = "The value was converted to {obj_type_friendly(x)}." + ), + call = self$call + ) } if (inherits(x, "POSIXct")) { x <- as.Date(x) diff --git a/R/scale-discrete-.R b/R/scale-discrete-.R index 680167b060..27888ca48a 100644 --- a/R/scale-discrete-.R +++ b/R/scale-discrete-.R @@ -73,14 +73,24 @@ #' geom_point() + #' scale_x_discrete(labels = abbreviate) #' } -scale_x_discrete <- function(name = waiver(), ..., palette = seq_len, - expand = waiver(), guide = waiver(), - position = "bottom", sec.axis = waiver(), - continuous.limits = NULL) { +scale_x_discrete <- function( + name = waiver(), + ..., + palette = seq_len, + expand = waiver(), + guide = waiver(), + position = "bottom", + sec.axis = waiver(), + continuous.limits = NULL +) { sc <- discrete_scale( - aesthetics = ggplot_global$x_aes, name = name, - palette = palette, ..., - expand = expand, guide = guide, position = position, + aesthetics = ggplot_global$x_aes, + name = name, + palette = palette, + ..., + expand = expand, + guide = guide, + position = position, super = ScaleDiscretePosition ) @@ -90,14 +100,24 @@ scale_x_discrete <- function(name = waiver(), ..., palette = seq_len, } #' @rdname scale_discrete #' @export -scale_y_discrete <- function(name = waiver(), ..., palette = seq_len, - expand = waiver(), guide = waiver(), - position = "left", sec.axis = waiver(), - continuous.limits = NULL) { +scale_y_discrete <- function( + name = waiver(), + ..., + palette = seq_len, + expand = waiver(), + guide = waiver(), + position = "left", + sec.axis = waiver(), + continuous.limits = NULL +) { sc <- discrete_scale( - aesthetics = ggplot_global$y_aes, name = name, - palette = palette, ..., - expand = expand, guide = guide, position = position, + aesthetics = ggplot_global$y_aes, + name = name, + palette = palette, + ..., + expand = expand, + guide = guide, + position = position, super = ScaleDiscretePosition ) @@ -115,7 +135,9 @@ scale_y_discrete <- function(name = waiver(), ..., palette = seq_len, #' @format NULL #' @usage NULL #' @export -ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, +ScaleDiscretePosition <- ggproto( + "ScaleDiscretePosition", + ScaleDiscrete, continuous_limits = NULL, train = function(self, x) { @@ -133,7 +155,7 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, } # if self$limits is not NULL and is a function, apply it to range - if (is.function(self$limits)){ + if (is.function(self$limits)) { return(self$limits(self$range$range)) } @@ -176,11 +198,20 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, mapped_discrete(x) }, - rescale = function(self, x, limits = self$get_limits(), range = self$dimension(limits = limits)) { + rescale = function( + self, + x, + limits = self$get_limits(), + range = self$dimension(limits = limits) + ) { rescale(self$map(x, limits = limits), from = range) }, - dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { + dimension = function( + self, + expand = expansion(0, 0), + limits = self$get_limits() + ) { expand_limits_scale(self, expand, limits) }, @@ -208,7 +239,9 @@ new_mapped_discrete <- function(x = double()) { x } mapped_discrete <- function(x = double()) { - if (is.null(x)) return(NULL) + if (is.null(x)) { + return(NULL) + } new_mapped_discrete(vec_cast(x, double())) } is_mapped_discrete <- function(x) inherits(x, "mapped_discrete") @@ -229,12 +262,14 @@ c.mapped_discrete <- function(..., recursive = FALSE) { mapped_discrete(NextMethod()) } #' @export -as.data.frame.mapped_discrete <- function (x, ...) { +as.data.frame.mapped_discrete <- function(x, ...) { as.data.frame.vector(x = unclass(x), ...) } #' @export -vec_ptype2.mapped_discrete.mapped_discrete <- function(x, y, ...) new_mapped_discrete() +vec_ptype2.mapped_discrete.mapped_discrete <- function(x, y, ...) { + new_mapped_discrete() +} #' @export vec_ptype2.mapped_discrete.double <- function(x, y, ...) new_mapped_discrete() #' @export @@ -256,17 +291,24 @@ vec_cast.mapped_discrete.mapped_discrete <- function(x, to, ...) x #' @export vec_cast.mapped_discrete.integer <- function(x, to, ...) mapped_discrete(x) #' @export -vec_cast.integer.mapped_discrete <- function(x, to, ...) as.integer(as.vector(x)) +vec_cast.integer.mapped_discrete <- function(x, to, ...) { + as.integer(as.vector(x)) +} #' @export vec_cast.mapped_discrete.double <- function(x, to, ...) new_mapped_discrete(x) #' @export vec_cast.double.mapped_discrete <- function(x, to, ...) as.vector(x) #' @export -vec_cast.character.mapped_discrete <- function(x, to, ...) as.character(as.vector(x)) +vec_cast.character.mapped_discrete <- function(x, to, ...) { + as.character(as.vector(x)) +} #' @export -vec_cast.mapped_discrete.factor <- function(x, to, ...) mapped_discrete(as.vector(unclass(x))) +vec_cast.mapped_discrete.factor <- function(x, to, ...) { + mapped_discrete(as.vector(unclass(x))) +} #' @export -vec_cast.factor.mapped_discrete <- function(x, to, ...) factor(as.vector(x), ...) +vec_cast.factor.mapped_discrete <- function(x, to, ...) { + factor(as.vector(x), ...) +} #' @export vec_cast.mapped_discrete.logical <- function(x, to, ...) mapped_discrete(x) - diff --git a/R/scale-expansion.R b/R/scale-expansion.R index 89b8bd06ad..e4ffd63e25 100644 --- a/R/scale-expansion.R +++ b/R/scale-expansion.R @@ -1,4 +1,3 @@ - #' Generate expansion vector for scales #' #' This is a convenience function for generating scale expansion vectors @@ -36,8 +35,15 @@ #' scale_y_continuous(expand = expansion(mult = .05)) #' expansion <- function(mult = 0, add = 0) { - if (!(is.numeric(mult) && (length(mult) %in% 1:2) && is.numeric(add) && (length(add) %in% 1:2))) { - cli::cli_abort("{.arg mult} and {.arg add} must be numeric vectors with 1 or 2 elements.") + if ( + !(is.numeric(mult) && + (length(mult) %in% 1:2) && + is.numeric(add) && + (length(add) %in% 1:2)) + ) { + cli::cli_abort( + "{.arg mult} and {.arg add} must be numeric vectors with 1 or 2 elements." + ) } mult <- rep(mult, length.out = 2) @@ -65,8 +71,10 @@ expand_scale <- function(mult = 0, add = 0) { #' @noRd #' expand_range4 <- function(limits, expand) { - if (!(is.numeric(expand) && length(expand) %in% c(2,4))) { - cli::cli_abort("{.arg expand} must be a numeric vector with 2 or 4 elements.") + if (!(is.numeric(expand) && length(expand) %in% c(2, 4))) { + cli::cli_abort( + "{.arg expand} must be a numeric vector with 2 or 4 elements." + ) } if (!any(is.finite(limits))) { @@ -94,8 +102,12 @@ expand_range4 <- function(limits, expand) { #' @return One of `discrete`, `continuous`, or `scale$expand` #' @noRd #' -default_expansion <- function(scale, discrete = expansion(add = 0.6), - continuous = expansion(mult = 0.05), expand = TRUE) { +default_expansion <- function( + scale, + discrete = expansion(add = 0.6), + continuous = expansion(mult = 0.05), + expand = TRUE +) { out <- expansion() if (!any(expand)) { return(out) @@ -141,8 +153,12 @@ default_expansion <- function(scale, discrete = expansion(add = 0.6), #' #' @noRd #' -expand_limits_scale <- function(scale, expand = expansion(0, 0), limits = waiver(), - coord_limits = NULL) { +expand_limits_scale <- function( + scale, + expand = expansion(0, 0), + limits = waiver(), + coord_limits = NULL +) { limits <- limits %|W|% scale$get_limits() if (scale$is_discrete()) { @@ -158,18 +174,28 @@ expand_limits_scale <- function(scale, expand = expansion(0, 0), limits = waiver # using the inverse transform to resolve the NA value is needed for date/datetime/time # scales, which refuse to transform objects of the incorrect type transformation <- scale$get_transformation() - coord_limits <- coord_limits %||% transformation$inverse(c(NA_real_, NA_real_)) + coord_limits <- coord_limits %||% + transformation$inverse(c(NA_real_, NA_real_)) coord_limits_scale <- transformation$transform(coord_limits) expand_limits_continuous(limits, expand, coord_limits_scale) } } -expand_limits_continuous <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA)) { +expand_limits_continuous <- function( + limits, + expand = expansion(0, 0), + coord_limits = c(NA, NA) +) { expand_limits_continuous_trans(limits, expand, coord_limits)$continuous_range } -expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA), - range_continuous = NULL, continuous_limits = NULL) { +expand_limits_discrete <- function( + limits, + expand = expansion(0, 0), + coord_limits = c(NA, NA), + range_continuous = NULL, + continuous_limits = NULL +) { if (is.function(continuous_limits)) { continuous_limits <- continuous_limits(limits) } @@ -180,7 +206,7 @@ expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limit check_numeric(continuous_limits, arg = "continuous.limits") check_length(continuous_limits, 2L, arg = "continuous.limits") missing <- is.na(continuous_limits) - limits <- ifelse(missing, range(limits), continuous_limits) + limits <- ifelse(missing, range(limits), continuous_limits) } limit_info <- expand_limits_discrete_trans( @@ -193,9 +219,12 @@ expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limit limit_info$continuous_range } -expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), - coord_limits = c(NA, NA), trans = transform_identity()) { - +expand_limits_continuous_trans <- function( + limits, + expand = expansion(0, 0), + coord_limits = c(NA, NA), + trans = transform_identity() +) { # let non-NA coord_limits override the scale limits limits <- ifelse(is.na(coord_limits), limits, coord_limits) @@ -204,8 +233,13 @@ expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), # range expansion expects values in increasing order, which may not be true # for reciprocal/reverse transformations - if (all(is.finite(continuous_range_coord)) && diff(continuous_range_coord) < 0) { - continuous_range_coord <- rev(expand_range4(rev(continuous_range_coord), expand)) + if ( + all(is.finite(continuous_range_coord)) && diff(continuous_range_coord) < 0 + ) { + continuous_range_coord <- rev(expand_range4( + rev(continuous_range_coord), + expand + )) } else { continuous_range_coord <- expand_range4(continuous_range_coord, expand) } @@ -215,7 +249,11 @@ expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), # if any non-finite values were introduced in the transformations, # replace them with the original scale limits for the purposes of # calculating breaks and minor breaks from the scale - continuous_range <- ifelse(is.finite(final_scale_limits), final_scale_limits, limits) + continuous_range <- ifelse( + is.finite(final_scale_limits), + final_scale_limits, + limits + ) list( continuous_range_coord = sort(continuous_range_coord), @@ -223,9 +261,13 @@ expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), ) } -expand_limits_discrete_trans <- function(limits, expand = expansion(0, 0), - coord_limits = c(NA, NA), trans = transform_identity(), - range_continuous = NULL) { +expand_limits_discrete_trans <- function( + limits, + expand = expansion(0, 0), + coord_limits = c(NA, NA), + trans = transform_identity(), + range_continuous = NULL +) { discrete_limits <- NULL if (length(limits) > 0) { if (is_discrete(limits)) { @@ -242,25 +284,44 @@ expand_limits_discrete_trans <- function(limits, expand = expansion(0, 0), if (is_empty) { expand_limits_continuous_trans(c(0, 1), expand, coord_limits, trans) } else if (is_only_continuous) { - expand_limits_continuous_trans(range_continuous, expand, coord_limits, trans) + expand_limits_continuous_trans( + range_continuous, + expand, + coord_limits, + trans + ) } else if (is_only_discrete) { expand_limits_continuous_trans(discrete_limits, expand, coord_limits, trans) } else { # continuous and discrete - limit_info_discrete <- expand_limits_continuous_trans(discrete_limits, expand, coord_limits, trans) + limit_info_discrete <- expand_limits_continuous_trans( + discrete_limits, + expand, + coord_limits, + trans + ) # don't expand continuous range if there is also a discrete range limit_info_continuous <- expand_limits_continuous_trans( - range_continuous, expansion(0, 0), coord_limits, trans + range_continuous, + expansion(0, 0), + coord_limits, + trans ) # prefer expanded discrete range, but allow continuous range to further expand the range list( continuous_range_coord = range( - c(limit_info_discrete$continuous_range_coord, limit_info_continuous$continuous_range_coord) + c( + limit_info_discrete$continuous_range_coord, + limit_info_continuous$continuous_range_coord + ) ), continuous_range = range( - c(limit_info_discrete$continuous_range, limit_info_continuous$continuous_range) + c( + limit_info_discrete$continuous_range, + limit_info_continuous$continuous_range + ) ) ) } diff --git a/R/scale-gradient.R b/R/scale-gradient.R index 32f61a2e8e..a6e444a3a6 100644 --- a/R/scale-gradient.R +++ b/R/scale-gradient.R @@ -83,28 +83,44 @@ #' geom_point(aes(colour = z1)) + #' scale_colour_gradient(low = "yellow", high = "red", na.value = NA) #' -scale_colour_gradient <- function(name = waiver(), ..., low = "#132B43", - high = "#56B1F7", space = "Lab", - na.value = "grey50", - guide = "colourbar", aesthetics = "colour") { +scale_colour_gradient <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_seq_gradient(low, high, space), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } #' @rdname scale_gradient #' @export -scale_fill_gradient <- function(name = waiver(), ..., low = "#132B43", - high = "#56B1F7", space = "Lab", - na.value = "grey50", guide = "colourbar", - aesthetics = "fill") { +scale_fill_gradient <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_seq_gradient(low, high, space), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } @@ -115,41 +131,72 @@ scale_fill_gradient <- function(name = waiver(), ..., low = "#132B43", #' Defaults to 0. #' @rdname scale_gradient #' @export -scale_colour_gradient2 <- function(name = waiver(), ..., low = muted("red"), - mid = "white", high = muted("blue"), - midpoint = 0, space = "Lab", na.value = "grey50", - transform = "identity", guide = "colourbar", - aesthetics = "colour") { +scale_colour_gradient2 <- function( + name = waiver(), + ..., + low = muted("red"), + mid = "white", + high = muted("blue"), + midpoint = 0, + space = "Lab", + na.value = "grey50", + transform = "identity", + guide = "colourbar", + aesthetics = "colour" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = div_gradient_pal(low, mid, high, space), - na.value = na.value, transform = transform, guide = guide, ..., + na.value = na.value, + transform = transform, + guide = guide, + ..., rescaler = mid_rescaler(mid = midpoint, transform = transform) ) } #' @rdname scale_gradient #' @export -scale_fill_gradient2 <- function(name = waiver(), ..., low = muted("red"), - mid = "white", high = muted("blue"), - midpoint = 0, space = "Lab", na.value = "grey50", - transform = "identity", guide = "colourbar", - aesthetics = "fill") { +scale_fill_gradient2 <- function( + name = waiver(), + ..., + low = muted("red"), + mid = "white", + high = muted("blue"), + midpoint = 0, + space = "Lab", + na.value = "grey50", + transform = "identity", + guide = "colourbar", + aesthetics = "fill" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = div_gradient_pal(low, mid, high, space), - na.value = na.value, transform = transform, guide = guide, ..., + na.value = na.value, + transform = transform, + guide = guide, + ..., rescaler = mid_rescaler(mid = midpoint, transform = transform) ) } -mid_rescaler <- function(mid, transform = "identity", - arg = caller_arg(mid), call = caller_env()) { +mid_rescaler <- function( + mid, + transform = "identity", + arg = caller_arg(mid), + call = caller_env() +) { transform <- as.trans(transform) trans_mid <- transform$transform(mid) check_transformation( - mid, trans_mid, transform$name, - arg = arg, call = call + mid, + trans_mid, + transform$name, + arg = arg, + call = call ) function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) { rescale_mid(x, to, from, trans_mid) @@ -160,29 +207,49 @@ mid_rescaler <- function(mid, transform = "identity", #' @param colours,colors Vector of colours to use for n-colour gradient. #' @rdname scale_gradient #' @export -scale_colour_gradientn <- function(name = waiver(), ..., colours, values = NULL, - space = "Lab", na.value = "grey50", - guide = "colourbar", aesthetics = "colour", - colors) { +scale_colour_gradientn <- function( + name = waiver(), + ..., + colours, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour", + colors +) { colours <- if (missing(colours)) colors else colours continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n(colours, values, space), - na.value = na.value, guide = guide, ... + na.value = na.value, + guide = guide, + ... ) } #' @rdname scale_gradient #' @export -scale_fill_gradientn <- function(name = waiver(), ..., colours, values = NULL, - space = "Lab", na.value = "grey50", - guide = "colourbar", aesthetics = "fill", - colors) { +scale_fill_gradientn <- function( + name = waiver(), + ..., + colours, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill", + colors +) { colours <- if (missing(colours)) colors else colours continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n(colours, values, space), - na.value = na.value, guide = guide, ... + na.value = na.value, + guide = guide, + ... ) } diff --git a/R/scale-grey.R b/R/scale-grey.R index cc6a88033e..06e1fd970a 100644 --- a/R/scale-grey.R +++ b/R/scale-grey.R @@ -29,22 +29,38 @@ #' ggplot(mtcars, aes(mpg, wt)) + #' geom_point(aes(colour = miss)) + #' scale_colour_grey(na.value = "green") -scale_colour_grey <- function(name = waiver(), ..., start = 0.2, end = 0.8, - na.value = "red", aesthetics = "colour") { +scale_colour_grey <- function( + name = waiver(), + ..., + start = 0.2, + end = 0.8, + na.value = "red", + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_grey(start, end), - na.value = na.value, ... + na.value = na.value, + ... ) } #' @rdname scale_grey #' @export -scale_fill_grey <- function(name = waiver(), ..., start = 0.2, end = 0.8, - na.value = "red", aesthetics = "fill") { +scale_fill_grey <- function( + name = waiver(), + ..., + start = 0.2, + end = 0.8, + na.value = "red", + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_grey(start, end), - na.value = na.value, ... + na.value = na.value, + ... ) } diff --git a/R/scale-hue.R b/R/scale-hue.R index 311533e283..e9cbb8e4b3 100644 --- a/R/scale-hue.R +++ b/R/scale-hue.R @@ -56,48 +56,87 @@ #' geom_point(aes(colour = miss)) + #' scale_colour_hue(na.value = "black") #' } -scale_colour_hue <- function(name = waiver(), ..., h = c(0, 360) + 15, c = 100, - l = 65, h.start = 0, direction = 1, - na.value = "grey50", aesthetics = "colour") { +scale_colour_hue <- function( + name = waiver(), + ..., + h = c(0, 360) + 15, + c = 100, + l = 65, + h.start = 0, + direction = 1, + na.value = "grey50", + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_hue(h, c, l, h.start, direction), - na.value = na.value, ... + na.value = na.value, + ... ) } #' @rdname scale_hue #' @export -scale_fill_hue <- function(name = waiver(), ..., h = c(0, 360) + 15, c = 100, - l = 65, h.start = 0, direction = 1, - na.value = "grey50", aesthetics = "fill") { +scale_fill_hue <- function( + name = waiver(), + ..., + h = c(0, 360) + 15, + c = 100, + l = 65, + h.start = 0, + direction = 1, + na.value = "grey50", + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_hue(h, c, l, h.start, direction), - na.value = na.value, ... + na.value = na.value, + ... ) } -scale_colour_qualitative <- function(name = waiver(), ..., type = NULL, - h = c(0, 360) + 15, c = 100, l = 65, - h.start = 0, direction = 1, - na.value = "grey50", - aesthetics = "colour") { +scale_colour_qualitative <- function( + name = waiver(), + ..., + type = NULL, + h = c(0, 360) + 15, + c = 100, + l = 65, + h.start = 0, + direction = 1, + na.value = "grey50", + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_qualitative(type, h, c, l, h.start, direction), - na.value = na.value, ... + na.value = na.value, + ... ) } -scale_fill_qualitative <- function(name = waiver(), ..., type = NULL, - h = c(0, 360) + 15, c = 100, l = 65, - h.start = 0, direction = 1, - na.value = "grey50", aesthetics = "fill") { +scale_fill_qualitative <- function( + name = waiver(), + ..., + type = NULL, + h = c(0, 360) + 15, + c = 100, + l = 65, + h.start = 0, + direction = 1, + na.value = "grey50", + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_qualitative(type, h, c, l, h.start, direction), - na.value = na.value, ... + na.value = na.value, + ... ) } diff --git a/R/scale-identity.R b/R/scale-identity.R index 29023868c6..8afaee0f78 100644 --- a/R/scale-identity.R +++ b/R/scale-identity.R @@ -65,22 +65,36 @@ NULL #' @rdname scale_identity #' @export -scale_colour_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "colour") { +scale_colour_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleDiscreteIdentity ) } #' @rdname scale_identity #' @export -scale_fill_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "fill") { +scale_fill_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleDiscreteIdentity ) } @@ -89,11 +103,18 @@ scale_fill_identity <- function(name = waiver(), ..., guide = "none", #' @seealso #' Other shape scales: [scale_shape()], [scale_shape_manual()]. #' @export -scale_shape_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "shape") { +scale_shape_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "shape" +) { continuous_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleContinuousIdentity ) } @@ -102,11 +123,18 @@ scale_shape_identity <- function(name = waiver(), ..., guide = "none", #' @seealso #' Other linetype scales: [scale_linetype()], [scale_linetype_manual()]. #' @export -scale_linetype_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "linetype") { +scale_linetype_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "linetype" +) { discrete_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleDiscreteIdentity ) } @@ -115,22 +143,36 @@ scale_linetype_identity <- function(name = waiver(), ..., guide = "none", #' @seealso #' Other alpha scales: [scale_alpha()], [scale_alpha_manual()]. #' @export -scale_linewidth_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "linewidth") { +scale_linewidth_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "linewidth" +) { continuous_scale( - aesthetics, name = name, - palette = pal_identity(), ..., - guide = guide, super = ScaleContinuousIdentity + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, + super = ScaleContinuousIdentity ) } #' @rdname scale_identity #' @export -scale_alpha_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "alpha") { +scale_alpha_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "alpha" +) { continuous_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleContinuousIdentity ) } @@ -139,33 +181,54 @@ scale_alpha_identity <- function(name = waiver(), ..., guide = "none", #' @seealso #' Other size scales: [scale_size()], [scale_size_manual()]. #' @export -scale_size_identity <- function(name = waiver(), ..., guide = "none", - aesthetics = "size") { +scale_size_identity <- function( + name = waiver(), + ..., + guide = "none", + aesthetics = "size" +) { continuous_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleContinuousIdentity ) } #' @rdname scale_identity #' @export -scale_discrete_identity <- function(aesthetics, name = waiver(), ..., - guide = "none") { +scale_discrete_identity <- function( + aesthetics, + name = waiver(), + ..., + guide = "none" +) { discrete_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleDiscreteIdentity ) } #' @rdname scale_identity #' @export -scale_continuous_identity <- function(aesthetics, name = waiver(), ..., - guide = "none") { +scale_continuous_identity <- function( + aesthetics, + name = waiver(), + ..., + guide = "none" +) { continuous_scale( - aesthetics, name = name, - palette = pal_identity(), ..., guide = guide, + aesthetics, + name = name, + palette = pal_identity(), + ..., + guide = guide, super = ScaleContinuousIdentity ) } @@ -174,7 +237,9 @@ scale_continuous_identity <- function(aesthetics, name = waiver(), ..., #' @format NULL #' @usage NULL #' @export -ScaleDiscreteIdentity <- ggproto("ScaleDiscreteIdentity", ScaleDiscrete, +ScaleDiscreteIdentity <- ggproto( + "ScaleDiscreteIdentity", + ScaleDiscrete, map = function(x) { if (is.factor(x)) { as.character(x) @@ -185,7 +250,9 @@ ScaleDiscreteIdentity <- ggproto("ScaleDiscreteIdentity", ScaleDiscrete, train = function(self, x) { # do nothing if no guide, otherwise train so we know what breaks to use - if (identical(self$guide, "none")) return() + if (identical(self$guide, "none")) { + return() + } ggproto_parent(ScaleDiscrete, self)$train(x) } ) @@ -195,7 +262,9 @@ ScaleDiscreteIdentity <- ggproto("ScaleDiscreteIdentity", ScaleDiscrete, #' @format NULL #' @usage NULL #' @export -ScaleContinuousIdentity <- ggproto("ScaleContinuousIdentity", ScaleContinuous, +ScaleContinuousIdentity <- ggproto( + "ScaleContinuousIdentity", + ScaleContinuous, map = function(x) { if (is.factor(x)) { as.character(x) @@ -206,7 +275,9 @@ ScaleContinuousIdentity <- ggproto("ScaleContinuousIdentity", ScaleContinuous, train = function(self, x) { # do nothing if no guide, otherwise train so we know what breaks to use - if (identical(self$guide, "none")) return() + if (identical(self$guide, "none")) { + return() + } ggproto_parent(ScaleContinuous, self)$train(x) } ) diff --git a/R/scale-linetype.R b/R/scale-linetype.R index f3d48aa4c5..087394e440 100644 --- a/R/scale-linetype.R +++ b/R/scale-linetype.R @@ -44,7 +44,8 @@ #' theme_void(20) scale_linetype <- function(name = waiver(), ..., aesthetics = "linetype") { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = NULL, ... ) @@ -52,9 +53,14 @@ scale_linetype <- function(name = waiver(), ..., aesthetics = "linetype") { #' @rdname scale_linetype #' @export -scale_linetype_binned <- function(name = waiver(), ..., aesthetics = "linetype") { +scale_linetype_binned <- function( + name = waiver(), + ..., + aesthetics = "linetype" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = NULL, ... ) diff --git a/R/scale-linewidth.R b/R/scale-linewidth.R index 2a062e0e73..fcc34afbda 100644 --- a/R/scale-linewidth.R +++ b/R/scale-linewidth.R @@ -29,16 +29,29 @@ NULL #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_continuous <- function(name = waiver(), breaks = waiver(), - labels = waiver(), limits = NULL, - range = NULL, transform = "identity", - trans = deprecated(), - guide = "legend", - aesthetics = "linewidth") { +scale_linewidth_continuous <- function( + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + range = NULL, + transform = "identity", + trans = deprecated(), + guide = "legend", + aesthetics = "linewidth" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL - continuous_scale(aesthetics, palette = palette, name = name, - breaks = breaks, labels = labels, limits = limits, - transform = transform, trans = trans, guide = guide) + continuous_scale( + aesthetics, + palette = palette, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + transform = transform, + trans = trans, + guide = guide + ) } #' @rdname scale_linewidth @@ -47,22 +60,42 @@ scale_linewidth <- scale_linewidth_continuous #' @rdname scale_linewidth #' @export -scale_linewidth_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = NULL, n.breaks = NULL, - nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins", aesthetics = "linewidth") { +scale_linewidth_binned <- function( + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + range = NULL, + n.breaks = NULL, + nice.breaks = TRUE, + transform = "identity", + trans = deprecated(), + guide = "bins", + aesthetics = "linewidth" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL - binned_scale(aesthetics, palette = palette, name = name, - breaks = breaks, labels = labels, limits = limits, - transform = transform, trans = trans, n.breaks = n.breaks, - nice.breaks = nice.breaks, guide = guide) + binned_scale( + aesthetics, + palette = palette, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + transform = transform, + trans = trans, + n.breaks = n.breaks, + nice.breaks = nice.breaks, + guide = guide + ) } #' @rdname scale_linewidth #' @export #' @usage NULL scale_linewidth_discrete <- function(...) { - cli::cli_warn("Using {.field linewidth} for a discrete variable is not advised.") + cli::cli_warn( + "Using {.field linewidth} for a discrete variable is not advised." + ) args <- list2(...) args$call <- args$call %||% current_call() exec(scale_linewidth_ordinal, !!!args) @@ -71,7 +104,12 @@ scale_linewidth_discrete <- function(...) { #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { +scale_linewidth_ordinal <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "linewidth" +) { palette <- if (!is.null(range)) { function(n) seq(range[1], range[2], length.out = n) } else { @@ -83,21 +121,37 @@ scale_linewidth_ordinal <- function(name = waiver(), ..., range = NULL, aestheti #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { +scale_linewidth_datetime <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "linewidth" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics, transform = "time", name = name, - palette = palette, ... + aesthetics, + transform = "time", + name = name, + palette = palette, + ... ) } #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_date <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { +scale_linewidth_date <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "linewidth" +) { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics, transform = "date", name = name, - palette = palette, ... + aesthetics, + transform = "date", + name = name, + palette = palette, + ... ) } diff --git a/R/scale-manual.R b/R/scale-manual.R index 87b479e926..e51462d309 100644 --- a/R/scale-manual.R +++ b/R/scale-manual.R @@ -89,13 +89,25 @@ NULL #' @rdname scale_manual #' @export -scale_colour_manual <- function(..., values, aesthetics = "colour", breaks = waiver(), na.value = "grey50") { +scale_colour_manual <- function( + ..., + values, + aesthetics = "colour", + breaks = waiver(), + na.value = "grey50" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @export -scale_fill_manual <- function(..., values, aesthetics = "fill", breaks = waiver(), na.value = "grey50") { +scale_fill_manual <- function( + ..., + values, + aesthetics = "fill", + breaks = waiver(), + na.value = "grey50" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } @@ -103,7 +115,13 @@ scale_fill_manual <- function(..., values, aesthetics = "fill", breaks = waiver( #' @seealso #' Other size scales: [scale_size()], [scale_size_identity()]. #' @export -scale_size_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "size") { +scale_size_manual <- function( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "size" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } @@ -111,7 +129,13 @@ scale_size_manual <- function(..., values, breaks = waiver(), na.value = NA, aes #' @seealso #' Other shape scales: [scale_shape()], [scale_shape_identity()]. #' @export -scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "shape") { +scale_shape_manual <- function( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "shape" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } @@ -119,7 +143,13 @@ scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA, ae #' @seealso #' Other linetype scales: [scale_linetype()], [scale_linetype_identity()]. #' @export -scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "linetype") { +scale_linetype_manual <- function( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linetype" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } @@ -127,13 +157,25 @@ scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = NA, #' @seealso #' Other alpha scales: [scale_alpha()], [scale_alpha_identity()]. #' @export -scale_linewidth_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "linewidth") { +scale_linewidth_manual <- function( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linewidth" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @export -scale_alpha_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "alpha") { +scale_alpha_manual <- function( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "alpha" +) { manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } @@ -143,9 +185,15 @@ scale_discrete_manual <- function(aesthetics, ..., values, breaks = waiver()) { manual_scale(aesthetics, values, breaks, ...) } -manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), - name = waiver(), ..., - limits = NULL, call = caller_call()) { +manual_scale <- function( + aesthetic, + values = NULL, + breaks = waiver(), + name = waiver(), + ..., + limits = NULL, + call = caller_call() +) { call <- call %||% current_call() # check for missing `values` parameter, in lieu of providing # a default to all the different scale_*_manual() functions @@ -171,8 +219,13 @@ manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), } # order values according to breaks - if (is.vector(values) && is.null(names(values)) && !is_waiver(breaks) && - !is.null(breaks) && !is.function(breaks)) { + if ( + is.vector(values) && + is.null(names(values)) && + !is_waiver(breaks) && + !is.null(breaks) && + !is.function(breaks) + ) { if (length(breaks) <= length(values)) { names(values) <- breaks } else { @@ -182,13 +235,19 @@ manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), pal <- function(n) { if (n > length(values)) { - cli::cli_abort("Insufficient values in manual scale. {n} needed but only {length(values)} provided.") + cli::cli_abort( + "Insufficient values in manual scale. {n} needed but only {length(values)} provided." + ) } values } discrete_scale( - aesthetic, name = name, - palette = pal, breaks = breaks, limits = limits, - call = call, ... + aesthetic, + name = name, + palette = pal, + breaks = breaks, + limits = limits, + call = call, + ... ) } diff --git a/R/scale-shape.R b/R/scale-shape.R index bde6756840..ef044b456f 100644 --- a/R/scale-shape.R +++ b/R/scale-shape.R @@ -49,14 +49,24 @@ #' scale_shape_identity() + #' facet_wrap(~shape) + #' theme_void() -scale_shape <- function(name = waiver(), ..., solid = NULL, aesthetics = "shape") { +scale_shape <- function( + name = waiver(), + ..., + solid = NULL, + aesthetics = "shape" +) { palette <- if (!is.null(solid)) pal_shape(solid) else NULL discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_shape #' @export -scale_shape_binned <- function(name = waiver(), ..., solid = TRUE, aesthetics = "shape") { +scale_shape_binned <- function( + name = waiver(), + ..., + solid = TRUE, + aesthetics = "shape" +) { palette <- if (!is.null(solid)) pal_binned(pal_shape(solid)) else NULL binned_scale(aesthetics, name = name, palette = palette, ...) } diff --git a/R/scale-size.R b/R/scale-size.R index 964abf16a6..859384c940 100644 --- a/R/scale-size.R +++ b/R/scale-size.R @@ -51,16 +51,29 @@ NULL #' @rdname scale_size #' @export #' @usage NULL -scale_size_continuous <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = NULL, - transform = "identity", - trans = deprecated(), - guide = "legend", - aesthetics = "size") { +scale_size_continuous <- function( + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + range = NULL, + transform = "identity", + trans = deprecated(), + guide = "legend", + aesthetics = "size" +) { palette <- if (!is.null(range)) pal_area(range) else NULL - continuous_scale(aesthetics, palette = palette, name = name, - breaks = breaks, labels = labels, limits = limits, - transform = transform, trans = trans, guide = guide) + continuous_scale( + aesthetics, + palette = palette, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + transform = transform, + trans = trans, + guide = guide + ) } #' @rdname scale_size @@ -69,27 +82,59 @@ scale_size <- scale_size_continuous #' @rdname scale_size #' @export -scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = c(1, 6), - transform = "identity", trans = deprecated(), - guide = "legend", aesthetics = "size") { - continuous_scale(aesthetics, palette = pal_rescale(range), name = name, - breaks = breaks, labels = labels, limits = limits, transform = transform, - trans = trans, guide = guide) +scale_radius <- function( + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + range = c(1, 6), + transform = "identity", + trans = deprecated(), + guide = "legend", + aesthetics = "size" +) { + continuous_scale( + aesthetics, + palette = pal_rescale(range), + name = name, + breaks = breaks, + labels = labels, + limits = limits, + transform = transform, + trans = trans, + guide = guide + ) } #' @rdname scale_size #' @export -scale_size_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = NULL, n.breaks = NULL, - nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins", - aesthetics = "size") { +scale_size_binned <- function( + name = waiver(), + breaks = waiver(), + labels = waiver(), + limits = NULL, + range = NULL, + n.breaks = NULL, + nice.breaks = TRUE, + transform = "identity", + trans = deprecated(), + guide = "bins", + aesthetics = "size" +) { palette <- if (!is.null(range)) pal_area(range) else NULL - binned_scale(aesthetics, palette = palette, name = name, - breaks = breaks, labels = labels, limits = limits, - transform = transform, trans = trans, n.breaks = n.breaks, - nice.breaks = nice.breaks, guide = guide) + binned_scale( + aesthetics, + palette = palette, + name = name, + breaks = breaks, + labels = labels, + limits = limits, + transform = transform, + trans = trans, + n.breaks = n.breaks, + nice.breaks = nice.breaks, + guide = guide + ) } #' @rdname scale_size @@ -105,7 +150,12 @@ scale_size_discrete <- function(...) { #' @rdname scale_size #' @export #' @usage NULL -scale_size_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { +scale_size_ordinal <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "size" +) { palette <- if (!is.null(range)) { function(n) sqrt(seq(range[1]^2, range[2]^2, length.out = n)) } else { @@ -118,28 +168,47 @@ scale_size_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = #' @param max_size Size of largest points. #' @export #' @rdname scale_size -scale_size_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { +scale_size_area <- function( + name = waiver(), + ..., + max_size = 6, + aesthetics = "size" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = abs_area(max_size), - rescaler = rescale_max, ... + rescaler = rescale_max, + ... ) } #' @export #' @rdname scale_size -scale_size_binned_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { +scale_size_binned_area <- function( + name = waiver(), + ..., + max_size = 6, + aesthetics = "size" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = abs_area(max_size), - rescaler = rescale_max, ... + rescaler = rescale_max, + ... ) } #' @rdname scale_size #' @export #' @usage NULL -scale_size_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { +scale_size_datetime <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "size" +) { palette <- if (!is.null(range)) pal_area(range) else NULL datetime_scale(aesthetics, "time", name = name, palette = palette, ...) } @@ -147,7 +216,12 @@ scale_size_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = #' @rdname scale_size #' @export #' @usage NULL -scale_size_date <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { +scale_size_date <- function( + name = waiver(), + ..., + range = NULL, + aesthetics = "size" +) { palette <- if (!is.null(range)) pal_area(range) else NULL datetime_scale(aesthetics, "date", name = name, palette = palette, ...) } diff --git a/R/scale-steps.R b/R/scale-steps.R index 9ef13ac630..b8c6b28c2b 100644 --- a/R/scale-steps.R +++ b/R/scale-steps.R @@ -47,83 +47,141 @@ #' geom_point(aes(colour = z1)) + #' scale_colour_stepsn(colours = terrain.colors(10)) #' @rdname scale_steps -scale_colour_steps <- function(name = waiver(), ..., low = "#132B43", - high = "#56B1F7", space = "Lab", - na.value = "grey50", guide = "coloursteps", - aesthetics = "colour") { +scale_colour_steps <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "colour" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_seq_gradient(low, high, space), - na.value = na.value, guide = guide, ... + na.value = na.value, + guide = guide, + ... ) } #' @rdname scale_steps #' @export -scale_colour_steps2 <- function(name = waiver(), ..., low = muted("red"), - mid = "white", high = muted("blue"), - midpoint = 0, space = "Lab", na.value = "grey50", - transform = "identity", guide = "coloursteps", - aesthetics = "colour") { +scale_colour_steps2 <- function( + name = waiver(), + ..., + low = muted("red"), + mid = "white", + high = muted("blue"), + midpoint = 0, + space = "Lab", + na.value = "grey50", + transform = "identity", + guide = "coloursteps", + aesthetics = "colour" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = div_gradient_pal(low, mid, high, space), - na.value = na.value, transform = transform, guide = guide, + na.value = na.value, + transform = transform, + guide = guide, rescaler = mid_rescaler(mid = midpoint, transform = transform), ... ) } #' @rdname scale_steps #' @export -scale_colour_stepsn <- function(name = waiver(), ..., colours, values = NULL, - space = "Lab", na.value = "grey50", - guide = "coloursteps", aesthetics = "colour", - colors) { +scale_colour_stepsn <- function( + name = waiver(), + ..., + colours, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "colour", + colors +) { colours <- if (missing(colours)) colors else colours binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n(colours, values, space), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } #' @rdname scale_steps #' @export -scale_fill_steps <- function(name = waiver(), ..., low = "#132B43", - high = "#56B1F7", space = "Lab", - na.value = "grey50", guide = "coloursteps", - aesthetics = "fill") { +scale_fill_steps <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "fill" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_seq_gradient(low, high, space), - na.value = na.value, guide = guide, + na.value = na.value, + guide = guide, ... ) } #' @rdname scale_steps #' @export -scale_fill_steps2 <- function(name = waiver(), ..., low = muted("red"), - mid = "white", high = muted("blue"), - midpoint = 0, space = "Lab", na.value = "grey50", - transform = "identity", guide = "coloursteps", - aesthetics = "fill") { +scale_fill_steps2 <- function( + name = waiver(), + ..., + low = muted("red"), + mid = "white", + high = muted("blue"), + midpoint = 0, + space = "Lab", + na.value = "grey50", + transform = "identity", + guide = "coloursteps", + aesthetics = "fill" +) { binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = div_gradient_pal(low, mid, high, space), - na.value = na.value, transform = transform, guide = guide, + na.value = na.value, + transform = transform, + guide = guide, rescaler = mid_rescaler(mid = midpoint, transform = transform), ... ) } #' @rdname scale_steps #' @export -scale_fill_stepsn <- function(name = waiver(), ..., colours, values = NULL, - space = "Lab", na.value = "grey50", - guide = "coloursteps", aesthetics = "fill", - colors) { +scale_fill_stepsn <- function( + name = waiver(), + ..., + colours, + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "fill", + colors +) { colours <- if (missing(colours)) colors else colours binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n(colours, values, space), - na.value = na.value, guide = guide, ... + na.value = na.value, + guide = guide, + ... ) } diff --git a/R/scale-type.R b/R/scale-type.R index e9f3b8cc9b..0469186b79 100644 --- a/R/scale-type.R +++ b/R/scale-type.R @@ -2,7 +2,9 @@ find_scale <- function(aes, x, env = parent.frame()) { # Inf is ambiguous; it can be used either with continuous scales or with # discrete scales, so just skip in the hope that we will have a better guess # with the other layers - if (is.null(x) || (is_atomic(x) && all(is.infinite(x))) || inherits(x, "AsIs")) { + if ( + is.null(x) || (is_atomic(x) && all(is.infinite(x))) || inherits(x, "AsIs") + ) { return(NULL) } @@ -63,7 +65,9 @@ scale_type <- function(x) UseMethod("scale_type") #' @export scale_type.default <- function(x) { - cli::cli_inform("Don't know how to automatically pick scale for object of type {.cls {class(x)}}. Defaulting to continuous.") + cli::cli_inform( + "Don't know how to automatically pick scale for object of type {.cls {class(x)}}. Defaulting to continuous." + ) "continuous" } diff --git a/R/scale-view.R b/R/scale-view.R index 53d1404197..9d2afd7f0c 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -1,4 +1,3 @@ - #' View scale constructor #' #' View scales are an implementation of `Scale` objects that have fixed @@ -12,22 +11,29 @@ #' @param continuous_range The final dimensions of the scale #' #' @noRd -view_scale_primary <- function(scale, limits = scale$get_limits(), - continuous_range = scale$dimension(limits = limits)) { - +view_scale_primary <- function( + scale, + limits = scale$get_limits(), + continuous_range = scale$dimension(limits = limits) +) { # continuous_range can be specified in arbitrary order, but # scales expect the one in ascending order. continuous_scale_sorted <- sort(continuous_range) - if(!scale$is_discrete()) { + if (!scale$is_discrete()) { breaks <- scale$get_breaks(continuous_scale_sorted) breaks <- censor(breaks, continuous_scale_sorted, only.finite = FALSE) } else { breaks <- scale$get_breaks(limits) } - minor_breaks <- scale$get_breaks_minor(b = breaks, limits = continuous_scale_sorted) + minor_breaks <- scale$get_breaks_minor( + b = breaks, + limits = continuous_scale_sorted + ) minor_breaks <- censor(minor_breaks, continuous_range, only.finite = FALSE) - ggproto(NULL, ViewScale, + ggproto( + NULL, + ViewScale, scale = scale, guide = scale$guide, position = scale$position, @@ -42,10 +48,16 @@ view_scale_primary <- function(scale, limits = scale$get_limits(), } # this function is a hack that is difficult to avoid given the complex implementation of second axes -view_scale_secondary <- function(scale, limits = scale$get_limits(), - continuous_range = scale$dimension(limits = limits)) { - - if (is.null(scale$secondary.axis) || is_waiver(scale$secondary.axis) || scale$secondary.axis$empty()) { +view_scale_secondary <- function( + scale, + limits = scale$get_limits(), + continuous_range = scale$dimension(limits = limits) +) { + if ( + is.null(scale$secondary.axis) || + is_waiver(scale$secondary.axis) || + scale$secondary.axis$empty() + ) { # if there is no second axis, return the primary scale with no guide # this guide can be overridden using guides() primary_scale <- view_scale_primary(scale, limits, continuous_range) @@ -59,7 +71,8 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), # flip position from the original scale by default # this can (should) be overridden in the guide - position <- switch(scale$position, + position <- switch( + scale$position, top = "bottom", bottom = "top", left = "right", @@ -67,7 +80,9 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), scale$position ) - ggproto(NULL, ViewScale, + ggproto( + NULL, + ViewScale, scale = scale, guide = scale$secondary.axis$guide, position = position, @@ -84,13 +99,17 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), get_breaks_minor = function(self) self$break_info$minor_source, break_positions = function(self) self$break_info$major, break_positions_minor = function(self) self$break_info$minor, - get_labels = function(self, breaks = self$get_breaks()) self$break_info$labels, + get_labels = function(self, breaks = self$get_breaks()) { + self$break_info$labels + }, rescale = function(x) rescale(x, from = break_info$range, to = c(0, 1)) ) } } -ViewScale <- ggproto("ViewScale", NULL, +ViewScale <- ggproto( + "ViewScale", + NULL, # map, rescale, and make_title need a reference # to the original scale scale = ggproto(NULL, Scale), @@ -167,7 +186,7 @@ ViewScale <- ggproto("ViewScale", NULL, }, make_fixed_copy = function(self) { breaks <- self$get_breaks() - minor <- self$get_breaks_minor() + minor <- self$get_breaks_minor() transform <- self$scale$get_transformation() if (self$scale$is_discrete()) { @@ -178,17 +197,18 @@ ViewScale <- ggproto("ViewScale", NULL, if (!is.null(transform)) { breaks <- transform$inverse(breaks) - minor <- transform$inverse(minor) + minor <- transform$inverse(minor) } ggproto( - NULL, self$scale, + NULL, + self$scale, breaks = breaks, minor_breaks = minor, limits = limits, expand = c(0, 0, 0, 0), continuous_limits = self$continuous_range, - train = function (...) NULL + train = function(...) NULL ) } ) diff --git a/R/scale-viridis.R b/R/scale-viridis.R index 57b212e07c..7c56a7b691 100644 --- a/R/scale-viridis.R +++ b/R/scale-viridis.R @@ -58,11 +58,19 @@ #' # Use viridis_b to bin continuous data before mapping #' v + scale_fill_viridis_b() #' -scale_colour_viridis_d <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - aesthetics = "colour") { +scale_colour_viridis_d <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + aesthetics = "colour" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_viridis(alpha, begin, end, direction, option), ... ) @@ -70,11 +78,19 @@ scale_colour_viridis_d <- function(name = waiver(), ..., alpha = 1, begin = 0, #' @export #' @rdname scale_viridis -scale_fill_viridis_d <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - aesthetics = "fill") { +scale_fill_viridis_d <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + aesthetics = "fill" +) { discrete_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_viridis(alpha, begin, end, direction, option), ... ) @@ -82,13 +98,23 @@ scale_fill_viridis_d <- function(name = waiver(), ..., alpha = 1, begin = 0, #' @export #' @rdname scale_viridis -scale_colour_viridis_c <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - values = NULL, space = "Lab", - na.value = "grey50", guide = "colourbar", - aesthetics = "colour") { +scale_colour_viridis_c <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n( pal_viridis(alpha, begin, end, direction, option)(6), values, @@ -102,13 +128,23 @@ scale_colour_viridis_c <- function(name = waiver(), ..., alpha = 1, begin = 0, #' @export #' @rdname scale_viridis -scale_fill_viridis_c <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - values = NULL, space = "Lab", - na.value = "grey50", guide = "colourbar", - aesthetics = "fill") { +scale_fill_viridis_c <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill" +) { continuous_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal_gradient_n( pal_viridis(alpha, begin, end, direction, option)(6), values, @@ -122,17 +158,27 @@ scale_fill_viridis_c <- function(name = waiver(), ..., alpha = 1, begin = 0, #' @export #' @rdname scale_viridis -scale_colour_viridis_b <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - values = NULL, space = "Lab", - na.value = "grey50", guide = "coloursteps", - aesthetics = "colour") { - pal <- pal_binned( +scale_colour_viridis_b <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "colour" +) { + pal <- pal_binned( pal_viridis(alpha, begin, end, direction, option) ) binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal, na.value = na.value, guide = guide, @@ -142,17 +188,27 @@ scale_colour_viridis_b <- function(name = waiver(), ..., alpha = 1, begin = 0, #' @export #' @rdname scale_viridis -scale_fill_viridis_b <- function(name = waiver(), ..., alpha = 1, begin = 0, - end = 1, direction = 1, option = "D", - values = NULL, space = "Lab", - na.value = "grey50", guide = "coloursteps", - aesthetics = "fill") { - pal <- pal_binned( +scale_fill_viridis_b <- function( + name = waiver(), + ..., + alpha = 1, + begin = 0, + end = 1, + direction = 1, + option = "D", + values = NULL, + space = "Lab", + na.value = "grey50", + guide = "coloursteps", + aesthetics = "fill" +) { + pal <- pal_binned( pal_viridis(alpha, begin, end, direction, option) ) binned_scale( - aesthetics, name = name, + aesthetics, + name = name, palette = pal, na.value = na.value, guide = guide, diff --git a/R/scales-.R b/R/scales-.R index 6c14347f49..de4524b8b4 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -6,11 +6,17 @@ scales_list <- function() { ggproto(NULL, ScalesList) } -ScalesList <- ggproto("ScalesList", NULL, +ScalesList <- ggproto( + "ScalesList", + NULL, scales = NULL, find = function(self, aesthetic) { - vapply(self$scales, function(x) any(aesthetic %in% x$aesthetics), logical(1)) + vapply( + self$scales, + function(x) any(aesthetic %in% x$aesthetics), + logical(1) + ) }, has_scale = function(self, aesthetic) { @@ -57,7 +63,9 @@ ScalesList <- ggproto("ScalesList", NULL, get_scales = function(self, output) { scale <- self$scales[self$find(output)] - if (length(scale) == 0) return() + if (length(scale) == 0) { + return() + } scale[[1]] }, @@ -73,10 +81,13 @@ ScalesList <- ggproto("ScalesList", NULL, return(df) } - mapped <- unlist(lapply( - self$scales, - function(scale) scale$map_df(df = df) - ), recursive = FALSE) + mapped <- unlist( + lapply( + self$scales, + function(scale) scale$map_df(df = df) + ), + recursive = FALSE + ) df[names(mapped)] <- mapped df @@ -89,21 +100,29 @@ ScalesList <- ggproto("ScalesList", NULL, # If the scale contains to trans or trans is identity, there is no need # to transform anything - idx_skip <- vapply(self$scales, function(x) { - transformation <- x$get_transformation() - has_default_transform(x) && - (is.null(transformation) || identical(transformation$transform, identity)) - }, logical(1L)) + idx_skip <- vapply( + self$scales, + function(x) { + transformation <- x$get_transformation() + has_default_transform(x) && + (is.null(transformation) || + identical(transformation$transform, identity)) + }, + logical(1L) + ) scales <- self$scales[!idx_skip] if (length(scales) == 0) { return(df) } - transformed <- unlist(lapply( - scales, - function(scale) scale$transform_df(df = df) - ), recursive = FALSE) + transformed <- unlist( + lapply( + scales, + function(scale) scale$transform_df(df = df) + ), + recursive = FALSE + ) df[names(transformed)] <- transformed df @@ -115,31 +134,39 @@ ScalesList <- ggproto("ScalesList", NULL, # If the scale contains to trans or trans is identity, there is no need # to transform anything - idx_skip <- vapply(self$scales, function(x) { - transformation <- x$get_transformation() - has_default_transform(x) && - (is.null(transformation) || identical(transformation$transform, identity)) - }, logical(1)) + idx_skip <- vapply( + self$scales, + function(x) { + transformation <- x$get_transformation() + has_default_transform(x) && + (is.null(transformation) || + identical(transformation$transform, identity)) + }, + logical(1) + ) scales <- self$scales[!idx_skip] if (length(scales) == 0) { return(df) } - backtransformed <- unlist(lapply( - scales, - function(scale) { - aesthetics <- intersect(scale$aesthetics, names(df)) - if (length(aesthetics) == 0) { - return() - } - inverse <- scale$get_transformation()$inverse - if (is.null(inverse)) { - return() + backtransformed <- unlist( + lapply( + scales, + function(scale) { + aesthetics <- intersect(scale$aesthetics, names(df)) + if (length(aesthetics) == 0) { + return() + } + inverse <- scale$get_transformation()$inverse + if (is.null(inverse)) { + return() + } + lapply(df[aesthetics], inverse) } - lapply(df[aesthetics], inverse) - } - ), recursive = FALSE) + ), + recursive = FALSE + ) df[names(backtransformed)] <- backtransformed df @@ -154,7 +181,6 @@ ScalesList <- ggproto("ScalesList", NULL, return() } - for (aes in new_aesthetics) { self$add(find_scale(aes, data[[aes]], env)) } @@ -186,7 +212,7 @@ ScalesList <- ggproto("ScalesList", NULL, elem <- elem %||% fallback_palette(scale) palette <- switch( type, - discrete = as_discrete_pal(elem), + discrete = as_discrete_pal(elem), continuous = as_continuous_pal(elem) ) if (!is.function(palette)) { @@ -204,4 +230,3 @@ ScalesList <- ggproto("ScalesList", NULL, } } ) - diff --git a/R/stat-.R b/R/stat-.R index cb4fc1a983..065d6f3c59 100644 --- a/R/stat-.R +++ b/R/stat-.R @@ -200,7 +200,9 @@ Stat <- ggproto( unlist(strsplit(self$required_aes, "|", fixed = TRUE)) ) - data <- remove_missing(data, params$na.rm, + data <- remove_missing( + data, + params$na.rm, c(required_aes, self$non_missing_aes), snake_class(self), finite = TRUE @@ -215,7 +217,10 @@ Stat <- ggproto( try_fetch( inject(self$compute_panel(data = data, scales = scales, !!!params)), error = function(cnd) { - cli::cli_warn("Computation failed in {.fn {snake_class(self)}}.", parent = cnd) + cli::cli_warn( + "Computation failed in {.fn {snake_class(self)}}.", + parent = cnd + ) data_frame0() } ) @@ -251,7 +256,9 @@ Stat <- ggproto( #' #' A data frame with layer data compute_panel = function(self, data, scales, ...) { - if (empty(data)) return(data_frame0()) + if (empty(data)) { + return(data_frame0()) + } groups <- split(data, data$group) stats <- lapply(groups, function(group) { @@ -261,39 +268,49 @@ Stat <- ggproto( # Record columns that are not constant within groups. We will drop them later. non_constant_columns <- character(0) - stats <- mapply(function(new, old) { - # In this function, - # - # - `new` is the computed result. All the variables will be picked. - # - `old` is the original data. There are 3 types of variables: - # 1) If the variable is already included in `new`, it's ignored - # because the values of `new` will be used. - # 2) If the variable is not included in `new` and the value is - # constant within the group, it will be picked. - # 3) If the variable is not included in `new` and the value is not - # constant within the group, it will be dropped. We need to record - # the dropped columns to drop it consistently later. - - if (empty(new)) return(data_frame0()) - - # First, filter out the columns already included `new` (type 1). - old <- old[, !(names(old) %in% names(new)), drop = FALSE] - - # Then, check whether the rest of the columns have constant values (type 2) - # or not (type 3). - non_constant <- vapply(old, vec_unique_count, integer(1)) > 1L - - # Record the non-constant columns. - non_constant_columns <<- c(non_constant_columns, names(old)[non_constant]) - - vec_cbind( - new, - # Note that, while the non-constant columns should be dropped, we don't - # do this here because it can be filled by vec_rbind() later if either - # one of the group has a constant value (see #4394 for the details). - old[rep(1, nrow(new)), , drop = FALSE] - ) - }, stats, groups, SIMPLIFY = FALSE) + stats <- mapply( + function(new, old) { + # In this function, + # + # - `new` is the computed result. All the variables will be picked. + # - `old` is the original data. There are 3 types of variables: + # 1) If the variable is already included in `new`, it's ignored + # because the values of `new` will be used. + # 2) If the variable is not included in `new` and the value is + # constant within the group, it will be picked. + # 3) If the variable is not included in `new` and the value is not + # constant within the group, it will be dropped. We need to record + # the dropped columns to drop it consistently later. + + if (empty(new)) { + return(data_frame0()) + } + + # First, filter out the columns already included `new` (type 1). + old <- old[, !(names(old) %in% names(new)), drop = FALSE] + + # Then, check whether the rest of the columns have constant values (type 2) + # or not (type 3). + non_constant <- vapply(old, vec_unique_count, integer(1)) > 1L + + # Record the non-constant columns. + non_constant_columns <<- c( + non_constant_columns, + names(old)[non_constant] + ) + + vec_cbind( + new, + # Note that, while the non-constant columns should be dropped, we don't + # do this here because it can be filled by vec_rbind() later if either + # one of the group has a constant value (see #4394 for the details). + old[rep(1, nrow(new)), , drop = FALSE] + ) + }, + stats, + groups, + SIMPLIFY = FALSE + ) non_constant_columns <- unique0(non_constant_columns) @@ -400,7 +417,6 @@ Stat <- ggproto( } c(union(required_aes, names(self$default_aes)), self$optional_aes, "group") } - ) #' @export diff --git a/R/stat-align.R b/R/stat-align.R index 23d0489396..ec9c1fbdd5 100644 --- a/R/stat-align.R +++ b/R/stat-align.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatAlign <- ggproto( - "StatAlign", Stat, + "StatAlign", + Stat, extra_params = c("na.rm", "orientation"), required_aes = c("x", "y"), @@ -27,23 +28,37 @@ StatAlign <- ggproto( pivot <- vec_unrep(data_frame0(group = data$group, y = y < 0)) group_ends <- cumsum(vec_unrep(pivot$key$group)$times) pivot <- cumsum(pivot$times)[-group_ends] - cross <- -y[pivot] * (x[pivot + 1] - x[pivot]) / - (y[pivot + 1] - y[pivot]) + x[pivot] + cross <- -y[pivot] * + (x[pivot + 1] - x[pivot]) / + (y[pivot + 1] - y[pivot]) + + x[pivot] unique_loc <- unique(sort(c(x, cross))) - adjust <- diff(range(unique_loc, na.rm = TRUE)) * 0.001 - adjust <- min(adjust, min(diff(unique_loc)) / 3) + adjust <- diff(range(unique_loc, na.rm = TRUE)) * 0.001 + adjust <- min(adjust, min(diff(unique_loc)) / 3) unique_loc <- unique(sort(c( - unique_loc - adjust, unique_loc, unique_loc + adjust + unique_loc - adjust, + unique_loc, + unique_loc + adjust ))) ggproto_parent(Stat, self)$compute_panel( - data, scales, flipped_aes = flipped_aes, unique_loc = unique_loc, - adjust = adjust, ... + data, + scales, + flipped_aes = flipped_aes, + unique_loc = unique_loc, + adjust = adjust, + ... ) }, - compute_group = function(data, scales, flipped_aes = NA, unique_loc = NULL, adjust = 0) { + compute_group = function( + data, + scales, + flipped_aes = NA, + unique_loc = NULL, + adjust = 0 + ) { data <- flip_data(data, flipped_aes) if (is_unique(data$x)) { # Not enough data to align @@ -52,7 +67,9 @@ StatAlign <- ggproto( # Sort out multiple observations at the same x if (anyDuplicated(data$x)) { data <- dapply(data, "x", function(d) { - if (nrow(d) == 1) return(d) + if (nrow(d) == 1) { + return(d) + } d <- d[c(1, nrow(d)), ] d$x[1] <- d$x[1] - adjust d @@ -81,6 +98,7 @@ StatAlign <- ggproto( #' @export #' @rdname geom_ribbon stat_align <- make_constructor( - StatAlign, geom = "area", + StatAlign, + geom = "area", omit = c("unique_loc", "adjust") ) diff --git a/R/stat-bin.R b/R/stat-bin.R index 1b2361f250..74c364e699 100644 --- a/R/stat-bin.R +++ b/R/stat-bin.R @@ -3,9 +3,14 @@ #' @usage NULL #' @export StatBin <- ggproto( - "StatBin", Stat, + "StatBin", + Stat, setup_params = function(self, data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = FALSE + ) if (is.logical(params$drop)) { params$drop <- if (isTRUE(params$drop)) "all" else "none" @@ -13,16 +18,21 @@ StatBin <- ggproto( drop <- params$drop params$drop <- arg_match0( params$drop %||% "none", - c("all", "none", "extremes"), arg_nm = "drop" + c("all", "none", "extremes"), + arg_nm = "drop" ) has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic." + ) } if (has_x && has_y) { - cli::cli_abort("{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic." + ) } x <- flipped_names(params$flipped_aes)$x @@ -40,15 +50,29 @@ StatBin <- ggproto( extra_params = c("na.rm", "orientation"), - compute_group = function(data, scales, binwidth = NULL, bins = NULL, - center = NULL, boundary = NULL, - closed = c("right", "left"), pad = FALSE, - breaks = NULL, flipped_aes = FALSE, drop = "none") { + compute_group = function( + data, + scales, + binwidth = NULL, + bins = NULL, + center = NULL, + boundary = NULL, + closed = c("right", "left"), + pad = FALSE, + breaks = NULL, + flipped_aes = FALSE, + drop = "none" + ) { x <- flipped_names(flipped_aes)$x bins <- compute_bins( - data[[x]], scales[[x]], - breaks = breaks, binwidth = binwidth, bins = bins, - center = center, boundary = boundary, closed = closed + data[[x]], + scales[[x]], + breaks = breaks, + binwidth = binwidth, + bins = bins, + center = center, + boundary = boundary, + closed = closed ) bins <- bin_vector(data[[x]], bins, weight = data$weight, pad = pad) @@ -122,7 +146,9 @@ StatBin <- ggproto( #' @export #' @rdname geom_histogram stat_bin <- make_constructor( - StatBin, geom = "bar", position = "stack", + StatBin, + geom = "bar", + position = "stack", orientation = NA ) diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index da9716d7de..8fbc1a80ec 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -4,14 +4,22 @@ #' @usage NULL #' @export StatBin2d <- ggproto( - "StatBin2d", StatSummary2d, + "StatBin2d", + StatSummary2d, default_aes = aes(weight = 1, fill = after_stat(count)), required_aes = c("x", "y"), - compute_group = function(data, scales, binwidth = NULL, bins = 30, - breaks = NULL, drop = TRUE, - boundary = NULL, closed = NULL, center = NULL) { - + compute_group = function( + data, + scales, + binwidth = NULL, + bins = 30, + breaks = NULL, + drop = TRUE, + boundary = NULL, + closed = NULL, + center = NULL + ) { data$z <- data$weight %||% 1 data$weight <- NULL @@ -19,8 +27,15 @@ StatBin2d <- ggproto( boundary <- boundary %||% if (is.null(center)) list(x = 0, y = 0) out <- StatSummary2d$compute_group( - data, scales, binwidth = binwidth, bins = bins, breaks = breaks, - drop = drop, fun = "sum", boundary = boundary, closed = closed, + data, + scales, + binwidth = binwidth, + bins = bins, + breaks = breaks, + drop = drop, + fun = "sum", + boundary = boundary, + closed = closed, center = center ) diff --git a/R/stat-bindot.R b/R/stat-bindot.R index 5367a2d99a..73128bf8cd 100644 --- a/R/stat-bindot.R +++ b/R/stat-bindot.R @@ -2,7 +2,9 @@ #' @format NULL #' @usage NULL #' @export -StatBindot <- ggproto("StatBindot", Stat, +StatBindot <- ggproto( + "StatBindot", + Stat, required_aes = "x", non_missing_aes = "weight", default_aes = aes(y = after_stat(count)), @@ -10,7 +12,9 @@ StatBindot <- ggproto("StatBindot", Stat, setup_params = function(data, params) { if (is.null(params$binwidth)) { - cli::cli_inform("Bin width defaults to 1/30 of the range of the data. Pick better value with {.arg binwidth}.") + cli::cli_inform( + "Bin width defaults to 1/30 of the range of the data. Pick better value with {.arg binwidth}." + ) } params }, @@ -20,57 +24,91 @@ StatBindot <- ggproto("StatBindot", Stat, ggproto_parent(Stat, self)$compute_layer(data, params, layout) }, - compute_panel = function(self, data, scales, na.rm = FALSE, binwidth = NULL, - binaxis = "x", method = "dotdensity", - binpositions = "bygroup", origin = NULL, - width = 0.9, drop = FALSE, - right = TRUE) { - + compute_panel = function( + self, + data, + scales, + na.rm = FALSE, + binwidth = NULL, + binaxis = "x", + method = "dotdensity", + binpositions = "bygroup", + origin = NULL, + width = 0.9, + drop = FALSE, + right = TRUE + ) { # If using dotdensity and binning over all, we need to find the bin centers # for all data before it's split into groups. if (method == "dotdensity" && binpositions == "all") { if (binaxis == "x") { - newdata <- densitybin(x = data$x, weight = data$weight, binwidth = binwidth, - method = method) + newdata <- densitybin( + x = data$x, + weight = data$weight, + binwidth = binwidth, + method = method + ) - data <- data[order(data$x), ] + data <- data[order(data$x), ] newdata <- newdata[order(newdata$x), ] - } else if (binaxis == "y") { - newdata <- densitybin(x = data$y, weight = data$weight, binwidth = binwidth, - method = method) + newdata <- densitybin( + x = data$y, + weight = data$weight, + binwidth = binwidth, + method = method + ) - data <- data[order(data$y), ] + data <- data[order(data$y), ] newdata <- newdata[order(newdata$x), ] } - data$bin <- newdata$bin - data$binwidth <- newdata$binwidth - data$weight <- newdata$weight + data$bin <- newdata$bin + data$binwidth <- newdata$binwidth + data$weight <- newdata$weight data$bincenter <- newdata$bincenter - } - ggproto_parent(Stat, self)$compute_panel(data, scales, binwidth = binwidth, - binaxis = binaxis, method = method, binpositions = binpositions, - origin = origin, width = width, drop = drop, - right = right) + ggproto_parent(Stat, self)$compute_panel( + data, + scales, + binwidth = binwidth, + binaxis = binaxis, + method = method, + binpositions = binpositions, + origin = origin, + width = width, + drop = drop, + right = right + ) }, - compute_group = function(self, data, scales, binwidth = NULL, binaxis = "x", - method = "dotdensity", binpositions = "bygroup", - origin = NULL, width = 0.9, drop = FALSE, - right = TRUE) { + compute_group = function( + self, + data, + scales, + binwidth = NULL, + binaxis = "x", + method = "dotdensity", + binpositions = "bygroup", + origin = NULL, + width = 0.9, + drop = FALSE, + right = TRUE + ) { # Check that weights are whole numbers (for dots, weights must be whole) - if (!is.null(data$weight) && !(is_integerish(data$weight) && all(data$weight >= 0))) { + if ( + !is.null(data$weight) && + !(is_integerish(data$weight) && all(data$weight >= 0)) + ) { stop_input_type(data$weight, "nonnegative integers", arg = "weight") } if (binaxis == "x") { - range <- scales$x$dimension() - values <- data$x + range <- scales$x$dimension() + values <- data$x } else if (binaxis == "y") { - range <- scales$y$dimension() + range <- scales$y$dimension() values <- data$y # The middle of each group, on the stack axis midline <- mean(range(data$x)) @@ -78,23 +116,32 @@ StatBindot <- ggproto("StatBindot", Stat, if (method == "histodot") { bins <- compute_bins( - values, scales[[binaxis]], - breaks = NULL, binwidth = binwidth, bins = 30, center = NULL, - boundary = origin, closed = if (right) "right" else "left" + values, + scales[[binaxis]], + breaks = NULL, + binwidth = binwidth, + bins = 30, + center = NULL, + boundary = origin, + closed = if (right) "right" else "left" ) data <- bin_vector(values, bins, weight = data$weight, pad = FALSE) # Change "width" column to "binwidth" for consistency names(data)[names(data) == "width"] <- "binwidth" - names(data)[names(data) == "x"] <- "bincenter" - + names(data)[names(data) == "x"] <- "bincenter" } else if (method == "dotdensity") { - # If bin centers are found by group instead of by all, find the bin centers # (If binpositions=="all", then we'll already have bin centers.) - if (binpositions == "bygroup") - data <- densitybin(x = values, weight = data$weight, binwidth = binwidth, - method = method, range = range) + if (binpositions == "bygroup") { + data <- densitybin( + x = values, + weight = data$weight, + binwidth = binwidth, + method = method, + range = range + ) + } # Collapse each bin and get a count data <- dapply(data, "bincenter", function(x) { @@ -130,45 +177,58 @@ StatBindot <- ggproto("StatBindot", Stat, # This does density binning, but does not collapse each bin with a count. # It returns a data frame with the original data (x), weights, bin #, and the bin centers. -densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range = NULL) { - - if (length(stats::na.omit(x)) == 0) return(data_frame0()) - if (is.null(weight)) weight <- rep(1, length(x)) - weight[is.na(weight)] <- 0 - - if (is.null(range)) range <- range(x, na.rm = TRUE, finite = TRUE) - if (is.null(binwidth)) binwidth <- diff(range) / 30 - - # Sort weight and x, by x - weight <- weight[order(x)] - x <- sort(x, na.last = TRUE) - - cbin <- 0 # Current bin ID - bin <- rep.int(NA, length(x)) # The bin ID for each observation - binend <- -Inf # End position of current bin (scan left to right) - - # Scan list and put dots in bins - for (i in seq_along(x)) { - # If past end of bin, start a new bin at this point - if (x[i] >= binend) { - binend <- x[i] + binwidth - cbin <- cbin + 1 - } - - bin[i] <- cbin +densitybin <- function( + x, + weight = NULL, + binwidth = NULL, + method = method, + range = NULL +) { + if (length(stats::na.omit(x)) == 0) { + return(data_frame0()) + } + if (is.null(weight)) { + weight <- rep(1, length(x)) + } + weight[is.na(weight)] <- 0 + + if (is.null(range)) { + range <- range(x, na.rm = TRUE, finite = TRUE) + } + if (is.null(binwidth)) { + binwidth <- diff(range) / 30 + } + + # Sort weight and x, by x + weight <- weight[order(x)] + x <- sort(x, na.last = TRUE) + + cbin <- 0 # Current bin ID + bin <- rep.int(NA, length(x)) # The bin ID for each observation + binend <- -Inf # End position of current bin (scan left to right) + + # Scan list and put dots in bins + for (i in seq_along(x)) { + # If past end of bin, start a new bin at this point + if (x[i] >= binend) { + binend <- x[i] + binwidth + cbin <- cbin + 1 } - results <- data_frame0( - x = x, - bin = bin, - binwidth = binwidth, - weight = weight, - .size = length(x) - ) - results <- dapply(results, "bin", function(df) { - df$bincenter = (min(df$x) + max(df$x)) / 2 - return(df) - }) - - return(results) + bin[i] <- cbin + } + + results <- data_frame0( + x = x, + bin = bin, + binwidth = binwidth, + weight = weight, + .size = length(x) + ) + results <- dapply(results, "bin", function(df) { + df$bincenter = (min(df$x) + max(df$x)) / 2 + return(df) + }) + + return(results) } diff --git a/R/stat-binhex.R b/R/stat-binhex.R index 31b956b454..c8709412f3 100644 --- a/R/stat-binhex.R +++ b/R/stat-binhex.R @@ -3,13 +3,19 @@ #' @usage NULL #' @export StatBinhex <- ggproto( - "StatBinhex", Stat, + "StatBinhex", + Stat, default_aes = aes(weight = 1, fill = after_stat(count)), required_aes = c("x", "y"), - compute_group = function(data, scales, binwidth = NULL, bins = 30, - na.rm = FALSE) { + compute_group = function( + data, + scales, + binwidth = NULL, + bins = 30, + na.rm = FALSE + ) { check_installed("hexbin", reason = "for `stat_bin_hex()`.") binwidth <- binwidth %||% hex_binwidth(bins, scales) diff --git a/R/stat-boxplot.R b/R/stat-boxplot.R index 41819e5e1e..da2a0f1c9a 100644 --- a/R/stat-boxplot.R +++ b/R/stat-boxplot.R @@ -2,7 +2,9 @@ #' @format NULL #' @usage NULL #' @export -StatBoxplot <- ggproto("StatBoxplot", Stat, +StatBoxplot <- ggproto( + "StatBoxplot", + Stat, required_aes = c("y|x"), non_missing_aes = "weight", # either the x or y aesthetic will get dropped during @@ -21,20 +23,32 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, }, setup_params = function(self, data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, - group_has_equal = TRUE, - main_is_optional = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = TRUE, + group_has_equal = TRUE, + main_is_optional = TRUE + ) data <- flip_data(data, params$flipped_aes) has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic." + ) } - params$width <- params$width %||% (resolution(data$x %||% 0, discrete = TRUE) * 0.75) + params$width <- params$width %||% + (resolution(data$x %||% 0, discrete = TRUE) * 0.75) - if (!is_mapped_discrete(data$x) && is.double(data$x) && !has_groups(data) && any(data$x != data$x[1L])) { + if ( + !is_mapped_discrete(data$x) && + is.double(data$x) && + !has_groups(data) && + any(data$x != data$x[1L]) + ) { cli::cli_warn(c( "Continuous {.field {flipped_names(params$flipped_aes)$x}} aesthetic", "i" = "did you forget {.code aes(group = ...)}?" @@ -46,7 +60,14 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, extra_params = c("na.rm", "orientation"), - compute_group = function(data, scales, width = NULL, na.rm = FALSE, coef = 1.5, flipped_aes = FALSE) { + compute_group = function( + data, + scales, + width = NULL, + na.rm = FALSE, + coef = 1.5, + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) qs <- c(0, 0.25, 0.5, 0.75, 1) @@ -59,13 +80,15 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, names(stats) <- c("ymin", "lower", "middle", "upper", "ymax") iqr <- diff(stats[c(2, 4)]) - outliers <- data$y < (stats[2] - coef * iqr) | data$y > (stats[4] + coef * iqr) + outliers <- data$y < (stats[2] - coef * iqr) | + data$y > (stats[4] + coef * iqr) if (any(outliers)) { stats[c(1, 5)] <- range(c(stats[2:4], data$y[!outliers]), na.rm = TRUE) } - if (vec_unique_count(data$x) > 1) + if (vec_unique_count(data$x) > 1) { width <- diff(range(data$x)) * 0.9 + } df <- data_frame0(!!!as.list(stats)) df$outliers <- list(data$y[outliers]) @@ -107,6 +130,9 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, #' upper hinger + 1.5 * IQR." #' ) stat_boxplot <- make_constructor( - StatBoxplot, geom = "boxplot", position = "dodge2", - orientation = NA, omit = "width" + StatBoxplot, + geom = "boxplot", + position = "dodge2", + orientation = NA, + omit = "width" ) diff --git a/R/stat-connect.R b/R/stat-connect.R index a2a73590bd..d10f29016e 100644 --- a/R/stat-connect.R +++ b/R/stat-connect.R @@ -3,14 +3,17 @@ #' @usage NULL #' @export StatConnect <- ggproto( - "StatConnect", Stat, + "StatConnect", + Stat, required_aes = c("x|xmin|xmax", "y|ymin|ymax"), setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes( - data, params, - range_is_orthogonal = TRUE, ambiguous = TRUE + data, + params, + range_is_orthogonal = TRUE, + ambiguous = TRUE ) connection <- params$connection %||% "hv" @@ -19,16 +22,18 @@ StatConnect <- ggproto( check_string(connection) connection <- switch( arg_match0(connection, c("hv", "vh", "mid", "linear")), - hv = matrix(c(1, 1, 0, 1), 2, 2), - vh = matrix(c(0, 0, 0, 1), 2, 2), - mid = matrix(c(0.5, 0.5, 0, 1), 2, 2), - linear = matrix(c(0, 1, 0, 1), 2, 2) + hv = matrix(c(1, 1, 0, 1), 2, 2), + vh = matrix(c(0, 0, 0, 1), 2, 2), + mid = matrix(c(0.5, 0.5, 0, 1), 2, 2), + linear = matrix(c(0, 1, 0, 1), 2, 2) ) } - if (!is.matrix(connection) || + if ( + !is.matrix(connection) || !typeof(connection) %in% c("integer", "double") || - !identical(dim(connection)[2], 2L)) { + !identical(dim(connection)[2], 2L) + ) { extra <- "" if (!is.null(dim(connection)[2])) { extra <- paste0(" with ", dim(connection)[2], " column(s)") @@ -53,8 +58,12 @@ StatConnect <- ggproto( params }, - compute_group = function(data, scales, connection = "hv", flipped_aes = FALSE) { - + compute_group = function( + data, + scales, + connection = "hv", + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) n <- nrow(data) @@ -68,7 +77,7 @@ StatConnect <- ggproto( m <- nrow(connection) before <- rep(seq_len(n - 1), each = m) - after <- rep(seq_len(n)[-1], each = m) + after <- rep(seq_len(n)[-1], each = m) data <- vec_slice(data, order(data$x %||% data$xmin)) @@ -76,12 +85,12 @@ StatConnect <- ggproto( # Note that `length(x) != length(xjust)`, but these are kept in sync due to # the matrix recycling rules (effectively `rep(xjust, ncol(x))`) x <- as.matrix(data[intersect(names(data), ggplot_global$x_aes)]) - xjust <- rep(connection[, 1], n - 1L) + xjust <- rep(connection[, 1], n - 1L) x <- vec_slice(x, before) * (1 - xjust) + vec_slice(x, after) * xjust # Interpolate y y <- as.matrix(data[intersect(names(data), ggplot_global$y_aes)]) - yjust <- rep(connection[, 2], n - 1L) + yjust <- rep(connection[, 2], n - 1L) y <- vec_slice(y, before) * (1 - yjust) + vec_slice(y, after) * yjust # Reconstitute data @@ -98,7 +107,6 @@ StatConnect <- ggproto( } flip_data(new_data, flipped_aes) } - ) #' Connect observations diff --git a/R/stat-contour.R b/R/stat-contour.R index d299d68f01..028af2379b 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatContour <- ggproto( - "StatContour", Stat, + "StatContour", + Stat, required_aes = c("x", "y", "z"), default_aes = aes(order = after_stat(level)), @@ -19,15 +20,25 @@ StatContour <- ggproto( contour_deduplicate(data) }, - compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL, - breaks = NULL, na.rm = FALSE) { + compute_group = function( + data, + scales, + z.range, + bins = NULL, + binwidth = NULL, + breaks = NULL, + na.rm = FALSE + ) { # Undo data rotation rotation <- estimate_contour_angle(data$x, data$y) data[c("x", "y")] <- rotate_xy(data$x, data$y, -rotation) breaks <- contour_breaks(z.range, bins, binwidth, breaks) - isolines <- withr::with_options(list(OutDec = "."), xyz_to_isolines(data, breaks)) + isolines <- withr::with_options( + list(OutDec = "."), + xyz_to_isolines(data, breaks) + ) path_df <- iso_to_geom(isolines, data$group[1], geom = "path") path_df$level <- as.numeric(path_df$level) @@ -44,7 +55,8 @@ StatContour <- ggproto( #' @usage NULL #' @export StatContourFilled <- ggproto( - "StatContourFilled", Stat, + "StatContourFilled", + Stat, required_aes = c("x", "y", "z"), default_aes = aes(order = after_stat(level), fill = after_stat(level)), @@ -60,22 +72,32 @@ StatContourFilled <- ggproto( contour_deduplicate(data) }, - compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL, breaks = NULL, na.rm = FALSE) { - + compute_group = function( + data, + scales, + z.range, + bins = NULL, + binwidth = NULL, + breaks = NULL, + na.rm = FALSE + ) { # Undo data rotation rotation <- estimate_contour_angle(data$x, data$y) data[c("x", "y")] <- rotate_xy(data$x, data$y, -rotation) breaks <- contour_breaks(z.range, bins, binwidth, breaks) - isobands <- withr::with_options(list(OutDec = "."), xyz_to_isobands(data, breaks)) + isobands <- withr::with_options( + list(OutDec = "."), + xyz_to_isobands(data, breaks) + ) names(isobands) <- pretty_isoband_levels(names(isobands)) path_df <- iso_to_geom(isobands, data$group[1], geom = "polygon") path_df$level <- ordered(path_df$level, levels = names(isobands)) path_df$level_low <- breaks[as.numeric(path_df$level)] path_df$level_high <- breaks[as.numeric(path_df$level) + 1] - path_df$level_mid <- 0.5*(path_df$level_low + path_df$level_high) + path_df$level_mid <- 0.5 * (path_df$level_low + path_df$level_high) path_df$nlevel <- rescale_max(path_df$level_high) # Re-apply data rotation path_df[c("x", "y")] <- rotate_xy(path_df$x, path_df$y, rotation) @@ -113,14 +135,16 @@ StatContourFilled <- ggproto( #' #' @rdname geom_contour stat_contour <- make_constructor( - StatContour, geom = "contour", + StatContour, + geom = "contour", omit = "z.range" ) #' @rdname geom_contour #' @export stat_contour_filled <- make_constructor( - StatContourFilled, geom = "contour_filled", + StatContourFilled, + geom = "contour_filled", omit = "z.range" ) @@ -132,7 +156,12 @@ stat_contour_filled <- make_constructor( #' @return A vector of breaks #' @noRd #' -contour_breaks <- function(z_range, bins = NULL, binwidth = NULL, breaks = NULL) { +contour_breaks <- function( + z_range, + bins = NULL, + binwidth = NULL, + breaks = NULL +) { breaks <- allow_lambda(breaks) if (is.numeric(breaks)) { @@ -152,9 +181,9 @@ contour_breaks <- function(z_range, bins = NULL, binwidth = NULL, breaks = NULL) if (!is.null(bins)) { # round lower limit down and upper limit up to make sure # we generate bins that span the data range nicely - accuracy <- signif(diff(z_range), 1)/10 - z_range[1] <- floor(z_range[1]/accuracy)*accuracy - z_range[2] <- ceiling(z_range[2]/accuracy)*accuracy + accuracy <- signif(diff(z_range), 1) / 10 + z_range[1] <- floor(z_range[1] / accuracy) * accuracy + z_range[2] <- ceiling(z_range[2] / accuracy) * accuracy if (bins == 1) { return(z_range) @@ -287,7 +316,7 @@ pretty_isoband_levels <- function(isoband_levels, dig.lab = 3) { breaks <- unique(c(interval_low, interval_high)) - while(anyDuplicated(format(breaks, digits = dig.lab, trim = TRUE))) { + while (anyDuplicated(format(breaks, digits = dig.lab, trim = TRUE))) { dig.lab <- dig.lab + 1 } @@ -328,7 +357,6 @@ contour_deduplicate <- function(data, check = c("x", "y", "group", "PANEL")) { } estimate_contour_angle <- function(x, y) { - # Compute most frequent angle among first 20 points all_angles <- atan2(diff(head(y, 20L)), diff(head(x, 20L))) freq <- tabulate(match(all_angles, unique(all_angles))) @@ -351,7 +379,8 @@ estimate_contour_angle <- function(x, y) { } # No need to rotate contour data when angle is straight - straight <- abs(angle - c(-1, -0.5, 0, 0.5, 1) * pi) < sqrt(.Machine$double.eps) + straight <- abs(angle - c(-1, -0.5, 0, 0.5, 1) * pi) < + sqrt(.Machine$double.eps) if (any(straight)) { return(0) } diff --git a/R/stat-count.R b/R/stat-count.R index ee3a6f927b..3e697adb17 100644 --- a/R/stat-count.R +++ b/R/stat-count.R @@ -4,21 +4,30 @@ #' @export #' @include stat-.R StatCount <- ggproto( - "StatCount", Stat, + "StatCount", + Stat, required_aes = "x|y", default_aes = aes(x = after_stat(count), y = after_stat(count), weight = 1), setup_params = function(self, data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = FALSE + ) has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic." + ) } if (has_x && has_y) { - cli::cli_abort("{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic." + ) } if (is.null(params$width)) { @@ -31,7 +40,13 @@ StatCount <- ggproto( extra_params = c("na.rm", "orientation"), - compute_group = function(self, data, scales, width = NULL, flipped_aes = FALSE) { + compute_group = function( + self, + data, + scales, + width = NULL, + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) x <- data$x weight <- data$weight %||% rep(1, length(x)) @@ -65,6 +80,9 @@ StatCount <- ggproto( #' @export #' @rdname geom_bar stat_count <- make_constructor( - StatCount, geom = "bar", position = "stack", - orientation = NA, omit = "width" + StatCount, + geom = "bar", + position = "stack", + orientation = NA, + omit = "width" ) diff --git a/R/stat-density-2d.R b/R/stat-density-2d.R index cc9a6e20bb..54648155ea 100644 --- a/R/stat-density-2d.R +++ b/R/stat-density-2d.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatDensity2d <- ggproto( - "StatDensity2d", Stat, + "StatDensity2d", + Stat, default_aes = aes(colour = "#3366FF", size = 0.5), required_aes = c("x", "y"), @@ -13,8 +14,12 @@ StatDensity2d <- ggproto( dropped_aes = character(0), extra_params = c( - "na.rm", "contour", "contour_var", - "bins", "binwidth", "breaks" + "na.rm", + "contour", + "contour_var", + "bins", + "binwidth", + "breaks" ), # when contouring is on, are we returning lines or bands? @@ -29,7 +34,9 @@ StatDensity2d <- ggproto( } # if we're not contouring we're done - if (!isTRUE(params$contour %||% TRUE)) return(data) + if (!isTRUE(params$contour %||% TRUE)) { + return(data) + } # set up data and parameters for contouring contour_var <- params$contour_var %||% "density" @@ -44,32 +51,54 @@ StatDensity2d <- ggproto( if (isTRUE(self$contour_type == "bands")) { contour_stat <- ggproto(NULL, StatContourFilled) - } else { # lines is the default + } else { + # lines is the default contour_stat <- ggproto(NULL, StatContour) } # update dropped aes - contour_stat$dropped_aes <- c(contour_stat$dropped_aes, "density", "ndensity", "count") + contour_stat$dropped_aes <- c( + contour_stat$dropped_aes, + "density", + "ndensity", + "count" + ) dapply(data, "PANEL", function(data) { scales <- layout$get_scales(data$PANEL[1]) try_fetch( - inject(contour_stat$compute_panel(data = data, scales = scales, !!!params)), + inject(contour_stat$compute_panel( + data = data, + scales = scales, + !!!params + )), error = function(cnd) { - cli::cli_warn("Computation failed in {.fn {snake_class(self)}}.", parent = cnd) + cli::cli_warn( + "Computation failed in {.fn {snake_class(self)}}.", + parent = cnd + ) data_frame0() } ) }) }, - compute_group = function(data, scales, na.rm = FALSE, h = NULL, adjust = c(1, 1), - n = 100, ...) { - + compute_group = function( + data, + scales, + na.rm = FALSE, + h = NULL, + adjust = c(1, 1), + n = 100, + ... + ) { h <- precompute_2d_bw(data$x, data$y, h = h, adjust = adjust) # calculate density dens <- MASS::kde2d( - data$x, data$y, h = h, n = n, + data$x, + data$y, + h = h, + n = n, lims = c(scales$x$dimension(), scales$y$dimension()) ) @@ -92,7 +121,8 @@ StatDensity2d <- ggproto( #' @usage NULL #' @export StatDensity2dFilled <- ggproto( - "StatDensity2dFilled", StatDensity2d, + "StatDensity2dFilled", + StatDensity2d, default_aes = aes(colour = NA, fill = after_stat(level)), contour_type = "bands" ) @@ -141,8 +171,10 @@ StatDensity2dFilled <- ggproto( #' are no longer available after the contouring pass. #' stat_density_2d <- make_constructor( - StatDensity2d, geom = "density_2d", - contour = TRUE, contour_var = "density" + StatDensity2d, + geom = "density_2d", + contour = TRUE, + contour_var = "density" ) #' @rdname geom_density_2d @@ -153,8 +185,10 @@ stat_density2d <- stat_density_2d #' @rdname geom_density_2d #' @export stat_density_2d_filled <- make_constructor( - StatDensity2dFilled, geom = "density_2d_filled", - contour = TRUE, contour_var = "density" + StatDensity2dFilled, + geom = "density_2d_filled", + contour = TRUE, + contour_var = "density" ) #' @rdname geom_density_2d @@ -163,13 +197,16 @@ stat_density_2d_filled <- make_constructor( stat_density2d_filled <- stat_density_2d_filled precompute_2d_bw <- function(x, y, h = NULL, adjust = 1) { - if (is.null(h)) { # Note: MASS::bandwidth.nrd is equivalent to stats::bw.nrd * 4 h <- c(MASS::bandwidth.nrd(x), MASS::bandwidth.nrd(y)) # Handle case when when IQR == 0 and thus regular nrd bandwidth fails - if (h[1] == 0 && length(x) > 1) h[1] <- stats::bw.nrd0(x) * 4 - if (h[2] == 0 && length(y) > 1) h[2] <- stats::bw.nrd0(y) * 4 + if (h[1] == 0 && length(x) > 1) { + h[1] <- stats::bw.nrd0(x) * 4 + } + if (h[2] == 0 && length(y) > 1) { + h[2] <- stats::bw.nrd0(y) * 4 + } h <- h * adjust } diff --git a/R/stat-density.R b/R/stat-density.R index b655918667..0096d8173d 100644 --- a/R/stat-density.R +++ b/R/stat-density.R @@ -3,20 +3,33 @@ #' @usage NULL #' @export StatDensity <- ggproto( - "StatDensity", Stat, + "StatDensity", + Stat, required_aes = "x|y", - default_aes = aes(x = after_stat(density), y = after_stat(density), fill = NA, weight = NULL), + default_aes = aes( + x = after_stat(density), + y = after_stat(density), + fill = NA, + weight = NULL + ), dropped_aes = "weight", setup_params = function(self, data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = FALSE, + main_is_continuous = TRUE + ) has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic." + ) } params @@ -24,9 +37,18 @@ StatDensity <- ggproto( extra_params = c("na.rm", "orientation"), - compute_group = function(data, scales, bw = "nrd0", adjust = 1, kernel = "gaussian", - n = 512, trim = FALSE, na.rm = FALSE, bounds = c(-Inf, Inf), - flipped_aes = FALSE) { + compute_group = function( + data, + scales, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + trim = FALSE, + na.rm = FALSE, + bounds = c(-Inf, Inf), + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) if (trim) { range <- range(data$x, na.rm = TRUE) @@ -34,9 +56,17 @@ StatDensity <- ggproto( range <- scales[[flipped_names(flipped_aes)$x]]$dimension() } - density <- compute_density(data$x, data$weight, from = range[1], - to = range[2], bw = bw, adjust = adjust, kernel = kernel, n = n, - bounds = bounds) + density <- compute_density( + data$x, + data$weight, + from = range[1], + to = range[2], + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + bounds = bounds + ) density$flipped_aes <- flipped_aes flip_data(density, flipped_aes) } @@ -77,13 +107,23 @@ StatDensity <- ggproto( #' @export #' @rdname geom_density stat_density <- make_constructor( - StatDensity, geom = "area", position = "stack", + StatDensity, + geom = "area", + position = "stack", orientation = NA ) -compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, - kernel = "gaussian", n = 512, - bounds = c(-Inf, Inf)) { +compute_density <- function( + x, + w, + from, + to, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + bounds = c(-Inf, Inf) +) { nx <- w_sum <- length(x) if (is.null(w)) { w <- rep(1 / nx, nx) @@ -119,32 +159,48 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, if (any(is.finite(bounds))) { # To prevent discontinuities, we widen the range before calling the # unbounded estimator (#5641). - bounds <- sort(bounds) - range <- range(from, to) - width <- diff(range) + bounds <- sort(bounds) + range <- range(from, to) + width <- diff(range) range[1] <- range[1] - width * as.numeric(is.finite(bounds[1])) range[2] <- range[2] + width * as.numeric(is.finite(bounds[2])) n <- n * (sum(is.finite(bounds)) + 1) dens <- stats::density( - x, weights = w, bw = bw, adjust = adjust, - kernel = kernel, n = n, from = range[1], to = range[2] + x, + weights = w, + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + from = range[1], + to = range[2] ) dens <- reflect_density( - dens = dens, bounds = bounds, - from = range[1], to = range[2] + dens = dens, + bounds = bounds, + from = range[1], + to = range[2] ) } else { - dens <- stats::density(x, weights = w, bw = bw, adjust = adjust, - kernel = kernel, n = n, from = from, to = to) + dens <- stats::density( + x, + weights = w, + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + from = from, + to = to + ) } data_frame0( x = dens$x, density = dens$y, - scaled = dens$y / max(dens$y, na.rm = TRUE), + scaled = dens$y / max(dens$y, na.rm = TRUE), ndensity = dens$y / max(dens$y, na.rm = TRUE), - count = dens$y * nx, + count = dens$y * nx, wdensity = dens$y * w_sum, n = nx, .size = length(dens$x) @@ -189,7 +245,11 @@ reflect_density <- function(dens, bounds, from, to) { # Estimate linearly with zero tails (crucial to account for infinite bound) f_dens <- stats::approxfun( - x = dens$x, y = dens$y, method = "linear", yleft = 0, yright = 0 + x = dens$x, + y = dens$y, + method = "linear", + yleft = 0, + yright = 0 ) # Create a uniform x-grid inside `bounds` @@ -212,14 +272,17 @@ precompute_bw <- function(x, bw = "nrd0") { bw <- bw[1] if (is.character(bw)) { bw <- to_lower_ascii(bw) - bw <- arg_match0(bw, c("nrd0", "nrd", "ucv", "bcv", "sj", "sj-ste", "sj-dpi")) + bw <- arg_match0( + bw, + c("nrd0", "nrd", "ucv", "bcv", "sj", "sj-ste", "sj-dpi") + ) bw <- switch( to_lower_ascii(bw), nrd0 = stats::bw.nrd0(x), - nrd = stats::bw.nrd(x), - ucv = stats::bw.ucv(x), - bcv = stats::bw.bcv(x), - sj = , + nrd = stats::bw.nrd(x), + ucv = stats::bw.ucv(x), + bcv = stats::bw.bcv(x), + sj = , `sj-ste` = stats::bw.SJ(x, method = "ste"), `sj-dpi` = stats::bw.SJ(x, method = "dpi") ) diff --git a/R/stat-ecdf.R b/R/stat-ecdf.R index 6d1084d719..3167c69934 100644 --- a/R/stat-ecdf.R +++ b/R/stat-ecdf.R @@ -3,24 +3,38 @@ #' @usage NULL #' @export StatEcdf <- ggproto( - "StatEcdf", Stat, + "StatEcdf", + Stat, required_aes = c("x|y"), default_aes = aes(x = after_stat(ecdf), y = after_stat(ecdf), weight = NULL), setup_params = function(self, data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = FALSE, + main_is_continuous = TRUE + ) has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.") + cli::cli_abort( + "{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic." + ) } params }, - compute_group = function(data, scales, n = NULL, pad = TRUE, flipped_aes = FALSE) { + compute_group = function( + data, + scales, + n = NULL, + pad = TRUE, + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) # If n is NULL, use raw values; otherwise interpolate if (is.null(n)) { @@ -115,7 +129,6 @@ stat_ecdf <- make_constructor(StatEcdf, geom = "step") # Weighted eCDF function wecdf <- function(x, weights = NULL) { - weights <- weights %||% 1 weights <- vec_recycle(weights, length(x)) @@ -125,10 +138,13 @@ wecdf <- function(x, weights = NULL) { weights <- weights[ord] if (!all(is.finite(weights))) { - cli::cli_warn(c(paste0( - "The {.field weight} aesthetic does not support non-finite or ", - "{.code NA} values." - ), "i" = "These weights were replaced by {.val 0}.")) + cli::cli_warn(c( + paste0( + "The {.field weight} aesthetic does not support non-finite or ", + "{.code NA} values." + ), + "i" = "These weights were replaced by {.val 0}." + )) weights[!is.finite(weights)] <- 0 } @@ -156,7 +172,8 @@ wecdf <- function(x, weights = NULL) { # we sum weights per unique value of `x` agg_weights <- vapply( split(weights, matched), - sum, numeric(1) + sum, + numeric(1) ) # Like `ecdf(x)`, we return an approx function @@ -164,7 +181,9 @@ wecdf <- function(x, weights = NULL) { vals, cumsum(agg_weights) / total, method = "constant", - yleft = 0, yright = 1, - f = 0, ties = "ordered" + yleft = 0, + yright = 1, + f = 0, + ties = "ordered" ) } diff --git a/R/stat-ellipse.R b/R/stat-ellipse.R index dfd8c698d3..097dc99789 100644 --- a/R/stat-ellipse.R +++ b/R/stat-ellipse.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatEllipse <- ggproto( - "StatEllipse", Stat, + "StatEllipse", + Stat, required_aes = c("x", "y"), optional_aes = "weight", dropped_aes = "weight", @@ -16,10 +17,21 @@ StatEllipse <- ggproto( params }, - compute_group = function(data, scales, type = "t", level = 0.95, - segments = 51, na.rm = FALSE) { - calculate_ellipse(data = data, vars = c("x", "y"), type = type, - level = level, segments = segments) + compute_group = function( + data, + scales, + type = "t", + level = 0.95, + segments = 51, + na.rm = FALSE + ) { + calculate_ellipse( + data = data, + vars = c("x", "y"), + type = type, + level = level, + segments = segments + ) } ) @@ -71,7 +83,7 @@ StatEllipse <- ggproto( #' stat_ellipse(geom = "polygon") stat_ellipse <- make_constructor(StatEllipse, geom = "path") -calculate_ellipse <- function(data, vars, type, level, segments){ +calculate_ellipse <- function(data, vars, type, level, segments) { dfn <- 2 dfd <- nrow(data) - 1 @@ -87,22 +99,22 @@ calculate_ellipse <- function(data, vars, type, level, segments){ } else { if (type == "t") { # Prone to convergence problems when `sum(weight) != nrow(data)` - v <- MASS::cov.trob(data[,vars], wt = weight * nrow(data)) + v <- MASS::cov.trob(data[, vars], wt = weight * nrow(data)) } else if (type == "norm") { - v <- stats::cov.wt(data[,vars], wt = weight) + v <- stats::cov.wt(data[, vars], wt = weight) } else if (type == "euclid") { - v <- stats::cov.wt(data[,vars], wt = weight) + v <- stats::cov.wt(data[, vars], wt = weight) v$cov <- diag(rep(min(diag(v$cov)), 2)) } shape <- v$cov center <- v$center chol_decomp <- chol(shape) if (type == "euclid") { - radius <- level/max(chol_decomp) + radius <- level / max(chol_decomp) } else { radius <- sqrt(dfn * stats::qf(level, dfn, dfd)) } - angles <- (0:segments) * 2 * pi/segments + angles <- (0:segments) * 2 * pi / segments unit.circle <- cbind(cos(angles), sin(angles)) ellipse <- t(center + radius * t(unit.circle %*% chol_decomp)) } diff --git a/R/stat-function.R b/R/stat-function.R index 0394e44a17..2ba299e386 100644 --- a/R/stat-function.R +++ b/R/stat-function.R @@ -3,10 +3,18 @@ #' @usage NULL #' @export StatFunction <- ggproto( - "StatFunction", Stat, + "StatFunction", + Stat, default_aes = aes(x = NULL, y = after_scale(y)), - compute_group = function(data, scales, fun, xlim = NULL, n = 101, args = list()) { + compute_group = function( + data, + scales, + fun, + xlim = NULL, + n = 101, + args = list() + ) { if (is.null(scales$x)) { range <- xlim %||% c(0, 1) xseq <- seq(range[1], range[2], length.out = n) @@ -24,7 +32,9 @@ StatFunction <- ggproto( } } - if (is_formula(fun)) fun <- as_function(fun) + if (is_formula(fun)) { + fun <- as_function(fun) + } y_out <- inject(fun(x_trans, !!!args)) if (!is.null(scales$y) && !scales$y$is_discrete()) { @@ -51,7 +61,9 @@ StatFunction <- ggproto( #' @export #' @rdname geom_function stat_function <- make_constructor( - StatFunction, geom = "function", fun = , + StatFunction, + geom = "function", + fun = , checks = exprs(data <- data %||% ensure_nonempty_data) ) diff --git a/R/stat-identity.R b/R/stat-identity.R index bf71163a9d..81da7845b2 100644 --- a/R/stat-identity.R +++ b/R/stat-identity.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatIdentity <- ggproto( - "StatIdentity", Stat, + "StatIdentity", + Stat, compute_layer = function(self, data, params, layout) { data } diff --git a/R/stat-manual.R b/R/stat-manual.R index d7ead2f189..5ea25e7d3e 100644 --- a/R/stat-manual.R +++ b/R/stat-manual.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatManual <- ggproto( - "StatManual", Stat, + "StatManual", + Stat, setup_params = function(data, params) { params[["fun"]] <- allow_lambda(params[["fun"]]) diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index cab5230621..0ff1bfea1e 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -3,22 +3,24 @@ #' @usage NULL #' @export StatQqLine <- ggproto( - "StatQqLine", Stat, + "StatQqLine", + Stat, default_aes = aes(x = after_stat(x), y = after_stat(y)), required_aes = c("sample"), dropped_aes = c("sample"), - compute_group = function(data, - scales, - quantiles = NULL, - distribution = stats::qnorm, - dparams = list(), - na.rm = FALSE, - line.p = c(0.25, 0.75), - fullrange = FALSE) { - + compute_group = function( + data, + scales, + quantiles = NULL, + distribution = stats::qnorm, + dparams = list(), + na.rm = FALSE, + line.p = c(0.25, 0.75), + fullrange = FALSE + ) { sample <- sort(data$sample) n <- length(sample) @@ -32,7 +34,9 @@ StatQqLine <- ggproto( theoretical <- inject(distribution(p = quantiles, !!!dparams)) if (length(line.p) != 2) { - cli::cli_abort("Cannot fit line quantiles {line.p}. {.arg line.p} must have length 2.") + cli::cli_abort( + "Cannot fit line quantiles {line.p}. {.arg line.p} must have length 2." + ) } x_coords <- inject(distribution(p = line.p, !!!dparams)) @@ -47,8 +51,10 @@ StatQqLine <- ggproto( } data_frame0( - x = x, y = slope * x + intercept, - slope = slope, intercept = intercept + x = x, + y = slope * x + intercept, + slope = slope, + intercept = intercept ) } ) @@ -59,7 +65,11 @@ StatQqLine <- ggproto( #' defaults to `c(.25, .75)`. #' @param fullrange Should the q-q line span the full range of the plot, or just #' the data -geom_qq_line <- make_constructor(StatQqLine, geom = "abline", omit = "quantiles") +geom_qq_line <- make_constructor( + StatQqLine, + geom = "abline", + omit = "quantiles" +) #' @export #' @rdname geom_qq diff --git a/R/stat-qq.R b/R/stat-qq.R index b97796bd78..a44c7b4856 100644 --- a/R/stat-qq.R +++ b/R/stat-qq.R @@ -3,15 +3,21 @@ #' @usage NULL #' @export StatQq <- ggproto( - "StatQq", Stat, + "StatQq", + Stat, default_aes = aes(y = after_stat(sample), x = after_stat(theoretical)), required_aes = c("sample"), - compute_group = function(self, data, scales, quantiles = NULL, - distribution = stats::qnorm, dparams = list(), - na.rm = FALSE) { - + compute_group = function( + self, + data, + scales, + quantiles = NULL, + distribution = stats::qnorm, + dparams = list(), + na.rm = FALSE + ) { sample <- sort(data$sample) n <- length(sample) @@ -19,7 +25,9 @@ StatQq <- ggproto( if (is.null(quantiles)) { quantiles <- stats::ppoints(n) } else if (length(quantiles) != n) { - cli::cli_abort("The length of {.arg quantiles} must match the length of the data.") + cli::cli_abort( + "The length of {.arg quantiles} must match the length of the data." + ) } theoretical <- inject(distribution(p = quantiles, !!!dparams)) diff --git a/R/stat-quantilemethods.R b/R/stat-quantilemethods.R index 4999aa7304..5e8597792a 100644 --- a/R/stat-quantilemethods.R +++ b/R/stat-quantilemethods.R @@ -3,12 +3,21 @@ #' @usage NULL #' @export StatQuantile <- ggproto( - "StatQuantile", Stat, + "StatQuantile", + Stat, required_aes = c("x", "y"), - compute_group = function(data, scales, quantiles = c(0.25, 0.5, 0.75), - formula = NULL, xseq = NULL, method = "rq", - method.args = list(), lambda = 1, na.rm = FALSE) { + compute_group = function( + data, + scales, + quantiles = c(0.25, 0.5, 0.75), + formula = NULL, + xseq = NULL, + method = "rq", + method.args = list(), + lambda = 1, + na.rm = FALSE + ) { check_installed("quantreg", reason = "for `stat_quantile()`.") if (is.null(formula)) { @@ -23,10 +32,14 @@ StatQuantile <- ggproto( } else { formula <- y ~ x } - cli::cli_inform("Smoothing formula not specified. Using: {deparse(formula)}") + cli::cli_inform( + "Smoothing formula not specified. Using: {deparse(formula)}" + ) } - if (is.null(data$weight)) data$weight <- 1 + if (is.null(data$weight)) { + data$weight <- 1 + } if (is.null(xseq)) { xmin <- min(data$x, na.rm = TRUE) @@ -74,12 +87,20 @@ StatQuantile <- ggproto( #' @export #' @rdname geom_quantile stat_quantile <- make_constructor( - StatQuantile, geom = "quantile", + StatQuantile, + geom = "quantile", omit = c("xseq", "lambda") ) -quant_pred <- function(quantile, data, method, formula, weight, grid, - method.args = method.args) { +quant_pred <- function( + quantile, + data, + method, + formula, + weight, + grid, + method.args = method.args +) { model <- inject(method( formula, data = data, diff --git a/R/stat-sf-coordinates.R b/R/stat-sf-coordinates.R index b54c8f6376..f2b5dba692 100644 --- a/R/stat-sf-coordinates.R +++ b/R/stat-sf-coordinates.R @@ -56,11 +56,17 @@ #' will be used. Note that the function may warn about the incorrectness of #' the result if the data is not projected, but you can ignore this except #' when you really care about the exact locations. -stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point", - position = "identity", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE, - fun.geometry = NULL, - ...) { +stat_sf_coordinates <- function( + mapping = aes(), + data = NULL, + geom = "point", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + fun.geometry = NULL, + ... +) { layer_sf( stat = StatSfCoordinates, data = data, @@ -82,7 +88,8 @@ stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point", #' @format NULL #' @export StatSfCoordinates <- ggproto( - "StatSfCoordinates", Stat, + "StatSfCoordinates", + Stat, compute_layer = function(self, data, params, layout) { # add coord to the params, so it can be forwarded to compute_group() @@ -102,14 +109,19 @@ StatSfCoordinates <- ggproto( bbox <- sf::st_bbox(points_sfc) coord$record_bbox( - xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], - ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] + xmin = bbox[["xmin"]], + xmax = bbox[["xmax"]], + ymin = bbox[["ymin"]], + ymax = bbox[["ymax"]] ) # transform to the coord's default crs if possible default_crs <- coord$get_default_crs() - if (!(is.null(default_crs) || is.na(default_crs) || - is.na(sf::st_crs(points_sfc)))) { + if ( + !(is.null(default_crs) || + is.na(default_crs) || + is.na(sf::st_crs(points_sfc))) + ) { points_sfc <- sf::st_transform(points_sfc, default_crs) } } diff --git a/R/stat-sf.R b/R/stat-sf.R index cf0b55c0ec..0155590d91 100644 --- a/R/stat-sf.R +++ b/R/stat-sf.R @@ -2,7 +2,9 @@ #' @rdname ggsf #' @usage NULL #' @format NULL -StatSf <- ggproto("StatSf", Stat, +StatSf <- ggproto( + "StatSf", + Stat, compute_layer = function(self, data, params, layout) { # add coord to the params, so it can be forwarded to compute_group() params$coord <- layout$coord @@ -10,7 +12,7 @@ StatSf <- ggproto("StatSf", Stat, }, compute_panel = function(data, scales, coord) { - geometry_data <- data[[ geom_column(data) ]] + geometry_data <- data[[geom_column(data)]] geometry_crs <- sf::st_crs(geometry_data) bbox <- sf::st_bbox(geometry_data) @@ -19,8 +21,10 @@ StatSf <- ggproto("StatSf", Stat, # if the coord derives from CoordSf, then it # needs to know about bounding boxes of geometry data coord$record_bbox( - xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], - ymin = bbox[["ymin"]], ymax = bbox[["ymax"]] + xmin = bbox[["xmin"]], + xmax = bbox[["xmax"]], + ymin = bbox[["ymin"]], + ymax = bbox[["ymax"]] ) # to represent the location of the geometry in default coordinates, @@ -28,8 +32,16 @@ StatSf <- ggproto("StatSf", Stat, # backtransform bbox_trans <- sf_transform_xy( list( - x = c(rep(0.5*(bbox[["xmin"]] + bbox[["xmax"]]), 2), bbox[["xmin"]], bbox[["xmax"]]), - y = c(bbox[["ymin"]], bbox[["ymax"]], rep(0.5*(bbox[["ymin"]] + bbox[["ymax"]]), 2)) + x = c( + rep(0.5 * (bbox[["xmin"]] + bbox[["xmax"]]), 2), + bbox[["xmin"]], + bbox[["xmax"]] + ), + y = c( + bbox[["ymin"]], + bbox[["ymax"]], + rep(0.5 * (bbox[["ymin"]] + bbox[["ymax"]]), 2) + ) ), coord$get_default_crs(), geometry_crs @@ -59,9 +71,16 @@ StatSf <- ggproto("StatSf", Stat, #' @export #' @rdname ggsf #' @inheritParams stat_identity -stat_sf <- function(mapping = NULL, data = NULL, geom = "rect", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, ...) { +stat_sf <- function( + mapping = NULL, + data = NULL, + geom = "rect", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + ... +) { layer_sf( stat = StatSf, data = data, @@ -76,4 +95,3 @@ stat_sf <- function(mapping = NULL, data = NULL, geom = "rect", ) ) } - diff --git a/R/stat-smooth.R b/R/stat-smooth.R index 4b3499217e..fc1a0f9f45 100644 --- a/R/stat-smooth.R +++ b/R/stat-smooth.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatSmooth <- ggproto( - "StatSmooth", Stat, + "StatSmooth", + Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) msg <- character() @@ -22,8 +23,10 @@ StatSmooth <- ggproto( msg <- c(msg, paste0("method = '", method, "'")) } - if (identical(method, "gam") && - !prompt_install("mgcv", "for using {.code method = \"gam\"}")) { + if ( + identical(method, "gam") && + !prompt_install("mgcv", "for using {.code method = \"gam\"}") + ) { cli::cli_inform(c( "The {.arg method} was set to {.val gam}, but {.pkg mgcv} is not installed.", "!" = "Falling back to {.code method = \"lm\"}.", @@ -56,7 +59,8 @@ StatSmooth <- ggproto( } # If gam and gam's method is not specified by the user then use REML if (identical(method, gam_method())) { - params$method.args[["method"]] <- params$method.args[["method"]] %||% "REML" + params$method.args[["method"]] <- params$method.args[["method"]] %||% + "REML" } if (length(msg) > 0) { @@ -69,17 +73,30 @@ StatSmooth <- ggproto( extra_params = c("na.rm", "orientation"), - compute_group = function(data, scales, method = NULL, formula = NULL, - se = TRUE, n = 80, span = 0.75, fullrange = FALSE, - xseq = NULL, level = 0.95, method.args = list(), - na.rm = FALSE, flipped_aes = NA) { + compute_group = function( + data, + scales, + method = NULL, + formula = NULL, + se = TRUE, + n = 80, + span = 0.75, + fullrange = FALSE, + xseq = NULL, + level = 0.95, + method.args = list(), + na.rm = FALSE, + flipped_aes = NA + ) { data <- flip_data(data, flipped_aes) if (vec_unique_count(data$x) < 2) { # Not enough data to perform fit return(data_frame0()) } - if (is.null(data$weight)) data$weight <- 1 + if (is.null(data$weight)) { + data$weight <- 1 + } if (is.null(xseq)) { if (is.integer(data$x)) { diff --git a/R/stat-sum.R b/R/stat-sum.R index c764cbc14f..b54e23522c 100644 --- a/R/stat-sum.R +++ b/R/stat-sum.R @@ -3,15 +3,21 @@ #' @usage NULL #' @export StatSum <- ggproto( - "StatSum", Stat, + "StatSum", + Stat, default_aes = aes(size = after_stat(n), weight = 1), required_aes = c("x", "y"), compute_panel = function(data, scales) { - if (is.null(data$weight)) data$weight <- 1 + if (is.null(data$weight)) { + data$weight <- 1 + } - group_by <- setdiff(intersect(names(data), ggplot_global$all_aesthetics), "weight") + group_by <- setdiff( + intersect(names(data), ggplot_global$all_aesthetics), + "weight" + ) counts <- count(data, group_by, wt_var = "weight") counts <- rename(counts, c(freq = "n")) diff --git a/R/stat-summary-2d.R b/R/stat-summary-2d.R index 847cb68bfc..ddcb970f7b 100644 --- a/R/stat-summary-2d.R +++ b/R/stat-summary-2d.R @@ -3,14 +3,14 @@ #' @usage NULL #' @export StatSummary2d <- ggproto( - "StatSummary2d", Stat, + "StatSummary2d", + Stat, default_aes = aes(fill = after_stat(value)), required_aes = c("x", "y", "z"), dropped_aes = "z", # z gets dropped during statistical transformation setup_params = function(self, data, params) { - if (is.character(params$drop)) { params$drop <- !identical(params$drop, "none") } @@ -25,19 +25,40 @@ StatSummary2d <- ggproto( extra_params = c("na.rm", "origin"), - compute_group = function(data, scales, binwidth = NULL, bins = 30, - breaks = NULL, drop = TRUE, - fun = "mean", fun.args = list(), - boundary = 0, closed = NULL, center = NULL) { + compute_group = function( + data, + scales, + binwidth = NULL, + bins = 30, + breaks = NULL, + drop = TRUE, + fun = "mean", + fun.args = list(), + boundary = 0, + closed = NULL, + center = NULL + ) { bins <- dual_param(bins, list(x = 30, y = 30)) xbin <- compute_bins( - data$x, scales$x, breaks$x, binwidth$x, bins$x, - center$x, boundary$x, closed$x + data$x, + scales$x, + breaks$x, + binwidth$x, + bins$x, + center$x, + boundary$x, + closed$x ) ybin <- compute_bins( - data$y, scales$y, breaks$y, binwidth$y, bins$y, - center$y, boundary$y, closed$y + data$y, + scales$y, + breaks$y, + binwidth$y, + bins$y, + center$y, + boundary$y, + closed$y ) cut_id <- list( xbin = as.integer(bin_cut(data$x, xbin)), diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index d86936163a..0b2489be64 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -3,34 +3,46 @@ #' @param breaks Alternatively, you can supply a numeric vector giving the bin #' boundaries. Overrides `binwidth` and `bins`. #' @export -stat_summary_bin <- function(mapping = NULL, data = NULL, - geom = "pointrange", position = "identity", - ..., - fun.data = NULL, - fun = NULL, - fun.max = NULL, - fun.min = NULL, - fun.args = list(), - bins = 30, - binwidth = NULL, - breaks = NULL, - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE, - fun.y = deprecated(), - fun.ymin = deprecated(), - fun.ymax = deprecated()) { +stat_summary_bin <- function( + mapping = NULL, + data = NULL, + geom = "pointrange", + position = "identity", + ..., + fun.data = NULL, + fun = NULL, + fun.max = NULL, + fun.min = NULL, + fun.args = list(), + bins = 30, + binwidth = NULL, + breaks = NULL, + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE, + fun.y = deprecated(), + fun.ymin = deprecated(), + fun.ymax = deprecated() +) { if (lifecycle::is_present(fun.y)) { deprecate_warn0("3.3.0", "stat_summary_bin(fun.y)", "stat_summary_bin(fun)") fun <- fun %||% fun.y } if (lifecycle::is_present(fun.ymin)) { - deprecate_warn0("3.3.0", "stat_summary_bin(fun.ymin)", "stat_summary_bin(fun.min)") + deprecate_warn0( + "3.3.0", + "stat_summary_bin(fun.ymin)", + "stat_summary_bin(fun.min)" + ) fun.min <- fun.min %||% fun.ymin } if (lifecycle::is_present(fun.ymax)) { - deprecate_warn0("3.3.0", "stat_summary_bin(fun.ymax)", "stat_summary_bin(fun.max)") + deprecate_warn0( + "3.3.0", + "stat_summary_bin(fun.ymax)", + "stat_summary_bin(fun.max)" + ) fun.max <- fun.max %||% fun.ymax } layer( @@ -61,32 +73,58 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -StatSummaryBin <- ggproto("StatSummaryBin", Stat, +StatSummaryBin <- ggproto( + "StatSummaryBin", + Stat, required_aes = c("x", "y"), - extra_params = c("na.rm", "orientation", "fun.data", "fun.max", "fun.min", "fun.args"), + extra_params = c( + "na.rm", + "orientation", + "fun.data", + "fun.max", + "fun.min", + "fun.args" + ), setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params) params[["fun"]] <- make_summary_fun( - params$fun.data, params[["fun"]], - params$fun.max, params$fun.min, + params$fun.data, + params[["fun"]], + params$fun.max, + params$fun.min, params$fun.args %||% list() ) params }, - compute_group = function(data, scales, fun = NULL, - bins = 30, binwidth = NULL, breaks = NULL, - origin = NULL, right = FALSE, na.rm = FALSE, - flipped_aes = FALSE, width = NULL, center = NULL, - boundary = NULL, closed = c("right", "left")) { - + compute_group = function( + data, + scales, + fun = NULL, + bins = 30, + binwidth = NULL, + breaks = NULL, + origin = NULL, + right = FALSE, + na.rm = FALSE, + flipped_aes = FALSE, + width = NULL, + center = NULL, + boundary = NULL, + closed = c("right", "left") + ) { x <- flipped_names(flipped_aes)$x bins <- compute_bins( - data[[x]], scales[[x]], - breaks = breaks, binwidth = binwidth, bins = bins, - center = center, boundary = boundary, closed = closed + data[[x]], + scales[[x]], + breaks = breaks, + binwidth = binwidth, + bins = bins, + center = center, + boundary = boundary, + closed = closed ) data$bin <- bin_cut(data[[x]], bins) @@ -125,7 +163,9 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { # Three functions that take vectors as inputs call_f <- function(fun, x) { - if (is.null(fun)) return(NA_real_) + if (is.null(fun)) { + return(NA_real_) + } fun <- as_function(fun) inject(fun(x, !!!fun.args)) } diff --git a/R/stat-summary-hex.R b/R/stat-summary-hex.R index 8917e99887..974b68d453 100644 --- a/R/stat-summary-hex.R +++ b/R/stat-summary-hex.R @@ -3,21 +3,36 @@ #' @usage NULL #' @export StatSummaryHex <- ggproto( - "StatSummaryHex", Stat, + "StatSummaryHex", + Stat, default_aes = aes(fill = after_stat(value)), required_aes = c("x", "y", "z"), dropped_aes = "z", # z gets dropped during statistical transformation - compute_group = function(data, scales, binwidth = NULL, bins = 30, drop = TRUE, - fun = "mean", fun.args = list()) { + compute_group = function( + data, + scales, + binwidth = NULL, + bins = 30, + drop = TRUE, + fun = "mean", + fun.args = list() + ) { check_installed("hexbin", reason = "for `stat_summary_hex()`.") binwidth <- binwidth %||% hex_binwidth(bins, scales) fun <- as_function(fun) - hexBinSummarise(data$x, data$y, data$z, binwidth, - fun = fun, fun.args = fun.args, drop = drop) + hexBinSummarise( + data$x, + data$y, + data$z, + binwidth, + fun = fun, + fun.args = fun.args, + drop = drop + ) } ) diff --git a/R/stat-summary.R b/R/stat-summary.R index 789f867da9..c310c35c4a 100644 --- a/R/stat-summary.R +++ b/R/stat-summary.R @@ -126,21 +126,25 @@ #' m2 + coord_transform(y="log10") #' } #' } -stat_summary <- function(mapping = NULL, data = NULL, - geom = "pointrange", position = "identity", - ..., - fun.data = NULL, - fun = NULL, - fun.max = NULL, - fun.min = NULL, - fun.args = list(), - na.rm = FALSE, - orientation = NA, - show.legend = NA, - inherit.aes = TRUE, - fun.y = deprecated(), - fun.ymin = deprecated(), - fun.ymax = deprecated()) { +stat_summary <- function( + mapping = NULL, + data = NULL, + geom = "pointrange", + position = "identity", + ..., + fun.data = NULL, + fun = NULL, + fun.max = NULL, + fun.min = NULL, + fun.args = list(), + na.rm = FALSE, + orientation = NA, + show.legend = NA, + inherit.aes = TRUE, + fun.y = deprecated(), + fun.ymin = deprecated(), + fun.ymax = deprecated() +) { if (lifecycle::is_present(fun.y)) { deprecate_warn0("3.3.0", "stat_summary(fun.y)", "stat_summary(fun)") fun <- fun %||% fun.y @@ -178,23 +182,39 @@ stat_summary <- function(mapping = NULL, data = NULL, #' @format NULL #' @usage NULL #' @export -StatSummary <- ggproto("StatSummary", Stat, +StatSummary <- ggproto( + "StatSummary", + Stat, required_aes = c("x", "y"), - extra_params = c("na.rm", "orientation", "fun.data", "fun.max", "fun.min", "fun.args"), + extra_params = c( + "na.rm", + "orientation", + "fun.data", + "fun.max", + "fun.min", + "fun.args" + ), setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params) params[["fun"]] <- make_summary_fun( - params$fun.data, params[["fun"]], - params$fun.max, params$fun.min, + params$fun.data, + params[["fun"]], + params$fun.max, + params$fun.min, params$fun.args %||% list() ) params }, - compute_panel = function(data, scales, fun = NULL, - na.rm = FALSE, flipped_aes = FALSE) { + compute_panel = function( + data, + scales, + fun = NULL, + na.rm = FALSE, + flipped_aes = FALSE + ) { data <- flip_data(data, flipped_aes) summarised <- summarise_by_x(data, fun %||% function(df) mean_se(df$y)) summarised$flipped_aes <- flipped_aes @@ -260,7 +280,6 @@ uniquecols <- function(df) { NULL wrap_hmisc <- function(fun) { - function(x, ...) { check_installed("Hmisc") diff --git a/R/stat-unique.R b/R/stat-unique.R index 0fa45cf5eb..4ee535f408 100644 --- a/R/stat-unique.R +++ b/R/stat-unique.R @@ -3,7 +3,8 @@ #' @usage NULL #' @export StatUnique <- ggproto( - "StatUnique", Stat, + "StatUnique", + Stat, compute_panel = function(data, scales) { unique0(data) } diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 969723ebd4..747740de9b 100644 --- a/R/stat-ydensity.R +++ b/R/stat-ydensity.R @@ -3,12 +3,18 @@ #' @usage NULL #' @export StatYdensity <- ggproto( - "StatYdensity", Stat, + "StatYdensity", + Stat, required_aes = c("x", "y"), non_missing_aes = "weight", setup_params = function(data, params) { - params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) + params$flipped_aes <- has_flipped_aes( + data, + params, + main_is_orthogonal = TRUE, + group_has_equal = TRUE + ) if (!is.null(params$draw_quantiles)) { deprecate_soft0( @@ -26,10 +32,21 @@ StatYdensity <- ggproto( # `draw_quantiles` is here for deprecation repair reasons extra_params = c("na.rm", "orientation", "draw_quantiles"), - compute_group = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, - kernel = "gaussian", trim = TRUE, na.rm = FALSE, - drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf), - quantiles = c(0.25, 0.50, 0.75)) { + compute_group = function( + self, + data, + scales, + width = NULL, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + trim = TRUE, + na.rm = FALSE, + drop = TRUE, + flipped_aes = FALSE, + bounds = c(-Inf, Inf), + quantiles = c(0.25, 0.50, 0.75) + ) { if (nrow(data) < 2) { if (isTRUE(drop)) { cli::cli_warn(c( @@ -37,7 +54,8 @@ StatYdensity <- ggproto( i = paste0( "Set {.code drop = FALSE} to consider such groups for position ", "adjustment purposes." - ))) + ) + )) return(data_frame0()) } ans <- data_frame0(x = data$x, n = nrow(data)) @@ -47,9 +65,14 @@ StatYdensity <- ggproto( modifier <- if (trim) 0 else 3 bw <- calc_bw(data$y, bw) dens <- compute_density( - data$y, data[["weight"]], - from = range[1] - modifier * bw, to = range[2] + modifier * bw, - bw = bw, adjust = adjust, kernel = kernel, bounds = bounds + data$y, + data[["weight"]], + from = range[1] - modifier * bw, + to = range[2] + modifier * bw, + bw = bw, + adjust = adjust, + kernel = kernel, + bounds = bounds ) dens$y <- dens$x @@ -92,14 +115,34 @@ StatYdensity <- ggproto( dens }, - compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, - kernel = "gaussian", trim = TRUE, na.rm = FALSE, - scale = "area", flipped_aes = FALSE, drop = TRUE, - bounds = c(-Inf, Inf), quantiles = c(0.25, 0.50, 0.75)) { + compute_panel = function( + self, + data, + scales, + width = NULL, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + trim = TRUE, + na.rm = FALSE, + scale = "area", + flipped_aes = FALSE, + drop = TRUE, + bounds = c(-Inf, Inf), + quantiles = c(0.25, 0.50, 0.75) + ) { data <- flip_data(data, flipped_aes) data <- ggproto_parent(Stat, self)$compute_panel( - data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel, - trim = trim, na.rm = na.rm, drop = drop, bounds = bounds, + data, + scales, + width = width, + bw = bw, + adjust = adjust, + kernel = kernel, + trim = trim, + na.rm = na.rm, + drop = drop, + bounds = bounds, quantiles = quantiles ) if (!drop && any(data[["n"]] < 2)) { @@ -116,8 +159,10 @@ StatYdensity <- ggproto( area = data$density / max(data$density, na.rm = TRUE), # count: use the original densities scaled to a maximum of 1 (as above) # and then scale them according to the number of observations - count = data$density / max(data$density, na.rm = TRUE) * - data[["n"]] / max(data[["n"]]), + count = data$density / + max(data$density, na.rm = TRUE) * + data[["n"]] / + max(data[["n"]]), # width: constant width (density scaled to a maximum of 1) width = data$scaled ) @@ -157,15 +202,20 @@ StatYdensity <- ggproto( #' @export #' @rdname geom_violin stat_ydensity <- make_constructor( - StatYdensity, geom = "violin", position = "dodge", + StatYdensity, + geom = "violin", + position = "dodge", checks = exprs(scale <- arg_match0(scale, c("area", "count", "width"))), - orientation = NA, omit = "width" + orientation = NA, + omit = "width" ) calc_bw <- function(x, bw) { if (is.character(bw)) { if (length(x) < 2) { - cli::cli_abort("{.arg x} must contain at least 2 elements to select a bandwidth automatically.") + cli::cli_abort( + "{.arg x} must contain at least 2 elements to select a bandwidth automatically." + ) } bw <- switch( diff --git a/R/summarise-plot.R b/R/summarise-plot.R index 87b8927777..d54cf7cd06 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -68,8 +68,8 @@ summarise_layout <- function(p) { layout <- l$layout layout <- data_frame0( panel = l$layout$PANEL, - row = l$layout$ROW, - col = l$layout$COL + row = l$layout$ROW, + col = l$layout$COL ) # layout data frame has columns named for facet vars; rename them so we don't diff --git a/R/summary.R b/R/summary.R index 8c3d252906..1a58d92577 100644 --- a/R/summary.R +++ b/R/summary.R @@ -12,16 +12,26 @@ #' geom_point() #' summary(p) S7::method(summary, class_ggplot) <- function(object, ...) { - wrap <- function(x) paste( - paste(strwrap(x, exdent = 2), collapse = "\n"), - "\n", sep = "" + wrap <- function(x) { + paste( + paste(strwrap(x, exdent = 2), collapse = "\n"), + "\n", + sep = "" ) + } if (!is.null(object@data)) { output <- paste( - "data: ", paste(names(object@data), collapse = ", "), - " [", nrow(object@data), "x", ncol(object@data), "] ", - "\n", sep = "") + "data: ", + paste(names(object@data), collapse = ", "), + " [", + nrow(object@data), + "x", + ncol(object@data), + "] ", + "\n", + sep = "" + ) cat(wrap(output)) } if (length(object@mapping) > 0) { @@ -35,11 +45,11 @@ S7::method(summary, class_ggplot) <- function(object, ...) { vars <- if (length(vars) > 0) paste0("~", vars) else "" cat("faceting: ", paste0(vars, collapse = ", "), "\n") - if (length(object@layers) > 0) + if (length(object@layers) > 0) { cat("-----------------------------------\n") + } invisible(lapply(object@layers, function(x) { print(x) cat("\n") })) - } diff --git a/R/theme-current.R b/R/theme-current.R index e42f8c1e68..4d7bc19761 100644 --- a/R/theme-current.R +++ b/R/theme-current.R @@ -141,4 +141,3 @@ theme_replace <- replace_theme e1 } - diff --git a/R/theme-defaults.R b/R/theme-defaults.R index bc91ba8520..041cd46077 100644 --- a/R/theme-defaults.R +++ b/R/theme-defaults.R @@ -104,12 +104,16 @@ NULL #' @include theme.R #' @export #' @rdname ggtheme -theme_grey <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { - +theme_grey <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { # The half-line (base-fontsize / 2) sets up the basic vertical # rhythm of the theme. Most margins will be set to this value. # However, when we work with relative sizes, we may want to multiply @@ -125,58 +129,97 @@ theme_grey <- function(base_size = 11, base_family = "", t <- theme( # Elements in this first block aren't used directly, but are inherited # by others - line = element_line( - colour = ink, linewidth = base_line_size, - linetype = 1, lineend = "butt", linejoin = "round" - ), - rect = element_rect( - fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1, - linejoin = "round" - ), - text = element_text( - family = base_family, face = "plain", - colour = ink, size = base_size, - lineheight = 0.9, hjust = 0.5, vjust = 0.5, angle = 0, - margin = margin(), debug = FALSE - ), - - title = element_text(family = header_family), + line = element_line( + colour = ink, + linewidth = base_line_size, + linetype = 1, + lineend = "butt", + linejoin = "round" + ), + rect = element_rect( + fill = paper, + colour = ink, + linewidth = base_rect_size, + linetype = 1, + linejoin = "round" + ), + text = element_text( + family = base_family, + face = "plain", + colour = ink, + size = base_size, + lineheight = 0.9, + hjust = 0.5, + vjust = 0.5, + angle = 0, + margin = margin(), + debug = FALSE + ), + + title = element_text(family = header_family), spacing = unit(half_line, "pt"), margins = margin_auto(half_line), - point = element_point( - colour = ink, shape = 19, fill = paper, - size = (base_size / 11) * 1.5, - stroke = base_line_size - ), - - polygon = element_polygon( - fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1, linejoin = "round" - ), - - geom = element_geom( - ink = ink, paper = paper, accent = accent, - linewidth = base_line_size, borderwidth = base_line_size, - linetype = 1L, bordertype = 1L, - family = base_family, fontsize = base_size, - pointsize = (base_size / 11) * 1.5, pointshape = 19 - ), - - axis.line = element_blank(), - axis.line.x = NULL, - axis.line.y = NULL, - axis.text = element_text(size = rel(0.8), colour = col_mix(ink, paper, 0.302)), - axis.text.x = element_text(margin = margin(t = 0.8 * half_line / 2), vjust = 1), - axis.text.x.top = element_text(margin = margin(b = 0.8 * half_line / 2), vjust = 0), - axis.text.y = element_text(margin = margin(r = 0.8 * half_line / 2), hjust = 1), - axis.text.y.right = element_text(margin = margin(l = 0.8 * half_line / 2), hjust = 0), - axis.text.r = element_text(margin = margin(l = 0.8 * half_line / 2, r = 0.8 * half_line / 2), - hjust = 0.5), - axis.ticks = element_line(colour = col_mix(ink, paper, 0.2)), - axis.ticks.length = rel(0.5), + point = element_point( + colour = ink, + shape = 19, + fill = paper, + size = (base_size / 11) * 1.5, + stroke = base_line_size + ), + + polygon = element_polygon( + fill = paper, + colour = ink, + linewidth = base_rect_size, + linetype = 1, + linejoin = "round" + ), + + geom = element_geom( + ink = ink, + paper = paper, + accent = accent, + linewidth = base_line_size, + borderwidth = base_line_size, + linetype = 1L, + bordertype = 1L, + family = base_family, + fontsize = base_size, + pointsize = (base_size / 11) * 1.5, + pointshape = 19 + ), + + axis.line = element_blank(), + axis.line.x = NULL, + axis.line.y = NULL, + axis.text = element_text( + size = rel(0.8), + colour = col_mix(ink, paper, 0.302) + ), + axis.text.x = element_text( + margin = margin(t = 0.8 * half_line / 2), + vjust = 1 + ), + axis.text.x.top = element_text( + margin = margin(b = 0.8 * half_line / 2), + vjust = 0 + ), + axis.text.y = element_text( + margin = margin(r = 0.8 * half_line / 2), + hjust = 1 + ), + axis.text.y.right = element_text( + margin = margin(l = 0.8 * half_line / 2), + hjust = 0 + ), + axis.text.r = element_text( + margin = margin(l = 0.8 * half_line / 2, r = 0.8 * half_line / 2), + hjust = 0.5 + ), + axis.ticks = element_line(colour = col_mix(ink, paper, 0.2)), + axis.ticks.length = rel(0.5), axis.ticks.length.x = NULL, axis.ticks.length.x.top = NULL, axis.ticks.length.x.bottom = NULL, @@ -184,94 +227,107 @@ theme_grey <- function(base_size = 11, base_family = "", axis.ticks.length.y.left = NULL, axis.ticks.length.y.right = NULL, axis.minor.ticks.length = rel(0.75), - axis.title.x = element_text( - margin = margin(t = half_line / 2), - vjust = 1 - ), - axis.title.x.top = element_text( - margin = margin(b = half_line / 2), - vjust = 0 - ), - axis.title.y = element_text( - angle = 90, - margin = margin(r = half_line / 2), - vjust = 1 - ), + axis.title.x = element_text( + margin = margin(t = half_line / 2), + vjust = 1 + ), + axis.title.x.top = element_text( + margin = margin(b = half_line / 2), + vjust = 0 + ), + axis.title.y = element_text( + angle = 90, + margin = margin(r = half_line / 2), + vjust = 1 + ), axis.title.y.right = element_text( - angle = -90, - margin = margin(l = half_line / 2), - vjust = 1 - ), - - legend.background = element_rect(colour = NA), - legend.spacing = rel(2), - legend.spacing.x = NULL, - legend.spacing.y = NULL, - legend.margin = NULL, - legend.key = NULL, - legend.key.size = unit(1.2, "lines"), - legend.key.height = NULL, - legend.key.width = NULL, + angle = -90, + margin = margin(l = half_line / 2), + vjust = 1 + ), + + legend.background = element_rect(colour = NA), + legend.spacing = rel(2), + legend.spacing.x = NULL, + legend.spacing.y = NULL, + legend.margin = NULL, + legend.key = NULL, + legend.key.size = unit(1.2, "lines"), + legend.key.height = NULL, + legend.key.width = NULL, legend.key.spacing = NULL, - legend.text = element_text(size = rel(0.8)), - legend.title = element_text(hjust = 0), + legend.text = element_text(size = rel(0.8)), + legend.title = element_text(hjust = 0), legend.ticks.length = rel(0.2), - legend.position = "right", - legend.direction = NULL, + legend.position = "right", + legend.direction = NULL, legend.justification = "center", - legend.box = NULL, - legend.box.margin = margin_auto(0), + legend.box = NULL, + legend.box.margin = margin_auto(0), legend.box.background = element_blank(), legend.box.spacing = rel(2), - panel.background = element_rect(fill = col_mix(ink, paper, 0.92), colour = NA), - panel.border = element_blank(), - panel.grid = element_line(colour = paper), - panel.grid.minor = element_line(linewidth = rel(0.5)), - panel.spacing = NULL, - panel.spacing.x = NULL, - panel.spacing.y = NULL, - panel.ontop = FALSE, - - strip.background = element_rect(fill = col_mix(ink, paper, 0.85), colour = NA), - strip.clip = "on", - strip.text = element_text( - colour = col_mix(ink, paper, 0.1), - size = rel(0.8), - margin = margin_auto(0.8 * half_line) - ), - strip.text.x = NULL, - strip.text.y = element_text(angle = -90), - strip.text.y.left = element_text(angle = 90), - strip.placement = "inside", - strip.placement.x = NULL, - strip.placement.y = NULL, + panel.background = element_rect( + fill = col_mix(ink, paper, 0.92), + colour = NA + ), + panel.border = element_blank(), + panel.grid = element_line(colour = paper), + panel.grid.minor = element_line(linewidth = rel(0.5)), + panel.spacing = NULL, + panel.spacing.x = NULL, + panel.spacing.y = NULL, + panel.ontop = FALSE, + + strip.background = element_rect( + fill = col_mix(ink, paper, 0.85), + colour = NA + ), + strip.clip = "on", + strip.text = element_text( + colour = col_mix(ink, paper, 0.1), + size = rel(0.8), + margin = margin_auto(0.8 * half_line) + ), + strip.text.x = NULL, + strip.text.y = element_text(angle = -90), + strip.text.y.left = element_text(angle = 90), + strip.placement = "inside", + strip.placement.x = NULL, + strip.placement.y = NULL, strip.switch.pad.grid = unit(half_line / 2, "pt"), strip.switch.pad.wrap = unit(half_line / 2, "pt"), - plot.background = element_rect(colour = paper), - plot.title = element_text( # font size "large" - size = rel(1.2), - hjust = 0, vjust = 1, - margin = margin(b = half_line) - ), + plot.background = element_rect(colour = paper), + plot.title = element_text( + # font size "large" + size = rel(1.2), + hjust = 0, + vjust = 1, + margin = margin(b = half_line) + ), plot.title.position = "panel", - plot.subtitle = element_text( # font size "regular" - hjust = 0, vjust = 1, - margin = margin(b = half_line) - ), - plot.caption = element_text( # font size "small" - size = rel(0.8), - hjust = 1, vjust = 1, - margin = margin(t = half_line) - ), + plot.subtitle = element_text( + # font size "regular" + hjust = 0, + vjust = 1, + margin = margin(b = half_line) + ), + plot.caption = element_text( + # font size "small" + size = rel(0.8), + hjust = 1, + vjust = 1, + margin = margin(t = half_line) + ), plot.caption.position = "panel", - plot.tag = element_text( - size = rel(1.2), - hjust = 0.5, vjust = 0.5 - ), - plot.tag.position = 'topleft', - plot.margin = NULL, + plot.tag = element_text( + size = rel(1.2), + hjust = 0.5, + vjust = 0.5 + ), + plot.tag.position = 'topleft', + plot.margin = NULL, complete = TRUE ) @@ -285,11 +341,16 @@ theme_gray <- theme_grey #' @export #' @rdname ggtheme -theme_bw <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_bw <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { # Starts with theme_grey and then modify some parts theme_grey( base_size = base_size, @@ -297,18 +358,20 @@ theme_bw <- function(base_size = 11, base_family = "", header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( # white background and dark border panel.background = element_rect(fill = paper, colour = NA), - panel.border = element_rect(colour = col_mix(ink, paper, 0.2)), + panel.border = element_rect(colour = col_mix(ink, paper, 0.2)), # make gridlines dark, same contrast with white as in theme_grey panel.grid = element_line(colour = col_mix(ink, paper, 0.92)), panel.grid.minor = element_line(linewidth = rel(0.5)), # contour strips to match panel contour strip.background = element_rect( - fill = col_mix(ink, paper, 0.851), + fill = col_mix(ink, paper, 0.851), colour = col_mix(ink, paper, 0.2) ), @@ -318,11 +381,16 @@ theme_bw <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_linedraw <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_linedraw <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { half_line <- base_size / 2 # Starts with theme_bw and then modify some parts @@ -333,28 +401,30 @@ theme_linedraw <- function(base_size = 11, base_family = "", header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( # black text and ticks on the axes - axis.text = element_text(colour = ink, size = rel(0.8)), - axis.ticks = element_line(colour = ink, linewidth = rel(0.5)), + axis.text = element_text(colour = ink, size = rel(0.8)), + axis.ticks = element_line(colour = ink, linewidth = rel(0.5)), # NB: match the *visual* thickness of axis ticks to the panel border # 0.5 clipped looks like 0.25 # pure black panel border and grid lines, but thinner - panel.border = element_rect(colour = ink, linewidth = rel(1)), - panel.grid = element_line(colour = ink), + panel.border = element_rect(colour = ink, linewidth = rel(1)), + panel.grid = element_line(colour = ink), panel.grid.major = element_line(linewidth = rel(0.1)), panel.grid.minor = element_line(linewidth = rel(0.05)), # strips with black background and white text strip.background = element_rect(fill = ink), - strip.text = element_text( - colour = paper, - size = rel(0.8), - margin = margin_auto(0.8 * half_line) - ), + strip.text = element_text( + colour = paper, + size = rel(0.8), + margin = margin_auto(0.8 * half_line) + ), complete = TRUE ) @@ -362,11 +432,16 @@ theme_linedraw <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_light <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_light <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { half_line <- base_size / 2 # Starts with theme_grey and then modify some parts @@ -376,41 +451,56 @@ theme_light <- function(base_size = 11, base_family = "", header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( # white panel with light grey border panel.background = element_rect(fill = paper, colour = NA), - panel.border = element_rect(colour = col_mix(ink, paper, 0.702), linewidth = rel(1)), + panel.border = element_rect( + colour = col_mix(ink, paper, 0.702), + linewidth = rel(1) + ), # light grey, thinner gridlines # => make them slightly darker to keep acceptable contrast - panel.grid = element_line(colour = col_mix(ink, paper, 0.871)), + panel.grid = element_line(colour = col_mix(ink, paper, 0.871)), panel.grid.major = element_line(linewidth = rel(0.5)), panel.grid.minor = element_line(linewidth = rel(0.25)), # match axes ticks thickness to gridlines and colour to panel border - axis.ticks = element_line(colour = col_mix(ink, paper, 0.702), linewidth = rel(0.5)), + axis.ticks = element_line( + colour = col_mix(ink, paper, 0.702), + linewidth = rel(0.5) + ), # dark strips with light text (inverse contrast compared to theme_grey) - strip.background = element_rect(fill = col_mix(ink, paper, 0.702), colour = NA), - strip.text = element_text( - colour = paper, - size = rel(0.8), - margin = margin_auto(0.8 * half_line) - ), + strip.background = element_rect( + fill = col_mix(ink, paper, 0.702), + colour = NA + ), + strip.text = element_text( + colour = paper, + size = rel(0.8), + margin = margin_auto(0.8 * half_line) + ), complete = TRUE ) - } #' @export #' @rdname ggtheme -theme_dark <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_dark <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { half_line <- base_size / 2 # Starts with theme_grey and then modify some parts @@ -420,27 +510,38 @@ theme_dark <- function(base_size = 11, base_family = "", header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( # dark panel - panel.background = element_rect(fill = col_mix(ink, paper, 0.499), colour = NA), + panel.background = element_rect( + fill = col_mix(ink, paper, 0.499), + colour = NA + ), # inverse grid lines contrast compared to theme_grey # make them thinner and try to keep the same visual contrast as in theme_light - panel.grid = element_line(colour = col_mix(ink, paper, 0.42)), + panel.grid = element_line(colour = col_mix(ink, paper, 0.42)), panel.grid.major = element_line(linewidth = rel(0.5)), panel.grid.minor = element_line(linewidth = rel(0.25)), # match axes ticks thickness to gridlines - axis.ticks = element_line(colour = col_mix(ink, paper, 0.2), linewidth = rel(0.5)), + axis.ticks = element_line( + colour = col_mix(ink, paper, 0.2), + linewidth = rel(0.5) + ), # dark strips with light text (inverse contrast compared to theme_grey) - strip.background = element_rect(fill = col_mix(ink, paper, 0.15), colour = NA), - strip.text = element_text( - colour = col_mix(ink, paper, 0.899), - size = rel(0.8), - margin = margin_auto(0.8 * half_line) - ), + strip.background = element_rect( + fill = col_mix(ink, paper, 0.15), + colour = NA + ), + strip.text = element_text( + colour = col_mix(ink, paper, 0.899), + size = rel(0.8), + margin = margin_auto(0.8 * half_line) + ), complete = TRUE ) @@ -448,11 +549,16 @@ theme_dark <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_minimal <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_minimal <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { # Starts with theme_bw and remove most parts theme_bw( base_size = base_size, @@ -460,20 +566,22 @@ theme_minimal <- function(base_size = 11, base_family = "", header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( - axis.ticks = element_blank(), # Extra margins due to absence ticks + axis.ticks = element_blank(), # Extra margins due to absence ticks axis.text.x.bottom = element_text(margin = margin(t = 0.45 * base_size)), - axis.text.x.top = element_text(margin = margin(b = 0.45 * base_size)), - axis.text.y.left = element_text(margin = margin(r = 0.45 * base_size)), - axis.text.y.right = element_text(margin = margin(l = 0.45 * base_size)), + axis.text.x.top = element_text(margin = margin(b = 0.45 * base_size)), + axis.text.y.left = element_text(margin = margin(r = 0.45 * base_size)), + axis.text.y.right = element_text(margin = margin(l = 0.45 * base_size)), legend.background = element_blank(), - legend.key = element_blank(), - panel.background = element_blank(), - panel.border = element_blank(), - strip.background = element_blank(), - plot.background = element_rect(fill = paper, colour = NA), + legend.key = element_blank(), + panel.background = element_blank(), + panel.border = element_blank(), + strip.background = element_blank(), + plot.background = element_rect(fill = paper, colour = NA), complete = TRUE ) @@ -481,27 +589,34 @@ theme_minimal <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_classic <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_classic <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { theme_bw( base_size = base_size, base_family = base_family, header_family = header_family, base_line_size = base_line_size, base_rect_size = base_rect_size, - ink = ink, paper = paper, accent = accent + ink = ink, + paper = paper, + accent = accent ) %+replace% theme( # no background and no grid panel.border = element_blank(), - panel.grid = element_blank(), + panel.grid = element_blank(), # show axes - axis.text = element_text(size = rel(0.8)), - axis.line = element_line(lineend = "square"), + axis.text = element_text(size = rel(0.8)), + axis.line = element_line(lineend = "square"), axis.ticks = element_line(), # simple, black and white strips @@ -514,41 +629,62 @@ theme_classic <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_void <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = alpha(ink, 0), accent = "#3366FF") { +theme_void <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = alpha(ink, 0), + accent = "#3366FF" +) { half_line <- base_size / 2 # Only keep indispensable text: legend and plot titles t <- theme( - line = element_blank(), - rect = element_rect( - fill = paper, colour = NA, linewidth = 0, linetype = 1, - inherit.blank = FALSE, linejoin = "round" - ), - polygon = element_blank(), - point = element_blank(), - text = element_text( - family = base_family, face = "plain", - colour = ink, size = base_size, - lineheight = 0.9, hjust = 0.5, vjust = 0.5, angle = 0, - margin = margin(), debug = FALSE - ), - title = element_text(family = header_family), - spacing = unit(half_line, "pt"), - margins = margin_auto(half_line), - geom = element_geom( - ink = ink, paper = paper, accent = accent, - linewidth = base_line_size, borderwidth = base_line_size, - linetype = 1L, bordertype = 1L, - family = base_family, fontsize = base_size, - pointsize = (base_size / 11) * 1.5, pointshape = 19 - ), - axis.text = element_blank(), - axis.title = element_blank(), - axis.ticks.length = rel(0), + line = element_blank(), + rect = element_rect( + fill = paper, + colour = NA, + linewidth = 0, + linetype = 1, + inherit.blank = FALSE, + linejoin = "round" + ), + polygon = element_blank(), + point = element_blank(), + text = element_text( + family = base_family, + face = "plain", + colour = ink, + size = base_size, + lineheight = 0.9, + hjust = 0.5, + vjust = 0.5, + angle = 0, + margin = margin(), + debug = FALSE + ), + title = element_text(family = header_family), + spacing = unit(half_line, "pt"), + margins = margin_auto(half_line), + geom = element_geom( + ink = ink, + paper = paper, + accent = accent, + linewidth = base_line_size, + borderwidth = base_line_size, + linetype = 1L, + bordertype = 1L, + family = base_family, + fontsize = base_size, + pointsize = (base_size / 11) * 1.5, + pointshape = 19 + ), + axis.text = element_blank(), + axis.title = element_blank(), + axis.ticks.length = rel(0), axis.ticks.length.x = NULL, axis.ticks.length.x.top = NULL, axis.ticks.length.x.bottom = NULL, @@ -556,51 +692,55 @@ theme_void <- function(base_size = 11, base_family = "", axis.ticks.length.y.left = NULL, axis.ticks.length.y.right = NULL, axis.minor.ticks.length = NULL, - legend.box = NULL, - legend.key.size = unit(1.2, "lines"), - legend.position = "right", - legend.text = element_text(size = rel(0.8)), - legend.title = element_text(hjust = 0), + legend.box = NULL, + legend.key.size = unit(1.2, "lines"), + legend.position = "right", + legend.text = element_text(size = rel(0.8)), + legend.title = element_text(hjust = 0), legend.key.spacing = rel(1), - legend.margin = margin_auto(0), - legend.box.margin = margin_auto(0), + legend.margin = margin_auto(0), + legend.box.margin = margin_auto(0), legend.box.spacing = unit(0.2, "cm"), legend.ticks.length = rel(0.2), - legend.background = element_blank(), - legend.frame = element_blank(), + legend.background = element_blank(), + legend.frame = element_blank(), legend.box.background = element_blank(), - strip.clip = "on", - strip.text = element_text(size = rel(0.8)), + strip.clip = "on", + strip.text = element_text(size = rel(0.8)), strip.switch.pad.grid = rel(0.5), strip.switch.pad.wrap = rel(0.5), - strip.background = element_blank(), - panel.ontop = FALSE, - panel.spacing = NULL, - panel.background = element_blank(), - panel.border = element_blank(), - plot.margin = margin_auto(0), - plot.title = element_text( - size = rel(1.2), - hjust = 0, vjust = 1, - margin = margin(t = half_line) - ), + strip.background = element_blank(), + panel.ontop = FALSE, + panel.spacing = NULL, + panel.background = element_blank(), + panel.border = element_blank(), + plot.margin = margin_auto(0), + plot.title = element_text( + size = rel(1.2), + hjust = 0, + vjust = 1, + margin = margin(t = half_line) + ), plot.title.position = "panel", - plot.subtitle = element_text( - hjust = 0, vjust = 1, - margin = margin(t = half_line) - ), - plot.caption = element_text( - size = rel(0.8), - hjust = 1, vjust = 1, - margin = margin(t = half_line) - ), + plot.subtitle = element_text( + hjust = 0, + vjust = 1, + margin = margin(t = half_line) + ), + plot.caption = element_text( + size = rel(0.8), + hjust = 1, + vjust = 1, + margin = margin(t = half_line) + ), plot.caption.position = "panel", - plot.tag = element_text( - size = rel(1.2), - hjust = 0.5, vjust = 0.5 - ), - plot.tag.position = 'topleft', - plot.background = element_rect(), + plot.tag = element_text( + size = rel(1.2), + hjust = 0.5, + vjust = 0.5 + ), + plot.tag.position = 'topleft', + plot.background = element_rect(), complete = TRUE ) @@ -612,58 +752,100 @@ theme_void <- function(base_size = 11, base_family = "", #' @export #' @rdname ggtheme -theme_test <- function(base_size = 11, base_family = "", - header_family = NULL, - base_line_size = base_size / 22, - base_rect_size = base_size / 22, - ink = "black", paper = "white", accent = "#3366FF") { +theme_test <- function( + base_size = 11, + base_family = "", + header_family = NULL, + base_line_size = base_size / 22, + base_rect_size = base_size / 22, + ink = "black", + paper = "white", + accent = "#3366FF" +) { half_line <- base_size / 2 t <- theme( - line = element_line( - colour = ink, linewidth = base_line_size, - linetype = 1, lineend = "butt", linejoin = "round" - ), - rect = element_rect( - fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1, linejoin = "round" - ), - text = element_text( - family = base_family, face = "plain", - colour = ink, size = base_size, - lineheight = 0.9, hjust = 0.5, vjust = 0.5, angle = 0, - margin = margin(), debug = FALSE - ), - point = element_point( - colour = ink, shape = 19, fill = paper, - size = (base_size / 11) * 1.5, - stroke = base_line_size - ), - polygon = element_polygon( - fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1, linejoin = "round" - ), - title = element_text(family = header_family), + line = element_line( + colour = ink, + linewidth = base_line_size, + linetype = 1, + lineend = "butt", + linejoin = "round" + ), + rect = element_rect( + fill = paper, + colour = ink, + linewidth = base_rect_size, + linetype = 1, + linejoin = "round" + ), + text = element_text( + family = base_family, + face = "plain", + colour = ink, + size = base_size, + lineheight = 0.9, + hjust = 0.5, + vjust = 0.5, + angle = 0, + margin = margin(), + debug = FALSE + ), + point = element_point( + colour = ink, + shape = 19, + fill = paper, + size = (base_size / 11) * 1.5, + stroke = base_line_size + ), + polygon = element_polygon( + fill = paper, + colour = ink, + linewidth = base_rect_size, + linetype = 1, + linejoin = "round" + ), + title = element_text(family = header_family), spacing = unit(half_line, "pt"), margins = margin_auto(half_line), - geom = element_geom( - ink = ink, paper = paper, accent = accent, - linewidth = base_line_size, borderwidth = base_line_size, - family = base_family, fontsize = base_size, - linetype = 1L, - pointsize = (base_size / 11) * 1.5, pointshape = 19 - ), - - axis.line = element_blank(), - axis.line.x = NULL, - axis.line.y = NULL, - axis.text = element_text(size = rel(0.8), colour = col_mix(ink, paper, 0.302)), - axis.text.x = element_text(margin = margin(t = 0.8 * half_line / 2), vjust = 1), - axis.text.x.top = element_text(margin = margin(b = 0.8 * half_line / 2), vjust = 0), - axis.text.y = element_text(margin = margin(r = 0.8 * half_line / 2), hjust = 1), - axis.text.y.right = element_text(margin = margin(l = 0.8 * half_line / 2), hjust = 0), - axis.ticks = element_line(colour = col_mix(ink, paper, 0.2)), - axis.ticks.length = rel(0.5), + geom = element_geom( + ink = ink, + paper = paper, + accent = accent, + linewidth = base_line_size, + borderwidth = base_line_size, + family = base_family, + fontsize = base_size, + linetype = 1L, + pointsize = (base_size / 11) * 1.5, + pointshape = 19 + ), + + axis.line = element_blank(), + axis.line.x = NULL, + axis.line.y = NULL, + axis.text = element_text( + size = rel(0.8), + colour = col_mix(ink, paper, 0.302) + ), + axis.text.x = element_text( + margin = margin(t = 0.8 * half_line / 2), + vjust = 1 + ), + axis.text.x.top = element_text( + margin = margin(b = 0.8 * half_line / 2), + vjust = 0 + ), + axis.text.y = element_text( + margin = margin(r = 0.8 * half_line / 2), + hjust = 1 + ), + axis.text.y.right = element_text( + margin = margin(l = 0.8 * half_line / 2), + hjust = 0 + ), + axis.ticks = element_line(colour = col_mix(ink, paper, 0.2)), + axis.ticks.length = rel(0.5), axis.ticks.length.x = NULL, axis.ticks.length.x.top = NULL, axis.ticks.length.x.bottom = NULL, @@ -671,99 +853,103 @@ theme_test <- function(base_size = 11, base_family = "", axis.ticks.length.y.left = NULL, axis.ticks.length.y.right = NULL, axis.minor.ticks.length = rel(0.75), - axis.title.x = element_text( - margin = margin(t = half_line / 2), - vjust = 1 - ), - axis.title.x.top = element_text( - margin = margin(b = half_line / 2), - vjust = 0 - ), - axis.title.y = element_text( - angle = 90, - margin = margin(r = half_line / 2), - vjust = 1 - ), + axis.title.x = element_text( + margin = margin(t = half_line / 2), + vjust = 1 + ), + axis.title.x.top = element_text( + margin = margin(b = half_line / 2), + vjust = 0 + ), + axis.title.y = element_text( + angle = 90, + margin = margin(r = half_line / 2), + vjust = 1 + ), axis.title.y.right = element_text( - angle = -90, - margin = margin(l = half_line / 2), - vjust = 1 - ), - - legend.background = element_rect(colour = NA), - legend.spacing = rel(2), - legend.spacing.x = NULL, - legend.spacing.y = NULL, - legend.margin = margin_auto(0, unit = "cm"), - legend.key = NULL, - legend.key.size = unit(1.2, "lines"), - legend.key.height = NULL, - legend.key.width = NULL, + angle = -90, + margin = margin(l = half_line / 2), + vjust = 1 + ), + + legend.background = element_rect(colour = NA), + legend.spacing = rel(2), + legend.spacing.x = NULL, + legend.spacing.y = NULL, + legend.margin = margin_auto(0, unit = "cm"), + legend.key = NULL, + legend.key.size = unit(1.2, "lines"), + legend.key.height = NULL, + legend.key.width = NULL, legend.key.spacing = NULL, legend.key.spacing.x = NULL, legend.key.spacing.y = NULL, - legend.text = element_text(size = rel(0.8)), - legend.title = element_text(hjust = 0), + legend.text = element_text(size = rel(0.8)), + legend.title = element_text(hjust = 0), legend.ticks.length = rel(0.2), - legend.position = "right", - legend.direction = NULL, + legend.position = "right", + legend.direction = NULL, legend.justification = "center", - legend.box = NULL, - legend.box.margin = margin_auto(0, unit = "cm"), + legend.box = NULL, + legend.box.margin = margin_auto(0, unit = "cm"), legend.box.background = element_blank(), legend.box.spacing = rel(2), - panel.background = element_rect(fill = paper, colour = NA), - panel.border = element_rect(colour = col_mix(ink, paper, 0.2)), - panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), - panel.spacing = NULL, - panel.spacing.x = NULL, - panel.spacing.y = NULL, - panel.ontop = FALSE, - - strip.background = element_rect( - fill = col_mix(ink, paper, 0.85), - colour = col_mix(ink, paper, 0.2) - ), - strip.clip = "on", - strip.text = element_text( - colour = col_mix(ink, paper, 0.1), - size = rel(0.8), - margin = margin_auto(0.8 * half_line) - ), - strip.text.x = NULL, - strip.text.y = element_text(angle = -90), - strip.text.y.left = element_text(angle = 90), - strip.placement = "inside", - strip.placement.x = NULL, - strip.placement.y = NULL, + panel.background = element_rect(fill = paper, colour = NA), + panel.border = element_rect(colour = col_mix(ink, paper, 0.2)), + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + panel.spacing = NULL, + panel.spacing.x = NULL, + panel.spacing.y = NULL, + panel.ontop = FALSE, + + strip.background = element_rect( + fill = col_mix(ink, paper, 0.85), + colour = col_mix(ink, paper, 0.2) + ), + strip.clip = "on", + strip.text = element_text( + colour = col_mix(ink, paper, 0.1), + size = rel(0.8), + margin = margin_auto(0.8 * half_line) + ), + strip.text.x = NULL, + strip.text.y = element_text(angle = -90), + strip.text.y.left = element_text(angle = 90), + strip.placement = "inside", + strip.placement.x = NULL, + strip.placement.y = NULL, strip.switch.pad.grid = rel(0.5), strip.switch.pad.wrap = rel(0.5), - plot.background = element_rect(colour = paper), - plot.title = element_text( - size = rel(1.2), - hjust = 0, vjust = 1, - margin = margin(b = half_line) - ), + plot.background = element_rect(colour = paper), + plot.title = element_text( + size = rel(1.2), + hjust = 0, + vjust = 1, + margin = margin(b = half_line) + ), plot.title.position = "panel", - plot.subtitle = element_text( - hjust = 0, vjust = 1, - margin = margin(b = half_line) - ), - plot.caption = element_text( - size = rel(0.8), - hjust = 1, vjust = 1, - margin = margin(t = half_line) - ), + plot.subtitle = element_text( + hjust = 0, + vjust = 1, + margin = margin(b = half_line) + ), + plot.caption = element_text( + size = rel(0.8), + hjust = 1, + vjust = 1, + margin = margin(t = half_line) + ), plot.caption.position = "panel", - plot.tag = element_text( - size = rel(1.2), - hjust = 0.5, vjust = 0.5 - ), - plot.tag.position = 'topleft', - plot.margin = NULL, + plot.tag = element_text( + size = rel(1.2), + hjust = 0.5, + vjust = 0.5 + ), + plot.tag.position = 'topleft', + plot.margin = NULL, complete = TRUE ) @@ -781,7 +967,8 @@ theme_all_null <- function() { elements <- sapply( names(.element_tree), function(x) NULL, - simplify = FALSE, USE.NAMES = TRUE + simplify = FALSE, + USE.NAMES = TRUE ) args <- c(elements, list(complete = TRUE)) diff --git a/R/theme-elements.R b/R/theme-elements.R index 3f69eacfb3..f15c4b268c 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -105,41 +105,55 @@ element_blank <- S7::new_class( #' @include properties.R #' @include margins.R element_props <- list( - fill = property_colour(pattern = TRUE), - colour = property_colour(pattern = FALSE), - family = property_nullable(S7::class_character), - hjust = property_nullable(S7::class_numeric), - vjust = property_nullable(S7::class_numeric), - angle = property_nullable(S7::class_numeric), - size = property_nullable(S7::class_numeric), + fill = property_colour(pattern = TRUE), + colour = property_colour(pattern = FALSE), + family = property_nullable(S7::class_character), + hjust = property_nullable(S7::class_numeric), + vjust = property_nullable(S7::class_numeric), + angle = property_nullable(S7::class_numeric), + size = property_nullable(S7::class_numeric), lineheight = property_nullable(S7::class_numeric), - margin = property_nullable(margin), - face = property_fontface(allow_null = TRUE), - linewidth = property_nullable(S7::class_numeric), - linetype = property_nullable(S7::class_numeric | S7::class_character), - lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), - linejoin = property_choice(c("round", "mitre", "bevel"), allow_null = TRUE), - shape = property_nullable(S7::class_numeric | S7::class_character), - arrow = property_nullable(S7::new_S3_class("arrow") | S7::class_logical), + margin = property_nullable(margin), + face = property_fontface(allow_null = TRUE), + linewidth = property_nullable(S7::class_numeric), + linetype = property_nullable(S7::class_numeric | S7::class_character), + lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), + linejoin = property_choice(c("round", "mitre", "bevel"), allow_null = TRUE), + shape = property_nullable(S7::class_numeric | S7::class_character), + arrow = property_nullable(S7::new_S3_class("arrow") | S7::class_logical), arrow.fill = property_colour(pattern = FALSE), - debug = property_boolean(allow_null = TRUE, default = NULL), + debug = property_boolean(allow_null = TRUE, default = NULL), inherit.blank = property_boolean(default = FALSE), # These are reserved for future use - italic = property_nullable(S7::class_character), + italic = property_nullable(S7::class_character), fontweight = property_nullable(S7::class_numeric), - fontwidth = property_nullable(S7::class_numeric | S7::class_character) + fontwidth = property_nullable(S7::class_numeric | S7::class_character) ) #' @export #' @rdname element element_rect <- S7::new_class( - "element_rect", parent = element, - properties = element_props[c("fill", "colour", - "linewidth", "linetype", "linejoin", - "inherit.blank")], - constructor = function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, linejoin = NULL, - inherit.blank = FALSE, size = deprecated(), ...){ + "element_rect", + parent = element, + properties = element_props[c( + "fill", + "colour", + "linewidth", + "linetype", + "linejoin", + "inherit.blank" + )], + constructor = function( + fill = NULL, + colour = NULL, + linewidth = NULL, + linetype = NULL, + color = NULL, + linejoin = NULL, + inherit.blank = FALSE, + size = deprecated(), + ... + ) { warn_dots_empty() if (lifecycle::is_present(size)) { deprecate_warn0("3.4.0", "element_rect(size)", "element_rect(linewidth)") @@ -147,8 +161,11 @@ element_rect <- S7::new_class( } obj <- S7::new_object( S7::S7_object(), - fill = fill, colour = color %||% colour, - linewidth = linewidth, linetype = linetype, linejoin = linejoin, + fill = fill, + colour = color %||% colour, + linewidth = linewidth, + linetype = linetype, + linejoin = linejoin, inherit.blank = inherit.blank ) class(obj) <- union( @@ -165,16 +182,31 @@ element_rect <- S7::new_class( #' @param lineend Line end style, one of `"round"`, `"butt"` or `"square"`. #' @param arrow Arrow specification, as created by [grid::arrow()] element_line <- S7::new_class( - "element_line", parent = element, + "element_line", + parent = element, properties = element_props[c( - "colour", "linewidth", "linetype", "lineend", "linejoin", - "arrow", "arrow.fill", + "colour", + "linewidth", + "linetype", + "lineend", + "linejoin", + "arrow", + "arrow.fill", "inherit.blank" )], - constructor = function(colour = NULL, linewidth = NULL, linetype = NULL, - lineend = NULL, color = NULL, linejoin = NULL, - arrow = NULL, arrow.fill = NULL, - inherit.blank = FALSE, size = deprecated(), ...) { + constructor = function( + colour = NULL, + linewidth = NULL, + linetype = NULL, + lineend = NULL, + color = NULL, + linejoin = NULL, + arrow = NULL, + arrow.fill = NULL, + inherit.blank = FALSE, + size = deprecated(), + ... + ) { warn_dots_empty() if (lifecycle::is_present(size)) { deprecate_warn0("3.4.0", "element_line(size)", "element_line(linewidth)") @@ -184,7 +216,9 @@ element_line <- S7::new_class( obj <- S7::new_object( S7::S7_object(), colour = colour, - linewidth = linewidth, linetype = linetype, lineend = lineend, + linewidth = linewidth, + linetype = linetype, + lineend = lineend, linejoin = linejoin, arrow = arrow %||% FALSE, arrow.fill = arrow.fill %||% colour, @@ -220,20 +254,49 @@ element_line <- S7::new_class( #' @export #' @rdname element element_text <- S7::new_class( - "element_text", parent = element, + "element_text", + parent = element, properties = element_props[c( - "family", "face", "italic", "fontweight", "fontwidth", - "colour", "size", "hjust", "vjust", "angle", "lineheight", - "margin", "debug", "inherit.blank" + "family", + "face", + "italic", + "fontweight", + "fontwidth", + "colour", + "size", + "hjust", + "vjust", + "angle", + "lineheight", + "margin", + "debug", + "inherit.blank" )], - constructor = function(family = NULL, face = NULL, colour = NULL, - size = NULL, hjust = NULL, vjust = NULL, angle = NULL, - lineheight = NULL, color = NULL, margin = NULL, - debug = NULL, inherit.blank = FALSE, ...) { + constructor = function( + family = NULL, + face = NULL, + colour = NULL, + size = NULL, + hjust = NULL, + vjust = NULL, + angle = NULL, + lineheight = NULL, + color = NULL, + margin = NULL, + debug = NULL, + inherit.blank = FALSE, + ... + ) { warn_dots_empty() n <- max( - length(family), length(face), length(colour), length(size), - length(hjust), length(vjust), length(angle), length(lineheight) + length(family), + length(face), + length(colour), + length(size), + length(hjust), + length(vjust), + length(angle), + length(lineheight) ) if (n > 1) { cli::cli_warn(c( @@ -252,10 +315,20 @@ element_text <- S7::new_class( colour <- color %||% colour obj <- S7::new_object( S7::S7_object(), - family = family, face = face, colour = colour, size = size, - hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight, - margin = margin, debug = debug, inherit.blank = inherit.blank, - italic = NA_character_, fontweight = NA_real_, fontwidth = NA_real_ + family = family, + face = face, + colour = colour, + size = size, + hjust = hjust, + vjust = vjust, + angle = angle, + lineheight = lineheight, + margin = margin, + debug = debug, + inherit.blank = inherit.blank, + italic = NA_character_, + fontweight = NA_real_, + fontwidth = NA_real_ ) class(obj) <- union( union(c("ggplot2::element_text", "element_text"), class(obj)), @@ -268,19 +341,36 @@ element_text <- S7::new_class( #' @export #' @rdname element element_polygon <- S7::new_class( - "element_polygon", parent = element, + "element_polygon", + parent = element, properties = element_props[c( - "fill", "colour", "linewidth", "linetype", "linejoin", "inherit.blank" + "fill", + "colour", + "linewidth", + "linetype", + "linejoin", + "inherit.blank" )], - constructor = function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, linejoin = NULL, - inherit.blank = FALSE, ...) { + constructor = function( + fill = NULL, + colour = NULL, + linewidth = NULL, + linetype = NULL, + color = NULL, + linejoin = NULL, + inherit.blank = FALSE, + ... + ) { warn_dots_empty() colour <- color %||% colour S7::new_object( S7::S7_object(), - fill = fill, colour = color %||% colour, linewidth = linewidth, - linetype = linetype, linejoin = linejoin, inherit.blank = inherit.blank + fill = fill, + colour = color %||% colour, + linewidth = linewidth, + linetype = linetype, + linejoin = linejoin, + inherit.blank = inherit.blank ) } ) @@ -288,20 +378,38 @@ element_polygon <- S7::new_class( #' @export #' @rdname element element_point <- S7::new_class( - "element_point", parent = element, + "element_point", + parent = element, properties = rename( element_props[c( - "colour", "shape", "size", "fill", "linewidth", "inherit.blank" + "colour", + "shape", + "size", + "fill", + "linewidth", + "inherit.blank" )], c("linewidth" = "stroke") ), - constructor = function(colour = NULL, shape = NULL, size = NULL, fill = NULL, - stroke = NULL, color = NULL, inherit.blank = FALSE, ...) { + constructor = function( + colour = NULL, + shape = NULL, + size = NULL, + fill = NULL, + stroke = NULL, + color = NULL, + inherit.blank = FALSE, + ... + ) { warn_dots_empty() S7::new_object( S7::S7_object(), - colour = color %||% colour, fill = fill, shape = shape, size = size, - stroke = stroke, inherit.blank = inherit.blank + colour = color %||% colour, + fill = fill, + shape = shape, + size = size, + stroke = stroke, + inherit.blank = inherit.blank ) } ) @@ -312,7 +420,8 @@ element_point <- S7::new_class( #' @export #' @rdname element element_geom <- S7::new_class( - "element_geom", parent = element, + "element_geom", + parent = element, properties = list( ink = element_props$colour, paper = element_props$colour, @@ -329,13 +438,22 @@ element_geom <- S7::new_class( fill = element_props$fill ), constructor = function( - ink = NULL, paper = NULL, accent = NULL, - linewidth = NULL, borderwidth = NULL, - linetype = NULL, bordertype = NULL, - family = NULL, fontsize = NULL, - pointsize = NULL, pointshape = NULL, - colour = NULL, color = NULL, fill = NULL, - ...) { + ink = NULL, + paper = NULL, + accent = NULL, + linewidth = NULL, + borderwidth = NULL, + linetype = NULL, + bordertype = NULL, + family = NULL, + fontsize = NULL, + pointsize = NULL, + pointshape = NULL, + colour = NULL, + color = NULL, + fill = NULL, + ... + ) { warn_dots_empty() if (!is.null(fontsize)) { fontsize <- fontsize / .pt @@ -343,23 +461,37 @@ element_geom <- S7::new_class( S7::new_object( S7::S7_object(), - ink = ink, paper = paper, accent = accent, - linewidth = linewidth, borderwidth = borderwidth, - linetype = linetype, bordertype = bordertype, - family = family, fontsize = fontsize, - pointsize = pointsize, pointshape = pointshape, - colour = color %||% colour, fill = fill + ink = ink, + paper = paper, + accent = accent, + linewidth = linewidth, + borderwidth = borderwidth, + linetype = linetype, + bordertype = bordertype, + family = family, + fontsize = fontsize, + pointsize = pointsize, + pointshape = pointshape, + colour = color %||% colour, + fill = fill ) } ) .default_geom_element <- element_geom( - ink = "black", paper = "white", accent = "#3366FF", - linewidth = 0.5, borderwidth = 0.5, - linetype = 1L, bordertype = 1L, - family = "", fontsize = 11, - pointsize = 1.5, pointshape = 19, - fill = NULL, colour = NULL + ink = "black", + paper = "white", + accent = "#3366FF", + linewidth = 0.5, + borderwidth = 0.5, + linetype = 1L, + bordertype = 1L, + family = "", + fontsize = 11, + pointsize = 1.5, + pointshape = 19, + fill = NULL, + colour = NULL ) local({ @@ -375,14 +507,14 @@ local({ is_theme_element <- function(x, type = "any") { switch( type %||% "any", - any = S7::S7_inherits(x, element), - blank = S7::S7_inherits(x, element_blank), - rect = S7::S7_inherits(x, element_rect), - line = S7::S7_inherits(x, element_line), - text = S7::S7_inherits(x, element_text), + any = S7::S7_inherits(x, element), + blank = S7::S7_inherits(x, element_blank), + rect = S7::S7_inherits(x, element_rect), + line = S7::S7_inherits(x, element_line), + text = S7::S7_inherits(x, element_text), polygon = S7::S7_inherits(x, element_polygon), - point = S7::S7_inherits(x, element_point), - geom = S7::S7_inherits(x, element_geom), + point = S7::S7_inherits(x, element_point), + geom = S7::S7_inherits(x, element_geom), FALSE ) } @@ -451,7 +583,6 @@ is_rel <- function(x) inherits(x, "rel") #' @keywords internal #' @export element_render <- function(theme, element, ..., name = NULL) { - # Get the element from the theme, calculating inheritance el <- calc_element(element, theme) if (is.null(el)) { @@ -481,30 +612,66 @@ element_grob <- function(element, ...) { S7::method(element_grob, element_blank) <- function(element, ...) zeroGrob() S7::method(element_grob, element_rect) <- - function(element, x = 0.5, y = 0.5, width = 1, height = 1, - fill = NULL, colour = NULL, - linewidth = NULL, linetype = NULL, linejoin = NULL, - ..., size = deprecated()) { - + function( + element, + x = 0.5, + y = 0.5, + width = 1, + height = 1, + fill = NULL, + colour = NULL, + linewidth = NULL, + linetype = NULL, + linejoin = NULL, + ..., + size = deprecated() + ) { if (lifecycle::is_present(size)) { - deprecate_warn0("3.4.0", "element_grob.element_rect(size)", "element_grob.element_rect(linewidth)") + deprecate_warn0( + "3.4.0", + "element_grob.element_rect(size)", + "element_grob.element_rect(linewidth)" + ) linewidth <- size } - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype, linejoin = linejoin) - element_gp <- gg_par(lwd = element@linewidth, col = element@colour, - fill = element@fill, lty = element@linetype, - linejoin = element@linejoin) + gp <- gg_par( + lwd = linewidth, + col = colour, + fill = fill, + lty = linetype, + linejoin = linejoin + ) + element_gp <- gg_par( + lwd = element@linewidth, + col = element@colour, + fill = element@fill, + lty = element@linetype, + linejoin = element@linejoin + ) rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) } S7::method(element_grob, element_text) <- - function(element, label = "", x = NULL, y = NULL, - family = NULL, face = NULL, colour = NULL, size = NULL, - hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, - margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) { - + function( + element, + label = "", + x = NULL, + y = NULL, + family = NULL, + face = NULL, + colour = NULL, + size = NULL, + hjust = NULL, + vjust = NULL, + angle = NULL, + lineheight = NULL, + margin = NULL, + margin_x = FALSE, + margin_y = FALSE, + ... + ) { if (is.null(label)) { return(zeroGrob()) } @@ -520,26 +687,59 @@ S7::method(element_grob, element_text) <- angle <- angle %||% element@angle %||% 0 # The gp settings can override element_gp - gp <- gg_par(fontsize = size, col = colour, - fontfamily = family, fontface = face, - lineheight = lineheight) - element_gp <- gg_par(fontsize = element@size, col = element@colour, - fontfamily = element@family, fontface = element@face, - lineheight = element@lineheight) - - titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle, - gp = modify_list(element_gp, gp), margin = margin, - margin_x = margin_x, margin_y = margin_y, debug = element@debug, ...) + gp <- gg_par( + fontsize = size, + col = colour, + fontfamily = family, + fontface = face, + lineheight = lineheight + ) + element_gp <- gg_par( + fontsize = element@size, + col = element@colour, + fontfamily = element@family, + fontface = element@face, + lineheight = element@lineheight + ) + + titleGrob( + label, + x, + y, + hjust = hj, + vjust = vj, + angle = angle, + gp = modify_list(element_gp, gp), + margin = margin, + margin_x = margin_x, + margin_y = margin_y, + debug = element@debug, + ... + ) } S7::method(element_grob, element_line) <- - function(element, x = 0:1, y = 0:1, - colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL, - linejoin = NULL, arrow.fill = NULL, - default.units = "npc", id.lengths = NULL, ..., size = deprecated()) { - + function( + element, + x = 0:1, + y = 0:1, + colour = NULL, + linewidth = NULL, + linetype = NULL, + lineend = NULL, + linejoin = NULL, + arrow.fill = NULL, + default.units = "npc", + id.lengths = NULL, + ..., + size = deprecated() + ) { if (lifecycle::is_present(size)) { - deprecate_warn0("3.4.0", "element_grob.element_line(size)", "element_grob.element_line(linewidth)") + deprecate_warn0( + "3.4.0", + "element_grob.element_line(size)", + "element_grob.element_line(linewidth)" + ) linewidth <- size } @@ -555,56 +755,106 @@ S7::method(element_grob, element_line) <- # The gp settings can override element_gp gp <- gg_par( - col = colour, fill = arrow.fill %||% colour, - lwd = linewidth, lty = linetype, lineend = lineend, linejoin = linejoin + col = colour, + fill = arrow.fill %||% colour, + lwd = linewidth, + lty = linetype, + lineend = lineend, + linejoin = linejoin ) element_gp <- gg_par( - col = element@colour, fill = element@arrow.fill %||% element@colour, - lwd = element@linewidth, lty = element@linetype, - lineend = element@lineend, linejoin = element@linejoin + col = element@colour, + fill = element@arrow.fill %||% element@colour, + lwd = element@linewidth, + lty = element@linetype, + lineend = element@lineend, + linejoin = element@linejoin ) polylineGrob( - x, y, default.units = default.units, + x, + y, + default.units = default.units, gp = modify_list(element_gp, gp), - id.lengths = id.lengths, arrow = arrow, ... + id.lengths = id.lengths, + arrow = arrow, + ... ) } S7::method(element_grob, element_polygon) <- - function(element, x = c(0, 0.5, 1, 0.5), - y = c(0.5, 1, 0.5, 0), fill = NULL, - colour = NULL, linewidth = NULL, - linetype = NULL, linejoin = NULL, ..., - id = NULL, id.lengths = NULL, - pathId = NULL, pathId.lengths = NULL) { - - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, - lty = linetype, linejoin = linejoin) - element_gp <- gg_par(lwd = element@linewidth, col = element@colour, - fill = element@fill, lty = element@linetype, - linejoin = element@linejoin) + function( + element, + x = c(0, 0.5, 1, 0.5), + y = c(0.5, 1, 0.5, 0), + fill = NULL, + colour = NULL, + linewidth = NULL, + linetype = NULL, + linejoin = NULL, + ..., + id = NULL, + id.lengths = NULL, + pathId = NULL, + pathId.lengths = NULL + ) { + gp <- gg_par( + lwd = linewidth, + col = colour, + fill = fill, + lty = linetype, + linejoin = linejoin + ) + element_gp <- gg_par( + lwd = element@linewidth, + col = element@colour, + fill = element@fill, + lty = element@linetype, + linejoin = element@linejoin + ) pathGrob( - x = x, y = y, gp = modify_list(element_gp, gp), ..., + x = x, + y = y, + gp = modify_list(element_gp, gp), + ..., # We swap the id logic so that `id` is always the (super)group id # (consistent with `polygonGrob()`) and `pathId` always the subgroup id. - pathId = id, pathId.lengths = id.lengths, - id = pathId, id.lengths = pathId.lengths + pathId = id, + pathId.lengths = id.lengths, + id = pathId, + id.lengths = pathId.lengths ) } S7::method(element_grob, element_point) <- - function(element, x = 0.5, y = 0.5, colour = NULL, - shape = NULL, fill = NULL, size = NULL, - stroke = NULL, ..., - default.units = "npc") { - + function( + element, + x = 0.5, + y = 0.5, + colour = NULL, + shape = NULL, + fill = NULL, + size = NULL, + stroke = NULL, + ..., + default.units = "npc" + ) { gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke) - element_gp <- gg_par(col = element@colour, fill = element@fill, - pointsize = element@size, stroke = element@stroke) + element_gp <- gg_par( + col = element@colour, + fill = element@fill, + pointsize = element@size, + stroke = element@stroke + ) shape <- translate_shape_string(shape %||% element@shape %||% 19) - pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp), - default.units = default.units, ...) + pointsGrob( + x = x, + y = y, + pch = shape, + gp = modify_list(element_gp, gp), + default.units = default.units, + ... + ) } #' Define and register new theme elements @@ -674,7 +924,10 @@ register_theme_elements <- function(..., element_tree = NULL, complete = TRUE) { check_element_tree(element_tree) # Merge element trees - ggplot_global$element_tree <- defaults(element_tree, ggplot_global$element_tree) + ggplot_global$element_tree <- defaults( + element_tree, + ggplot_global$element_tree + ) invisible(old) } @@ -703,9 +956,9 @@ reset_theme_settings <- function(reset_current = TRUE) { # create the global variables holding all the theme settings on_load({ ggplot_global$theme_all_null <- theme_all_null() # cache all null theme, required by theme_grey() - ggplot_global$theme_current <- NULL # the current theme applied to plots if none is specified - ggplot_global$theme_default <- NULL # the underlying fallback default theme - ggplot_global$element_tree <- NULL # the current element tree for themes + ggplot_global$theme_current <- NULL # the current theme applied to plots if none is specified + ggplot_global$theme_default <- NULL # the underlying fallback default theme + ggplot_global$element_tree <- NULL # the current element tree for themes reset_theme_settings() # sets the preceding three global variables to their actual defaults }) @@ -734,8 +987,10 @@ check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { if (any(bad_fields)) { bad_fields <- names(x)[bad_fields] cli::cli_abort( - c("{.arg {arg}} must have elements constructed with {.fn el_def}.", - i = "Invalid structure: {.and {.val {bad_fields}}}"), + c( + "{.arg {arg}} must have elements constructed with {.fn el_def}.", + i = "Invalid structure: {.and {.val {bad_fields}}}" + ), call = call ) } @@ -743,7 +998,8 @@ check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { # Check element tree, prevent elements from being their own parent (#6162) bad_parent <- unlist(Map( function(name, el) any(name %in% el$inherit), - name = names(x), el = x + name = names(x), + el = x )) if (any(bad_parent)) { bad_parent <- names(x)[bad_parent] @@ -776,14 +1032,14 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { class <- switch( class, element = element, - element_blank = element_blank, - element_rect = element_rect, - element_line = element_line, - element_text = element_text, + element_blank = element_blank, + element_rect = element_rect, + element_line = element_line, + element_text = element_text, element_polygon = element_polygon, - element_point = element_point, - element_geom = element_geom, - margin = margin, + element_point = element_point, + element_geom = element_geom, + margin = margin, class ) } @@ -800,123 +1056,135 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { # among them. It should not be read from directly, since users may modify the # current element tree stored in ggplot_global$element_tree .element_tree <- list( - line = el_def(element_line), - rect = el_def(element_rect), - text = el_def(element_text), - point = el_def(element_point), - polygon = el_def(element_polygon), - geom = el_def(element_geom), - title = el_def(element_text, "text"), - spacing = el_def("unit"), - margins = el_def(c("margin", "unit")), - - axis.line = el_def(element_line, "line"), - axis.text = el_def(element_text, "text"), - axis.title = el_def(element_text, "title"), - axis.ticks = el_def(element_line, "line"), - legend.key.size = el_def(c("unit", "rel"), "spacing"), - panel.grid = el_def(element_line, "line"), - panel.grid.major = el_def(element_line, "panel.grid"), - panel.grid.minor = el_def(element_line, "panel.grid"), - strip.text = el_def(element_text, "text"), - - axis.line.x = el_def(element_line, "axis.line"), - axis.line.x.top = el_def(element_line, "axis.line.x"), - axis.line.x.bottom = el_def(element_line, "axis.line.x"), - axis.line.y = el_def(element_line, "axis.line"), - axis.line.y.left = el_def(element_line, "axis.line.y"), - axis.line.y.right = el_def(element_line, "axis.line.y"), - axis.line.theta = el_def(element_line, "axis.line.x"), - axis.line.r = el_def(element_line, "axis.line.y"), - - axis.text.x = el_def(element_text, "axis.text"), - axis.text.x.top = el_def(element_text, "axis.text.x"), - axis.text.x.bottom = el_def(element_text, "axis.text.x"), - axis.text.y = el_def(element_text, "axis.text"), - axis.text.y.left = el_def(element_text, "axis.text.y"), - axis.text.y.right = el_def(element_text, "axis.text.y"), - axis.text.theta = el_def(element_text, "axis.text.x"), - axis.text.r = el_def(element_text, "axis.text.y"), - - axis.ticks.length = el_def(c("unit", "rel"), "spacing"), + line = el_def(element_line), + rect = el_def(element_rect), + text = el_def(element_text), + point = el_def(element_point), + polygon = el_def(element_polygon), + geom = el_def(element_geom), + title = el_def(element_text, "text"), + spacing = el_def("unit"), + margins = el_def(c("margin", "unit")), + + axis.line = el_def(element_line, "line"), + axis.text = el_def(element_text, "text"), + axis.title = el_def(element_text, "title"), + axis.ticks = el_def(element_line, "line"), + legend.key.size = el_def(c("unit", "rel"), "spacing"), + panel.grid = el_def(element_line, "line"), + panel.grid.major = el_def(element_line, "panel.grid"), + panel.grid.minor = el_def(element_line, "panel.grid"), + strip.text = el_def(element_text, "text"), + + axis.line.x = el_def(element_line, "axis.line"), + axis.line.x.top = el_def(element_line, "axis.line.x"), + axis.line.x.bottom = el_def(element_line, "axis.line.x"), + axis.line.y = el_def(element_line, "axis.line"), + axis.line.y.left = el_def(element_line, "axis.line.y"), + axis.line.y.right = el_def(element_line, "axis.line.y"), + axis.line.theta = el_def(element_line, "axis.line.x"), + axis.line.r = el_def(element_line, "axis.line.y"), + + axis.text.x = el_def(element_text, "axis.text"), + axis.text.x.top = el_def(element_text, "axis.text.x"), + axis.text.x.bottom = el_def(element_text, "axis.text.x"), + axis.text.y = el_def(element_text, "axis.text"), + axis.text.y.left = el_def(element_text, "axis.text.y"), + axis.text.y.right = el_def(element_text, "axis.text.y"), + axis.text.theta = el_def(element_text, "axis.text.x"), + axis.text.r = el_def(element_text, "axis.text.y"), + + axis.ticks.length = el_def(c("unit", "rel"), "spacing"), axis.ticks.length.x = el_def(c("unit", "rel"), "axis.ticks.length"), axis.ticks.length.x.top = el_def(c("unit", "rel"), "axis.ticks.length.x"), axis.ticks.length.x.bottom = el_def(c("unit", "rel"), "axis.ticks.length.x"), - axis.ticks.length.y = el_def(c("unit", "rel"), "axis.ticks.length"), + axis.ticks.length.y = el_def(c("unit", "rel"), "axis.ticks.length"), axis.ticks.length.y.left = el_def(c("unit", "rel"), "axis.ticks.length.y"), axis.ticks.length.y.right = el_def(c("unit", "rel"), "axis.ticks.length.y"), axis.ticks.length.theta = el_def(c("unit", "rel"), "axis.ticks.length.x"), axis.ticks.length.r = el_def(c("unit", "rel"), "axis.ticks.length.y"), - axis.ticks.x = el_def(element_line, "axis.ticks"), - axis.ticks.x.top = el_def(element_line, "axis.ticks.x"), + axis.ticks.x = el_def(element_line, "axis.ticks"), + axis.ticks.x.top = el_def(element_line, "axis.ticks.x"), axis.ticks.x.bottom = el_def(element_line, "axis.ticks.x"), - axis.ticks.y = el_def(element_line, "axis.ticks"), - axis.ticks.y.left = el_def(element_line, "axis.ticks.y"), - axis.ticks.y.right = el_def(element_line, "axis.ticks.y"), - axis.ticks.theta = el_def(element_line, "axis.ticks.x"), - axis.ticks.r = el_def(element_line, "axis.ticks.y"), - - axis.title.x = el_def(element_text, "axis.title"), - axis.title.x.top = el_def(element_text, "axis.title.x"), + axis.ticks.y = el_def(element_line, "axis.ticks"), + axis.ticks.y.left = el_def(element_line, "axis.ticks.y"), + axis.ticks.y.right = el_def(element_line, "axis.ticks.y"), + axis.ticks.theta = el_def(element_line, "axis.ticks.x"), + axis.ticks.r = el_def(element_line, "axis.ticks.y"), + + axis.title.x = el_def(element_text, "axis.title"), + axis.title.x.top = el_def(element_text, "axis.title.x"), axis.title.x.bottom = el_def(element_text, "axis.title.x"), - axis.title.y = el_def(element_text, "axis.title"), - axis.title.y.left = el_def(element_text, "axis.title.y"), - axis.title.y.right = el_def(element_text, "axis.title.y"), + axis.title.y = el_def(element_text, "axis.title"), + axis.title.y.left = el_def(element_text, "axis.title.y"), + axis.title.y.right = el_def(element_text, "axis.title.y"), - axis.minor.ticks.x.top = el_def(element_line, "axis.ticks.x.top"), + axis.minor.ticks.x.top = el_def(element_line, "axis.ticks.x.top"), axis.minor.ticks.x.bottom = el_def(element_line, "axis.ticks.x.bottom"), - axis.minor.ticks.y.left = el_def(element_line, "axis.ticks.y.left"), - axis.minor.ticks.y.right = el_def(element_line, "axis.ticks.y.right"), - axis.minor.ticks.theta = el_def(element_line, "axis.ticks.theta"), - axis.minor.ticks.r = el_def(element_line, "axis.ticks.r"), + axis.minor.ticks.y.left = el_def(element_line, "axis.ticks.y.left"), + axis.minor.ticks.y.right = el_def(element_line, "axis.ticks.y.right"), + axis.minor.ticks.theta = el_def(element_line, "axis.ticks.theta"), + axis.minor.ticks.r = el_def(element_line, "axis.ticks.r"), axis.minor.ticks.length = el_def(c("unit", "rel")), - axis.minor.ticks.length.x = el_def(c("unit", "rel"), "axis.minor.ticks.length"), + axis.minor.ticks.length.x = el_def( + c("unit", "rel"), + "axis.minor.ticks.length" + ), axis.minor.ticks.length.x.top = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.x", "axis.ticks.length.x.top") + c("unit", "rel"), + c("axis.minor.ticks.length.x", "axis.ticks.length.x.top") ), axis.minor.ticks.length.x.bottom = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.x", "axis.ticks.length.x.bottom") + c("unit", "rel"), + c("axis.minor.ticks.length.x", "axis.ticks.length.x.bottom") + ), + axis.minor.ticks.length.y = el_def( + c("unit", "rel"), + "axis.minor.ticks.length" ), - axis.minor.ticks.length.y = el_def(c("unit", "rel"), "axis.minor.ticks.length"), axis.minor.ticks.length.y.left = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.y", "axis.ticks.length.y.left") + c("unit", "rel"), + c("axis.minor.ticks.length.y", "axis.ticks.length.y.left") ), axis.minor.ticks.length.y.right = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.y", "axis.ticks.length.y.right") + c("unit", "rel"), + c("axis.minor.ticks.length.y", "axis.ticks.length.y.right") ), axis.minor.ticks.length.theta = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.x", "axis.ticks.length.theta"), + c("unit", "rel"), + c("axis.minor.ticks.length.x", "axis.ticks.length.theta"), ), axis.minor.ticks.length.r = el_def( - c("unit", "rel"), c("axis.minor.ticks.length.y", "axis.ticks.length.r") + c("unit", "rel"), + c("axis.minor.ticks.length.y", "axis.ticks.length.r") ), - legend.background = el_def(element_rect, "rect"), - legend.margin = el_def(c("margin", "unit", "rel"), "margins"), - legend.spacing = el_def(c("unit", "rel"), "spacing"), - legend.spacing.x = el_def(c("unit", "rel"), "legend.spacing"), - legend.spacing.y = el_def(c("unit", "rel"), "legend.spacing"), - legend.key = el_def(element_rect, "panel.background"), - legend.key.height = el_def(c("unit", "rel"), "legend.key.size"), - legend.key.width = el_def(c("unit", "rel"), "legend.key.size"), - legend.key.spacing = el_def(c("unit", "rel"), "spacing"), + legend.background = el_def(element_rect, "rect"), + legend.margin = el_def(c("margin", "unit", "rel"), "margins"), + legend.spacing = el_def(c("unit", "rel"), "spacing"), + legend.spacing.x = el_def(c("unit", "rel"), "legend.spacing"), + legend.spacing.y = el_def(c("unit", "rel"), "legend.spacing"), + legend.key = el_def(element_rect, "panel.background"), + legend.key.height = el_def(c("unit", "rel"), "legend.key.size"), + legend.key.width = el_def(c("unit", "rel"), "legend.key.size"), + legend.key.spacing = el_def(c("unit", "rel"), "spacing"), legend.key.spacing.x = el_def(c("unit", "rel"), "legend.key.spacing"), legend.key.spacing.y = el_def(c("unit", "rel"), "legend.key.spacing"), legend.key.justification = el_def(c("character", "numeric", "integer")), - legend.frame = el_def(element_rect, "rect"), - legend.axis.line = el_def(element_line, "line"), - legend.ticks = el_def(element_line, "legend.axis.line"), + legend.frame = el_def(element_rect, "rect"), + legend.axis.line = el_def(element_line, "line"), + legend.ticks = el_def(element_line, "legend.axis.line"), legend.ticks.length = el_def(c("rel", "unit"), "legend.key.size"), - legend.text = el_def(element_text, "text"), + legend.text = el_def(element_text, "text"), legend.text.position = el_def("character"), - legend.title = el_def(element_text, "title"), + legend.title = el_def(element_text, "title"), legend.title.position = el_def("character"), - legend.byrow = el_def("logical"), - legend.position = el_def("character"), + legend.byrow = el_def("logical"), + legend.position = el_def("character"), legend.position.inside = el_def(c("numeric", "integer")), - legend.direction = el_def("character"), + legend.direction = el_def("character"), legend.justification = el_def(c("character", "numeric", "integer")), legend.justification.top = el_def( @@ -940,70 +1208,126 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { "legend.justification" ), - legend.location = el_def("character"), + legend.location = el_def("character"), - legend.box = el_def("character"), - legend.box.just = el_def("character"), - legend.box.margin = el_def(c("margin", "unit", "rel"), "margins"), + legend.box = el_def("character"), + legend.box.just = el_def("character"), + legend.box.margin = el_def(c("margin", "unit", "rel"), "margins"), legend.box.background = el_def(element_rect, "rect"), - legend.box.spacing = el_def(c("unit", "rel"), "spacing"), - - panel.background = el_def(element_rect, "rect"), - panel.border = el_def(element_rect, "rect"), - panel.spacing = el_def(c("unit", "rel"), "spacing"), - panel.spacing.x = el_def(c("unit", "rel"), "panel.spacing"), - panel.spacing.y = el_def(c("unit", "rel"), "panel.spacing"), - panel.grid.major.x = el_def(element_line, "panel.grid.major"), - panel.grid.major.y = el_def(element_line, "panel.grid.major"), - panel.grid.minor.x = el_def(element_line, "panel.grid.minor"), - panel.grid.minor.y = el_def(element_line, "panel.grid.minor"), - panel.ontop = el_def("logical"), - panel.widths = el_def("unit"), - panel.heights = el_def("unit"), - - strip.background = el_def(element_rect, "rect"), - strip.background.x = el_def(element_rect, "strip.background"), - strip.background.y = el_def(element_rect, "strip.background"), - strip.clip = el_def("character"), - strip.text.x = el_def(element_text, "strip.text"), - strip.text.x.top = el_def(element_text, "strip.text.x"), + legend.box.spacing = el_def(c("unit", "rel"), "spacing"), + + panel.background = el_def(element_rect, "rect"), + panel.border = el_def(element_rect, "rect"), + panel.spacing = el_def(c("unit", "rel"), "spacing"), + panel.spacing.x = el_def(c("unit", "rel"), "panel.spacing"), + panel.spacing.y = el_def(c("unit", "rel"), "panel.spacing"), + panel.grid.major.x = el_def(element_line, "panel.grid.major"), + panel.grid.major.y = el_def(element_line, "panel.grid.major"), + panel.grid.minor.x = el_def(element_line, "panel.grid.minor"), + panel.grid.minor.y = el_def(element_line, "panel.grid.minor"), + panel.ontop = el_def("logical"), + panel.widths = el_def("unit"), + panel.heights = el_def("unit"), + + strip.background = el_def(element_rect, "rect"), + strip.background.x = el_def(element_rect, "strip.background"), + strip.background.y = el_def(element_rect, "strip.background"), + strip.clip = el_def("character"), + strip.text.x = el_def(element_text, "strip.text"), + strip.text.x.top = el_def(element_text, "strip.text.x"), strip.text.x.bottom = el_def(element_text, "strip.text.x"), - strip.text.y = el_def(element_text, "strip.text"), - strip.text.y.left = el_def(element_text, "strip.text.y"), - strip.text.y.right = el_def(element_text, "strip.text.y"), - strip.placement = el_def("character"), - strip.placement.x = el_def("character", "strip.placement"), - strip.placement.y = el_def("character", "strip.placement"), + strip.text.y = el_def(element_text, "strip.text"), + strip.text.y.left = el_def(element_text, "strip.text.y"), + strip.text.y.right = el_def(element_text, "strip.text.y"), + strip.placement = el_def("character"), + strip.placement.x = el_def("character", "strip.placement"), + strip.placement.y = el_def("character", "strip.placement"), strip.switch.pad.grid = el_def(c("unit", "rel"), "spacing"), strip.switch.pad.wrap = el_def(c("unit", "rel"), "spacing"), - plot.background = el_def(element_rect, "rect"), - plot.title = el_def(element_text, "title"), + plot.background = el_def(element_rect, "rect"), + plot.title = el_def(element_text, "title"), plot.title.position = el_def("character"), - plot.subtitle = el_def(element_text, "text"), - plot.caption = el_def(element_text, "text"), + plot.subtitle = el_def(element_text, "text"), + plot.caption = el_def(element_text, "text"), plot.caption.position = el_def("character"), - plot.tag = el_def(element_text, "text"), - plot.tag.position = el_def(c("character", "numeric", "integer")), # Need to also accept numbers - plot.tag.location = el_def("character"), - plot.margin = el_def(c("margin", "unit", "rel"), "margins"), + plot.tag = el_def(element_text, "text"), + plot.tag.position = el_def(c("character", "numeric", "integer")), # Need to also accept numbers + plot.tag.location = el_def("character"), + plot.margin = el_def(c("margin", "unit", "rel"), "margins"), - palette.colour.discrete = el_def(c("character", "function")), + palette.colour.discrete = el_def(c("character", "function")), palette.colour.continuous = el_def(c("character", "function")), - palette.fill.discrete = el_def(c("character", "function"), "palette.colour.discrete"), - palette.fill.continuous = el_def(c("character", "function"), "palette.colour.continuous"), - palette.alpha.discrete = el_def(c("character", "numeric", "integer", "function")), - palette.alpha.continuous = el_def(c("character", "numeric", "integer", "function")), - palette.linewidth.discrete = el_def(c("character", "numeric", "integer", "function")), - palette.linewidth.continuous = el_def(c("character", "numeric", "integer", "function")), - palette.size.discrete = el_def(c("character", "numeric", "integer", "function")), - palette.size.continuous = el_def(c("character", "numeric", "integer", "function")), - palette.shape.discrete = el_def(c("character", "numeric", "integer", "function")), - palette.shape.continuous = el_def(c("character", "numeric", "integer", "function")), - palette.linetype.discrete = el_def(c("character", "numeric", "integer", "function")), - palette.linetype.continuous = el_def(c("character", "numeric", "integer", "function")), - - aspect.ratio = el_def(c("numeric", "integer")) + palette.fill.discrete = el_def( + c("character", "function"), + "palette.colour.discrete" + ), + palette.fill.continuous = el_def( + c("character", "function"), + "palette.colour.continuous" + ), + palette.alpha.discrete = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.alpha.continuous = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.linewidth.discrete = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.linewidth.continuous = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.size.discrete = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.size.continuous = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.shape.discrete = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.shape.continuous = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.linetype.discrete = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + palette.linetype.continuous = el_def(c( + "character", + "numeric", + "integer", + "function" + )), + + aspect.ratio = el_def(c("numeric", "integer")) ) # Check that an element object has the proper class @@ -1021,12 +1345,17 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { eldef <- element_tree[[elname]] if (is.null(eldef)) { - cli::cli_warn("The {.var {elname}} theme element is not defined in the element hierarchy.", call = call) + cli::cli_warn( + "The {.var {elname}} theme element is not defined in the element hierarchy.", + call = call + ) return() } # NULL values for elements are OK - if (is.null(el)) return() + if (is.null(el)) { + return() + } class <- eldef$class if (inherits(class, "S7_class")) { diff --git a/R/theme-sub.R b/R/theme-sub.R index 72a60ebf72..99f454e28e 100644 --- a/R/theme-sub.R +++ b/R/theme-sub.R @@ -54,43 +54,96 @@ subtheme <- function(elements, prefix = "", suffix = "", call = caller_env()) { #' @export #' @describeIn subtheme Theme specification for all axes. -theme_sub_axis <- function(title, text, ticks, ticks.length, line, minor.ticks.length) { +theme_sub_axis <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks.length +) { subtheme(find_args(), "axis.") } #' @export #' @describeIn subtheme Theme specification for both x axes. -theme_sub_axis_x <- function(title, text, ticks, ticks.length, line, minor.ticks.length) { +theme_sub_axis_x <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".x") } #' @export #' @describeIn subtheme Theme specification for both y axes. -theme_sub_axis_y <- function(title, text, ticks, ticks.length, line, minor.ticks.length) { +theme_sub_axis_y <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".y") } #' @export #' @describeIn subtheme Theme specification for the bottom x axis. -theme_sub_axis_bottom <- function(title, text, ticks, ticks.length, line, minor.ticks, minor.ticks.length) { +theme_sub_axis_bottom <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".x.bottom") } #' @export #' @describeIn subtheme Theme specification for the top x axis. -theme_sub_axis_top <- function(title, text, ticks, ticks.length, line, minor.ticks, minor.ticks.length) { +theme_sub_axis_top <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".x.top") } #' @export #' @describeIn subtheme Theme specification for the left y axis. -theme_sub_axis_left <- function(title, text, ticks, ticks.length, line, minor.ticks, minor.ticks.length) { +theme_sub_axis_left <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".y.left") } #' @export #' @describeIn subtheme Theme specification for the right y axis. -theme_sub_axis_right <- function(title, text, ticks, ticks.length, line, minor.ticks, minor.ticks.length) { +theme_sub_axis_right <- function( + title, + text, + ticks, + ticks.length, + line, + minor.ticks, + minor.ticks.length +) { subtheme(find_args(), "axis.", ".y.right") } @@ -98,56 +151,126 @@ theme_sub_axis_right <- function(title, text, ticks, ticks.length, line, minor.t #' @describeIn subtheme Theme specification for the legend. theme_sub_legend <- function( # Text stuff - text, text.position, title, title.position, + text, + text.position, + title, + title.position, # Drawn elements - background, frame, ticks, ticks.length, axis.line, + background, + frame, + ticks, + ticks.length, + axis.line, # Spacings - spacing, spacing.x, spacing.y, margin, + spacing, + spacing.x, + spacing.y, + margin, # Seys - key, key.size, key.height, key.width, key.spacing, key.spacing.x, - key.spacing.y, key.justification, + key, + key.size, + key.height, + key.width, + key.spacing, + key.spacing.x, + key.spacing.y, + key.justification, # Settings - byrow, position, direction, location, position.inside, + byrow, + position, + direction, + location, + position.inside, # Justification - justification, justification.top, justification.bottom, justification.left, - justification.right, justification.inside, + justification, + justification.top, + justification.bottom, + justification.left, + justification.right, + justification.inside, # Box - box, box.just, box.margin, box.background, box.spacing + box, + box.just, + box.margin, + box.background, + box.spacing ) { subtheme(find_args(), "legend.") } #' @export #' @describeIn subtheme Theme specification for the panels. -theme_sub_panel <- function(background, border, - widths, heights, spacing, spacing.x, spacing.y, - grid, grid.major, grid.minor, grid.major.x, - grid.major.y, grid.minor.x, grid.minor.y, ontop) { +theme_sub_panel <- function( + background, + border, + widths, + heights, + spacing, + spacing.x, + spacing.y, + grid, + grid.major, + grid.minor, + grid.major.x, + grid.major.y, + grid.minor.x, + grid.minor.y, + ontop +) { subtheme(find_args(), "panel.") } #' @export #' @describeIn subtheme Theme specification for the whole plot. -theme_sub_plot <- function(background, title, title.position, subtitle, caption, - caption.position, tag, tag.position, tag.location, - margin) { +theme_sub_plot <- function( + background, + title, + title.position, + subtitle, + caption, + caption.position, + tag, + tag.position, + tag.location, + margin +) { subtheme(find_args(), "plot.") } #' @export #' @describeIn subtheme Theme specification for facet strips. -theme_sub_strip <- function(background, background.x, background.y, clip, - placement, text, text.x, text.x.bottom, text.x.top, - text.y, text.y.left, text.y.right, - switch.pad.grid, switch.pad.wrap) { +theme_sub_strip <- function( + background, + background.x, + background.y, + clip, + placement, + text, + text.x, + text.x.bottom, + text.x.top, + text.y, + text.y.left, + text.y.right, + switch.pad.grid, + switch.pad.wrap +) { subtheme(find_args(), "strip.") } subtheme_param_doc <- function() { funs <- list( - theme_sub_axis, theme_sub_axis_x, theme_sub_axis_y, theme_sub_axis_bottom, - theme_sub_axis_top, theme_sub_axis_left, theme_sub_axis_right, theme_sub_legend, - theme_sub_panel, theme_sub_plot, theme_sub_strip + theme_sub_axis, + theme_sub_axis_x, + theme_sub_axis_y, + theme_sub_axis_bottom, + theme_sub_axis_top, + theme_sub_axis_left, + theme_sub_axis_right, + theme_sub_legend, + theme_sub_panel, + theme_sub_plot, + theme_sub_strip ) args <- sort(unique(unlist(lapply(funs, fn_fmls_names), use.names = FALSE))) paste0( diff --git a/R/theme.R b/R/theme.R index 63e410fb20..11a8b90476 100644 --- a/R/theme.R +++ b/R/theme.R @@ -335,154 +335,155 @@ #' p4 + aes(colour = drat) + #' theme(palette.colour.continuous = c("white", "pink", "hotpink")) #' } -theme <- function(..., - line, - rect, - text, - title, - point, - polygon, - geom, - spacing, - margins, - aspect.ratio, - axis.title, - axis.title.x, - axis.title.x.top, - axis.title.x.bottom, - axis.title.y, - axis.title.y.left, - axis.title.y.right, - axis.text, - axis.text.x, - axis.text.x.top, - axis.text.x.bottom, - axis.text.y, - axis.text.y.left, - axis.text.y.right, - axis.text.theta, - axis.text.r, - axis.ticks, - axis.ticks.x, - axis.ticks.x.top, - axis.ticks.x.bottom, - axis.ticks.y, - axis.ticks.y.left, - axis.ticks.y.right, - axis.ticks.theta, - axis.ticks.r, - axis.minor.ticks.x.top, - axis.minor.ticks.x.bottom, - axis.minor.ticks.y.left, - axis.minor.ticks.y.right, - axis.minor.ticks.theta, - axis.minor.ticks.r, - axis.ticks.length, - axis.ticks.length.x, - axis.ticks.length.x.top, - axis.ticks.length.x.bottom, - axis.ticks.length.y, - axis.ticks.length.y.left, - axis.ticks.length.y.right, - axis.ticks.length.theta, - axis.ticks.length.r, - axis.minor.ticks.length, - axis.minor.ticks.length.x, - axis.minor.ticks.length.x.top, - axis.minor.ticks.length.x.bottom, - axis.minor.ticks.length.y, - axis.minor.ticks.length.y.left, - axis.minor.ticks.length.y.right, - axis.minor.ticks.length.theta, - axis.minor.ticks.length.r, - axis.line, - axis.line.x, - axis.line.x.top, - axis.line.x.bottom, - axis.line.y, - axis.line.y.left, - axis.line.y.right, - axis.line.theta, - axis.line.r, - legend.background, - legend.margin, - legend.spacing, - legend.spacing.x, - legend.spacing.y, - legend.key, - legend.key.size, - legend.key.height, - legend.key.width, - legend.key.spacing, - legend.key.spacing.x, - legend.key.spacing.y, - legend.key.justification, - legend.frame, - legend.ticks, - legend.ticks.length, - legend.axis.line, - legend.text, - legend.text.position, - legend.title, - legend.title.position, - legend.position, - legend.position.inside, - legend.direction, - legend.byrow, - legend.justification, - legend.justification.top, - legend.justification.bottom, - legend.justification.left, - legend.justification.right, - legend.justification.inside, - legend.location, - legend.box, - legend.box.just, - legend.box.margin, - legend.box.background, - legend.box.spacing, - panel.background, - panel.border, - panel.spacing, - panel.spacing.x, - panel.spacing.y, - panel.grid, - panel.grid.major, - panel.grid.minor, - panel.grid.major.x, - panel.grid.major.y, - panel.grid.minor.x, - panel.grid.minor.y, - panel.ontop, - panel.widths, - panel.heights, - plot.background, - plot.title, - plot.title.position, - plot.subtitle, - plot.caption, - plot.caption.position, - plot.tag, - plot.tag.position, - plot.tag.location, - plot.margin, - strip.background, - strip.background.x, - strip.background.y, - strip.clip, - strip.placement, - strip.text, - strip.text.x, - strip.text.x.bottom, - strip.text.x.top, - strip.text.y, - strip.text.y.left, - strip.text.y.right, - strip.switch.pad.grid, - strip.switch.pad.wrap, - complete = FALSE, - validate = TRUE) { - +theme <- function( + ..., + line, + rect, + text, + title, + point, + polygon, + geom, + spacing, + margins, + aspect.ratio, + axis.title, + axis.title.x, + axis.title.x.top, + axis.title.x.bottom, + axis.title.y, + axis.title.y.left, + axis.title.y.right, + axis.text, + axis.text.x, + axis.text.x.top, + axis.text.x.bottom, + axis.text.y, + axis.text.y.left, + axis.text.y.right, + axis.text.theta, + axis.text.r, + axis.ticks, + axis.ticks.x, + axis.ticks.x.top, + axis.ticks.x.bottom, + axis.ticks.y, + axis.ticks.y.left, + axis.ticks.y.right, + axis.ticks.theta, + axis.ticks.r, + axis.minor.ticks.x.top, + axis.minor.ticks.x.bottom, + axis.minor.ticks.y.left, + axis.minor.ticks.y.right, + axis.minor.ticks.theta, + axis.minor.ticks.r, + axis.ticks.length, + axis.ticks.length.x, + axis.ticks.length.x.top, + axis.ticks.length.x.bottom, + axis.ticks.length.y, + axis.ticks.length.y.left, + axis.ticks.length.y.right, + axis.ticks.length.theta, + axis.ticks.length.r, + axis.minor.ticks.length, + axis.minor.ticks.length.x, + axis.minor.ticks.length.x.top, + axis.minor.ticks.length.x.bottom, + axis.minor.ticks.length.y, + axis.minor.ticks.length.y.left, + axis.minor.ticks.length.y.right, + axis.minor.ticks.length.theta, + axis.minor.ticks.length.r, + axis.line, + axis.line.x, + axis.line.x.top, + axis.line.x.bottom, + axis.line.y, + axis.line.y.left, + axis.line.y.right, + axis.line.theta, + axis.line.r, + legend.background, + legend.margin, + legend.spacing, + legend.spacing.x, + legend.spacing.y, + legend.key, + legend.key.size, + legend.key.height, + legend.key.width, + legend.key.spacing, + legend.key.spacing.x, + legend.key.spacing.y, + legend.key.justification, + legend.frame, + legend.ticks, + legend.ticks.length, + legend.axis.line, + legend.text, + legend.text.position, + legend.title, + legend.title.position, + legend.position, + legend.position.inside, + legend.direction, + legend.byrow, + legend.justification, + legend.justification.top, + legend.justification.bottom, + legend.justification.left, + legend.justification.right, + legend.justification.inside, + legend.location, + legend.box, + legend.box.just, + legend.box.margin, + legend.box.background, + legend.box.spacing, + panel.background, + panel.border, + panel.spacing, + panel.spacing.x, + panel.spacing.y, + panel.grid, + panel.grid.major, + panel.grid.minor, + panel.grid.major.x, + panel.grid.major.y, + panel.grid.minor.x, + panel.grid.minor.y, + panel.ontop, + panel.widths, + panel.heights, + plot.background, + plot.title, + plot.title.position, + plot.subtitle, + plot.caption, + plot.caption.position, + plot.tag, + plot.tag.position, + plot.tag.location, + plot.margin, + strip.background, + strip.background.x, + strip.background.y, + strip.clip, + strip.placement, + strip.text, + strip.text.x, + strip.text.x.bottom, + strip.text.x.top, + strip.text.y, + strip.text.y.left, + strip.text.y.right, + strip.switch.pad.grid, + strip.switch.pad.wrap, + complete = FALSE, + validate = TRUE +) { elements <- find_args(..., complete = NULL, validate = NULL) elements <- fix_theme_deprecations(elements) elements <- validate_theme_palettes(elements) @@ -513,7 +514,8 @@ fix_theme_deprecations <- function(elements) { } if (!is.null(elements$legend.title.align)) { deprecate_soft0( - "3.5.0", "theme(legend.title.align)", + "3.5.0", + "theme(legend.title.align)", I("theme(legend.title = element_text(hjust))") ) if (is.null(elements[["legend.title"]])) { @@ -526,7 +528,8 @@ fix_theme_deprecations <- function(elements) { } if (!is.null(elements$legend.text.align)) { deprecate_soft0( - "3.5.0", "theme(legend.text.align)", + "3.5.0", + "theme(legend.text.align)", I("theme(legend.text = element_text(hjust))") ) if (is.null(elements[["legend.text"]])) { @@ -539,7 +542,8 @@ fix_theme_deprecations <- function(elements) { } if (is.numeric(elements[["legend.position"]])) { deprecate_soft0( - "3.5.0", I("A numeric `legend.position` argument in `theme()`"), + "3.5.0", + I("A numeric `legend.position` argument in `theme()`"), "theme(legend.position.inside)" ) elements$legend.position.inside <- elements$legend.position @@ -549,29 +553,43 @@ fix_theme_deprecations <- function(elements) { } validate_theme_palettes <- function(elements) { - - pals <- c("palette.colour.discrete", "palette.colour.continuous", - "palette.fill.discrete", "palette.fill.continuous", - "palette.color.discrete", "palette.color.continuous") + pals <- c( + "palette.colour.discrete", + "palette.colour.continuous", + "palette.fill.discrete", + "palette.fill.continuous", + "palette.color.discrete", + "palette.color.continuous" + ) if (!any(pals %in% names(elements))) { return(elements) } # Standardise spelling if ("palette.color.continuous" %in% names(elements)) { - elements["palette.colour.continuous"] <- elements["palette.color.continuous"] + elements["palette.colour.continuous"] <- elements[ + "palette.color.continuous" + ] elements[["palette.color.continuous"]] <- NULL } if ("palette.color.discrete" %in% names(elements)) { - elements["palette.colour.discrete"] <- elements["palette.color.discrete"] + elements["palette.colour.discrete"] <- elements["palette.color.discrete"] elements[["palette.color.discrete"]] <- NULL } # Check for incompatible options - pals <- c("palette.colour.discrete", "palette.colour.continuous", - "palette.fill.discrete", "palette.fill.continuous") - opts <- c("ggplot2.discrete.colour", "ggplot2.continuous.colour", - "ggplot2.discrete.fill", "ggplot2.continuous.fill") + pals <- c( + "palette.colour.discrete", + "palette.colour.continuous", + "palette.fill.discrete", + "palette.fill.continuous" + ) + opts <- c( + "ggplot2.discrete.colour", + "ggplot2.continuous.colour", + "ggplot2.discrete.fill", + "ggplot2.continuous.fill" + ) index <- which(pals %in% names(elements)) for (i in index) { @@ -618,7 +636,9 @@ check_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { elnames[startsWith(elnames, "geom.")] <- "geom" mapply( - check_element, theme, elnames, + check_element, + theme, + elnames, MoreArgs = list(element_tree = tree, call = call) ) } @@ -660,7 +680,6 @@ plot_theme <- function(x, default = get_theme()) { theme <- x$theme } - # apply theme defaults appropriately if needed if (is_theme_complete(theme)) { # for complete themes, we fill in missing elements but don't do any element merging @@ -698,13 +717,15 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { if (is.null(t2)) { return(t1) } - if (!is.list(t2)) { # in various places in the code base, simple lists are used as themes + if (!is.list(t2)) { + # in various places in the code base, simple lists are used as themes cli::cli_abort("Can't add {.arg {t2name}} to a theme object.", call = call) } # If t2 is a complete theme or t1 is NULL, just return t2 - if (is_theme_complete(t2) || is.null(t1)) + if (is_theme_complete(t2) || is.null(t1)) { return(t2) + } # Iterate over the elements that are to be updated try_fetch( @@ -717,7 +738,11 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { t1[item] <- list(x) }, error = function(cnd) { - cli::cli_abort("Can't merge the {.var {item}} theme element.", parent = cnd, call = call) + cli::cli_abort( + "Can't merge the {.var {item}} theme element.", + parent = cnd, + call = call + ) } ) @@ -754,9 +779,16 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { #' t$axis.text.x #' t$axis.text #' t$text -calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, - call = caller_env()) { - if (verbose) cli::cli_inform(paste0(element, " --> ")) +calc_element <- function( + element, + theme, + verbose = FALSE, + skip_blank = FALSE, + call = caller_env() +) { + if (verbose) { + cli::cli_inform(paste0(element, " --> ")) + } el_out <- theme[[element]] @@ -766,7 +798,9 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, if (isTRUE(skip_blank)) { el_out <- NULL } else { - if (verbose) cli::cli_inform("{.fn element_blank} (no inheritance)") + if (verbose) { + cli::cli_inform("{.fn element_blank} (no inheritance)") + } return(el_out) } } @@ -781,11 +815,17 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, if (inherits(class, "S7_class")) { old_s3_inherit <- inherits(el_out, class@name) if (!S7::S7_inherits(el_out, class) && !old_s3_inherit) { - cli::cli_abort("Theme element {.var {element}} must have class {.cls {class@name}}.", call = call) + cli::cli_abort( + "Theme element {.var {element}} must have class {.cls {class@name}}.", + call = call + ) } } else { if (!inherits(el_out, class)) { - cli::cli_abort("Theme element {.var {element}} must have class {.cls {ggplot_global$element_tree[[element]]$class}}.", call = call) + cli::cli_abort( + "Theme element {.var {element}} must have class {.cls {ggplot_global$element_tree[[element]]$class}}.", + call = call + ) } } } @@ -795,7 +835,9 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # If no parents, this is a "root" node. Just return this element. if (is.null(pnames)) { - if (verbose) cli::cli_inform("nothing (top level)") + if (verbose) { + cli::cli_inform("nothing (top level)") + } # Check that all the properties of this element are non-NULL if (is_theme_element(el_out)) { @@ -823,11 +865,16 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, return(el_out) # no null properties remaining, return element } - cli::cli_abort("Theme element {.var {element}} has {.code NULL} property without default: {.field {names(nullprops)[nullprops]}}.", call = call) + cli::cli_abort( + "Theme element {.var {element}} has {.code NULL} property without default: {.field {names(nullprops)[nullprops]}}.", + call = call + ) } # Calculate the parent objects' inheritance - if (verbose) cli::cli_inform("{pnames}") + if (verbose) { + cli::cli_inform("{pnames}") + } # once we've started skipping blanks, we continue doing so until the end of the # recursion; we initiate skipping blanks if we encounter an element that @@ -867,7 +914,8 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, #' merge_element(new, old) #' merge_element <- S7::new_generic( - "merge_element", dispatch_args = c("new", "old"), + "merge_element", + dispatch_args = c("new", "old"), fun = function(new, old, ...) { # If old is NULL or element_blank, then just return new if (is.null(old) || is_theme_element(old, "blank")) { @@ -877,16 +925,24 @@ merge_element <- S7::new_generic( } ) -S7::method(merge_element, list(S7::class_any, S7::class_any)) <- +S7::method(merge_element, list(S7::class_any, S7::class_any)) <- function(new, old, ...) { - if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || - is.logical(new) || is.function(new)) { + if ( + is.null(new) || + is.character(new) || + is.numeric(new) || + is.unit(new) || + is.logical(new) || + is.function(new) + ) { # If new is NULL, or a string, numeric vector, unit, or logical, just return it return(new) } # otherwise we can't merge - cli::cli_abort("No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}.") + cli::cli_abort( + "No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}." + ) } S7::method(merge_element, list(element_blank, S7::class_any)) <- @@ -912,7 +968,7 @@ S7::method(merge_element, list(element, S7::class_any)) <- S7::props(new)[idx] <- S7::props(old, idx) new -} + } S7::method(merge_element, list(margin, S7::class_any)) <- function(new, old, ...) { @@ -943,7 +999,6 @@ S7::method(merge_element, list(S7::new_S3_class("element"), S7::class_any)) <- #' @noRd #' combine_elements <- function(e1, e2) { - # If e2 is NULL, nothing to inherit if (is.null(e2) || is_theme_element(e1, "blank")) { return(e1) diff --git a/R/utilities-break.R b/R/utilities-break.R index 11bc22019d..70c6df2113 100644 --- a/R/utilities-break.R +++ b/R/utilities-break.R @@ -34,9 +34,10 @@ cut_interval <- function(x, n = NULL, length = NULL, ...) { #' @rdname cut_interval cut_number <- function(x, n = NULL, ...) { brk <- breaks(x, "numbers", n) - if (anyDuplicated(brk)) + if (anyDuplicated(brk)) { cli::cli_abort("Insufficient data values to produce {n} bins.") - cut(x, brk , include.lowest = TRUE, ...) + } + cut(x, brk, include.lowest = TRUE, ...) } #' @export @@ -52,7 +53,14 @@ cut_number <- function(x, n = NULL, ...) { #' `boundary = 0.5`. #' @param closed One of `"right"` or `"left"` indicating whether right #' or left edges of bins are included in the bin. -cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right", ...) { +cut_width <- function( + x, + width, + center = NULL, + boundary = NULL, + closed = "right", + ... +) { x <- as.numeric(x) width <- as.numeric(width) @@ -65,7 +73,9 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" # Determine boundary if (!is.null(boundary) && !is.null(center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.") + cli::cli_abort( + "Only one of {.arg boundary} and {.arg center} may be specified." + ) } if (is.null(boundary)) { if (is.null(center)) { @@ -91,7 +101,10 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" breaks <- function(x, equal, nbins = NULL, binwidth = NULL) { equal <- arg_match0(equal, c("numbers", "width")) - if ((!is.null(nbins) && !is.null(binwidth)) || (is.null(nbins) && is.null(binwidth))) { + if ( + (!is.null(nbins) && !is.null(binwidth)) || + (is.null(nbins) && is.null(binwidth)) + ) { cli::cli_abort("Specify exactly one of {.arg n} and {.arg width}.") } @@ -110,6 +123,4 @@ breaks <- function(x, equal, nbins = NULL, binwidth = NULL) { } stats::quantile(x, probs, na.rm = TRUE) } - } - diff --git a/R/utilities-checks.R b/R/utilities-checks.R index d444e8c3d0..e2a419bbc2 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -1,17 +1,17 @@ - # Extra checks in addition to the ones in import-standalone-types-check.R # Usage: # check_object(x, is.data.frame, "a data.frame) -check_object <- function(x, - check_fun, - what, - ..., - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - +check_object <- function( + x, + check_fun, + what, + ..., + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env() +) { if (!missing(x)) { if (check_fun(x)) { return(invisible(NULL)) @@ -34,22 +34,25 @@ check_object <- function(x, ) } -check_numeric <- function(x, - what = "a {.cls numeric} vector", - ..., - arg = caller_arg(x), - call = caller_env()) { +check_numeric <- function( + x, + what = "a {.cls numeric} vector", + ..., + arg = caller_arg(x), + call = caller_env() +) { check_object(x, is.numeric, what, ..., arg = arg, call = call) } -check_inherits <- function(x, - class, - what = NULL, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - +check_inherits <- function( + x, + class, + what = NULL, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env() +) { if (!missing(x)) { if (inherits(x, class)) { return(invisible(NULL)) @@ -59,9 +62,12 @@ check_inherits <- function(x, } } - what <- what %||% paste( - "a", oxford_comma(paste0("{.cls ", class, "}")), "object" - ) + what <- what %||% + paste( + "a", + oxford_comma(paste0("{.cls ", class, "}")), + "object" + ) stop_input_type( x, @@ -73,8 +79,15 @@ check_inherits <- function(x, ) } -check_length <- function(x, length = integer(), ..., min = 0, max = Inf, - arg = caller_arg(x), call = caller_env()) { +check_length <- function( + x, + length = integer(), + ..., + min = 0, + max = Inf, + arg = caller_arg(x), + call = caller_env() +) { if (missing(x)) { stop_input_type(x, "a vector", arg = arg, call = call) } @@ -96,7 +109,9 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, } msg <- sprintf( "%s must be %s, not length %d.", - fmt(arg), type, n + fmt(arg), + type, + n ) cli::cli_abort(msg, call = call, arg = arg) } @@ -122,7 +137,10 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, msg <- sprintf( "`%s` must be a %s with %s, not length %d.", - fmt(arg), type, what, n + fmt(arg), + type, + what, + n ) cli::cli_abort(msg, call = call, arg = arg) } @@ -240,13 +258,17 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, #' #' # Possibly throw an error #' try(check_device("glyphs", action = "abort")) -check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, - call = caller_env()) { - +check_device <- function( + feature, + action = "warn", + op = NULL, + maybe = FALSE, + call = caller_env() +) { check_bool(maybe, allow_na = TRUE) # Grab device for checking - dev_cur <- grDevices::dev.cur() + dev_cur <- grDevices::dev.cur() dev_name <- names(dev_cur) if (dev_name == "null device") { @@ -256,29 +278,39 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, action <- arg_match0(action, c("test", "warn", "abort")) action_fun <- switch( action, - warn = cli::cli_warn, + warn = cli::cli_warn, abort = cli::cli_abort, function(...) invisible() ) feature <- arg_match0( feature, - c("clippingPaths", "alpha_masks", "lumi_masks", "compositing", "blending", - "transformations", "glyphs", "patterns", "gradients", "paths", - ".test_feature") + c( + "clippingPaths", + "alpha_masks", + "lumi_masks", + "compositing", + "blending", + "transformations", + "glyphs", + "patterns", + "gradients", + "paths", + ".test_feature" + ) ) # Formatting prettier feature names feat_name <- switch( feature, - clippingPaths = "clipping paths", - patterns = "tiled patterns", - blending = "blend modes", - gradients = "colour gradients", - glyphs = "typeset glyphs", - paths = "stroking and filling paths", + clippingPaths = "clipping paths", + patterns = "tiled patterns", + blending = "blend modes", + gradients = "colour gradients", + glyphs = "typeset glyphs", + paths = "stroking and filling paths", transformations = "affine transformations", - alpha_masks = "alpha masks", - lumi_masks = "luminance masks", + alpha_masks = "alpha masks", + lumi_masks = "luminance masks", feature ) @@ -287,16 +319,19 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, capable <- switch( feature, glyphs = version >= "4.3.0", - paths =, transformations =, compositing =, - patterns =, lumi_masks =, blending =, + paths = , + transformations = , + compositing = , + patterns = , + lumi_masks = , + blending = , gradients = version >= "4.2.0", - alpha_masks =, + alpha_masks = , clippingPaths = version >= "4.1.0", TRUE ) if (isFALSE(capable)) { - action_fun("R {version} does not support {.emph {feature}}.", - call = call) + action_fun("R {version} does not support {.emph {feature}}.", call = call) return(FALSE) } @@ -306,20 +341,22 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, # device to check capabilities. dev_old <- dev_cur on.exit(grDevices::dev.set(dev_old), add = TRUE) - dev_cur <- grDevices::dev.set(grDevices::dev.next()) + dev_cur <- grDevices::dev.set(grDevices::dev.next()) dev_name <- names(dev_cur) } # {ragg} and {svglite} report capabilities, but need specific version if (dev_name %in% c("agg_jpeg", "agg_ppm", "agg_png", "agg_tiff")) { check_installed( - "ragg", version = "1.2.6", + "ragg", + version = "1.2.6", reason = paste0("for checking device support for ", feat_name, ".") ) } if (dev_name == "devSVG") { check_installed( - "svglite", version = "2.1.2", + "svglite", + version = "2.1.2", reason = paste0("for checking device support for ", feat_name, ".") ) } @@ -361,7 +398,7 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, gradients = !all(is.na(capa$patterns)) && !all(c("LinearGradient", "RadialGradient") %in% capa$patterns), alpha_masks = !is.na(capa$masks) && !("alpha" %in% capa$masks), - lumi_masks = !is.na(capa$masks) && !("luminance" %in% capa$masks), + lumi_masks = !is.na(capa$masks) && !("luminance" %in% capa$masks), patterns = !is.na(capa$patterns) && !("TilingPattern" %in% capa$patterns), compositing = !all(is.na(capa$compositing)) && !all(.compo_ops %in% capa$compositing), @@ -412,10 +449,33 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, return(maybe) } -.compo_ops <- c("clear", "source", "over", "in", "out", "atop", "dest", - "dest.over", "dest.in", "dest.out", "dest.atop", "xor", "add", - "saturate") - -.blend_ops <- c("multiply", "screen", "overlay", "darken", "lighten", - "color.dodge", "color.burn", "hard.light", "soft.light", - "difference", "exclusion") +.compo_ops <- c( + "clear", + "source", + "over", + "in", + "out", + "atop", + "dest", + "dest.over", + "dest.in", + "dest.out", + "dest.atop", + "xor", + "add", + "saturate" +) + +.blend_ops <- c( + "multiply", + "screen", + "overlay", + "darken", + "lighten", + "color.dodge", + "color.burn", + "hard.light", + "soft.light", + "difference", + "exclusion" +) diff --git a/R/utilities-help.R b/R/utilities-help.R index d0c0a15576..c8f27bedd3 100644 --- a/R/utilities-help.R +++ b/R/utilities-help.R @@ -1,7 +1,8 @@ # Use extra_note arg to add some notes (e.g. the document is shared with multiple # Geoms and there's some difference among their aesthetics). rd_aesthetics <- function(type, name, extra_note = NULL) { - obj <- switch(type, + obj <- switch( + type, geom = validate_subclass(name, "Geom", env = globalenv()), stat = validate_subclass(name, "Stat", env = globalenv()), position = validate_subclass(name, "Position", env = globalenv()) @@ -11,11 +12,17 @@ rd_aesthetics <- function(type, name, extra_note = NULL) { c( "@section Aesthetics:", paste0( - "\\code{", type, "_", name, "()} ", + "\\code{", + type, + "_", + name, + "()} ", "understands the following aesthetics. Required aesthetics are displayed", " in bold and defaults are displayed for optional aesthetics:" ), - "\\tabular{rll}{", aes, "}", + "\\tabular{rll}{", + aes, + "}", if (!is.null(extra_note)) paste0(extra_note, "\n"), "Learn more about setting these aesthetics in \\code{vignette(\"ggplot2-specs\")}." ) @@ -30,7 +37,8 @@ rd_aesthetics_item <- function(x) { docs <- rd_match_docpage(all) defaults <- rd_defaults(x, all) - item <- ifelse(all %in% req, + item <- ifelse( + all %in% req, paste0("\\strong{\\code{", docs, "}}"), paste0("\\code{", docs, "}") ) @@ -59,27 +67,45 @@ rd_defaults <- function(layer, aesthetics) { } rd_match_docpage <- function(aes) { - split <- strsplit(aes, "} \\emph{or} \\code{", fixed = TRUE) - flat <- unlist(split) + flat <- unlist(split) index <- match( flat, c( - "x", "y", "xmin", "xmax", "ymin", "ymax", "xend", 'yend', - "colour", "fill", "alpha", + "x", + "y", + "xmin", + "xmax", + "ymin", + "ymax", + "xend", + 'yend', + "colour", + "fill", + "alpha", "group", - "linetype", "size", "shape", "linewidth" - ), nomatch = 0L + "linetype", + "size", + "shape", + "linewidth" + ), + nomatch = 0L ) docpage <- c( - "", rep("aes_position", 8), rep("aes_colour_fill_alpha", 3), - "aes_group_order", rep("aes_linetype_size_shape", 4) + "", + rep("aes_position", 8), + rep("aes_colour_fill_alpha", 3), + "aes_group_order", + rep("aes_linetype_size_shape", 4) )[index + 1] no_match <- index == 0 docpage[!no_match] <- paste0( - "\\link[ggplot2:", docpage[!no_match], - "]{", flat[!no_match], "}" + "\\link[ggplot2:", + docpage[!no_match], + "]{", + flat[!no_match], + "}" ) docpage[no_match] <- flat[no_match] docpage <- split(docpage, rep(seq_along(split), lengths(split, FALSE))) @@ -130,35 +156,39 @@ rd_orientation <- function() { #' corge = "grault" #' ) rd_computed_vars <- function(..., .details = "", .skip_intro = FALSE) { - args <- list(...) + args <- list(...) items <- names(args) descr <- unname(args) # Format preamble header <- "@section Computed variables: " - intro <- paste0( + intro <- paste0( "These are calculated by the 'stat' part of layers and can be accessed ", "with [delayed evaluation][aes_eval]. " ) - if (.skip_intro) intro <- "" + if (.skip_intro) { + intro <- "" + } preamble <- c(header, paste0(intro, gsub("\n", "", .details))) # Format items fmt_items <- gsub(",", ")`, `after_stat(", items, fixed = TRUE) - fmt_items <- gsub("|", ")` *or* `after_stat(", - fmt_items, fixed = TRUE) + fmt_items <- gsub("|", ")` *or* `after_stat(", fmt_items, fixed = TRUE) fmt_items <- paste0("* `after_stat(", fmt_items, ")`") # Compose item-list fmt_descr <- gsub("\n", "", descr) - fmt_list <- paste(fmt_items, fmt_descr, sep = "\\cr ") + fmt_list <- paste(fmt_items, fmt_descr, sep = "\\cr ") c(preamble, fmt_list) } -link_book <- function(text = "", section = "", - book = "https://ggplot2-book.org/", - suffix = "of the online ggplot2 book.") { +link_book <- function( + text = "", + section = "", + book = "https://ggplot2-book.org/", + suffix = "of the online ggplot2 book." +) { links <- paste0("[", text, "](", book, section, ")") if (length(links) > 1) { links <- oxford_comma(links, final = "and") @@ -167,7 +197,12 @@ link_book <- function(text = "", section = "", } roxy_tag_parse.roxy_tag_aesthetics <- function(x) { - x <- roxygen2::tag_two_part(x, "an argument name", "a description", required = FALSE) + x <- roxygen2::tag_two_part( + x, + "an argument name", + "a description", + required = FALSE + ) class <- get0(x$val$name, parent.frame()) if (!inherits(class, c("Geom", "Stat", "Position"))) { @@ -176,17 +211,21 @@ roxy_tag_parse.roxy_tag_aesthetics <- function(x) { ) } - fun_name <- snake_class(class) aes_item <- rd_aesthetics_item(class) - x$val <- c("", + x$val <- c( + "", paste0( - "\\code{", fun_name, "()} ", + "\\code{", + fun_name, + "()} ", "understands the following aesthetics. Required aesthetics are displayed", " in bold and defaults are displayed for optional aesthetics:" ), - "\\tabular{rll}{", aes_item, "}", + "\\tabular{rll}{", + aes_item, + "}", if (nzchar(x$val$description)) x$val$description ) x @@ -202,11 +241,13 @@ roxy_tag_rd.roxy_tag_aesthetics <- function(x, base_path, env) { on_load({ vctrs::s3_register( - "roxygen2::roxy_tag_parse", "roxy_tag_aesthetics", + "roxygen2::roxy_tag_parse", + "roxy_tag_aesthetics", roxy_tag_parse.roxy_tag_aesthetics ) vctrs::s3_register( - "roxygen2::roxy_tag_rd", "roxy_tag_aesthetics", + "roxygen2::roxy_tag_rd", + "roxy_tag_aesthetics", roxy_tag_rd.roxy_tag_aesthetics ) }) diff --git a/R/utilities-patterns.R b/R/utilities-patterns.R index e7cdd308bc..411c26c393 100644 --- a/R/utilities-patterns.R +++ b/R/utilities-patterns.R @@ -1,4 +1,3 @@ - #' Modify fill transparency #' #' This works much like [alpha()][scales::alpha] in that it modifies the @@ -112,4 +111,3 @@ pattern_alpha.GridTilingPattern <- function(x, alpha) { pattern_alpha.list <- function(x, alpha) { Map(pattern_alpha, x = x, alpha = alpha) } - diff --git a/R/utilities.R b/R/utilities.R index 348430fd12..14e816c034 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -23,7 +23,12 @@ scales::alpha # @param character vector of present aesthetics # @param name of object for error message # @keyword internal -check_required_aesthetics <- function(required, present, name, call = caller_env()) { +check_required_aesthetics <- function( + required, + present, + name, + call = caller_env() +) { if (is.null(required)) { return() } @@ -50,9 +55,13 @@ check_required_aesthetics <- function(required, present, name, call = caller_env vapply(pairs, `[`, character(1), 2) ) pairs <- lapply(pairs, setdiff, present) - pairs <- vapply(pairs, function(x) { - as_cli("{.and {.field {x}}}") - }, character(1)) + pairs <- vapply( + pairs, + function(x) { + as_cli("{.and {.field {x}}}") + }, + character(1) + ) pairs <- as_cli("{.or {pairs}}") } @@ -60,9 +69,13 @@ check_required_aesthetics <- function(required, present, name, call = caller_env missing_other <- !is_present & n != 2 if (any(missing_other)) { other <- lapply(required[missing_other], setdiff, present) - other <- vapply(other, function(x) { - as_cli("{.or {.field {x}}}") - }, character(1)) + other <- vapply( + other, + function(x) { + as_cli("{.or {.field {x}}}") + }, + character(1) + ) } missing <- c(other, pairs) @@ -99,19 +112,28 @@ clist <- function(l) { #' @param finite If `TRUE`, will also remove non-finite values. #' @keywords internal #' @export -remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "", - finite = FALSE) { +remove_missing <- function( + df, + na.rm = FALSE, + vars = names(df), + name = "", + finite = FALSE +) { check_bool(na.rm) missing <- detect_missing(df, vars, finite) if (any(missing)) { df <- df[!missing, , drop = FALSE] if (!na.rm) { - if (name != "") name <- paste(" ({.fn ", name, "})", sep = "") + if (name != "") { + name <- paste(" ({.fn ", name, "})", sep = "") + } msg <- paste0( "Removed {sum(missing)} row{?s} containing ", if (finite) "non-finite" else "missing values or values", - " outside the scale range", name, "." + " outside the scale range", + name, + "." ) cli::cli_warn(msg) } @@ -221,15 +243,15 @@ gg_dep <- function(version, msg) { # If current major number is greater than last-good major number, or if # current minor number is more than 1 greater than last-good minor number, # give error. - if (cv[[1,1]] > v[[1,1]] || cv[[1,2]] > v[[1,2]] + 1) { + if (cv[[1, 1]] > v[[1, 1]] || cv[[1, 2]] > v[[1, 2]] + 1) { cli::cli_abort(text) - # If minor number differs by one, give warning - } else if (cv[[1,2]] > v[[1,2]]) { + # If minor number differs by one, give warning + } else if (cv[[1, 2]] > v[[1, 2]]) { cli::cli_warn(text) - # If only subminor number is greater, give message - } else if (cv[[1,3]] > v[[1,3]]) { + # If only subminor number is greater, give message + } else if (cv[[1, 3]] > v[[1, 3]]) { cli::cli_inform(text) } @@ -243,11 +265,15 @@ to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x) to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x) tolower <- function(x) { - cli::cli_abort("Please use {.fn to_lower_ascii}, which works fine in all locales.") + cli::cli_abort( + "Please use {.fn to_lower_ascii}, which works fine in all locales." + ) } toupper <- function(x) { - cli::cli_abort("Please use {.fn to_upper_ascii}, which works fine in all locales.") + cli::cli_abort( + "Please use {.fn to_upper_ascii}, which works fine in all locales." + ) } merge_attrs <- function(new, old) { @@ -291,10 +317,13 @@ check_nondata_cols <- function(data, mapping, problem = NULL, hint = NULL) { # The `inherits(x, "Vector")` check is for checking S4 classes from Bioconductor # and whether they can be expected to follow behaviour typical of vectors. See # also #3835 - invalid <- which(!vapply( - data, FUN.VALUE = logical(1), - function(x) is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") - )) + invalid <- which( + !vapply( + data, + FUN.VALUE = logical(1), + function(x) is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") + ) + ) invalid <- names(data)[invalid] if (length(invalid) < 1) { @@ -490,10 +519,17 @@ switch_orientation <- function(aesthetics) { #' @keywords internal #' @name bidirection #' -has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA, - range_is_orthogonal = NA, group_has_equal = FALSE, - ambiguous = FALSE, main_is_continuous = FALSE, - main_is_optional = FALSE, default = FALSE) { +has_flipped_aes <- function( + data, + params = list(), + main_is_orthogonal = NA, + range_is_orthogonal = NA, + group_has_equal = FALSE, + ambiguous = FALSE, + main_is_continuous = FALSE, + main_is_optional = FALSE, + default = FALSE +) { # Is orientation already encoded in data? if (!is.null(data$flipped_aes)) { not_na <- which(!is.na(data$flipped_aes)) @@ -547,15 +583,27 @@ has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA, # Does each group have a single x or y value if (group_has_equal) { if (has_x) { - if (length(x) == 1) return(FALSE) - x_groups <- vapply(split(data$x, data$group), vec_unique_count, integer(1)) + if (length(x) == 1) { + return(FALSE) + } + x_groups <- vapply( + split(data$x, data$group), + vec_unique_count, + integer(1) + ) if (all(x_groups == 1)) { return(FALSE) } } if (has_y) { - if (length(y) == 1) return(TRUE) - y_groups <- vapply(split(data$y, data$group), vec_unique_count, integer(1)) + if (length(y) == 1) { + return(TRUE) + } + y_groups <- vapply( + split(data$y, data$group), + vec_unique_count, + integer(1) + ) if (all(y_groups == 1)) { return(TRUE) } @@ -588,7 +636,9 @@ flipped_names <- function(flip = FALSE) { } split_with_index <- function(x, f, n = max(f)) { - if (n == 1) return(list(x)) + if (n == 1) { + return(list(x)) + } f <- as.integer(f) attributes(f) <- list(levels = as.character(seq_len(n)), class = "factor") unname(split(x, f)) @@ -600,8 +650,6 @@ is_bang <- function(x) { # Puts all columns with 'AsIs' type in a '.ignore' column. - - #' Ignoring and exposing data #' #' The `.ignore_data()` function is used to hide `` columns during @@ -709,7 +757,13 @@ with_ordered_restart <- function(expr, .call) { return(zap()) } - msg <- paste0("Combining variables of class <", class_x, "> and <", class_y, ">") + msg <- paste0( + "Combining variables of class <", + class_x, + "> and <", + class_y, + ">" + ) desc <- paste0( "Please ensure your variables are compatible before plotting (location: ", format_error_call(.call), @@ -767,8 +821,8 @@ replace_null <- function(obj, ..., env = caller_env()) { # Collect dots without evaluating dots <- enexprs(...) # Select arguments that are null in `obj` - nms <- names(dots) - nms <- nms[vapply(obj[nms], is.null, logical(1))] + nms <- names(dots) + nms <- nms[vapply(obj[nms], is.null, logical(1))] # Replace those with the evaluated dots obj[nms] <- inject(list(!!!dots[nms]), env = env) obj @@ -816,7 +870,8 @@ fallback_palette <- function(scale) { if (discrete) { pal <- switch( aes, - colour = , fill = pal_hue(), + colour = , + fill = pal_hue(), alpha = function(n) seq(0.1, 1, length.out = n), linewidth = function(n) seq(2, 6, length.out = n), linetype = pal_linetype(), @@ -828,7 +883,8 @@ fallback_palette <- function(scale) { } switch( aes, - colour = , fill = pal_seq_gradient("#132B43", "#56B1F7"), + colour = , + fill = pal_seq_gradient("#132B43", "#56B1F7"), alpha = pal_rescale(c(0.1, 1)), linewidth = pal_rescale(c(1, 6)), linetype = pal_binned(pal_linetype()), @@ -840,7 +896,8 @@ fallback_palette <- function(scale) { warn_dots_used <- function(env = caller_env(), call = caller_env()) { check_dots_used( - env = env, call = call, + env = env, + call = call, # Demote from error to warning error = function(cnd) { # cli uses \f as newlines, not \n @@ -852,7 +909,8 @@ warn_dots_used <- function(env = caller_env(), call = caller_env()) { warn_dots_empty <- function(env = caller_env(), call = caller_env()) { check_dots_empty( - env = env, call = call, + env = env, + call = call, error = function(cnd) { msg <- gsub("\n", "\f", cnd_message(cnd)) cli::cli_warn(msg, call = call) @@ -889,11 +947,14 @@ prompt_install <- function(pkg, reason = NULL) { is_installed(pkg) } -compute_data_size <- function(data, size, default = 0.9, - target = "width", - panels = c("across", "by", "ignore"), - ...) { - +compute_data_size <- function( + data, + size, + default = 0.9, + target = "width", + panels = c("across", "by", "ignore"), + ... +) { data[[target]] <- data[[target]] %||% size if (!is.null(data[[target]])) { return(data) @@ -907,7 +968,9 @@ compute_data_size <- function(data, size, default = 0.9, res <- vapply(res, resolution, FUN.VALUE = numeric(1), ...) res <- min(res, na.rm = TRUE) } else if (panels == "by") { - res <- stats::ave(data[[var]], data$PANEL, FUN = function(x) resolution(x, ...)) + res <- stats::ave(data[[var]], data$PANEL, FUN = function(x) { + resolution(x, ...) + }) } else { res <- resolution(data[[var]], ...) } diff --git a/R/zxx.R b/R/zxx.R index 7c10940491..32fe72f82b 100644 --- a/R/zxx.R +++ b/R/zxx.R @@ -3,7 +3,10 @@ #' @export #' @rdname scale_viridis #' @usage NULL -scale_colour_ordinal <- function(..., type = getOption("ggplot2.ordinal.colour", getOption("ggplot2.ordinal.fill"))) { +scale_colour_ordinal <- function( + ..., + type = getOption("ggplot2.ordinal.colour", getOption("ggplot2.ordinal.fill")) +) { type <- type %||% scale_colour_viridis_d args <- list2(...) args$call <- args$call %||% current_call() @@ -31,15 +34,20 @@ scale_color_ordinal <- scale_colour_ordinal #' @export #' @rdname scale_gradient #' @usage NULL -scale_colour_datetime <- function(name = waiver(), ..., - low = "#132B43", - high = "#56B1F7", - space = "Lab", - na.value = "grey50", - guide = "colourbar", - aesthetics = "colour") { +scale_colour_datetime <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour" +) { datetime_scale( - aesthetics = aesthetics, transform = "time", name = name, + aesthetics = aesthetics, + transform = "time", + name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -55,16 +63,20 @@ scale_color_datetime <- scale_colour_datetime #' @export #' @rdname scale_gradient #' @usage NULL -scale_colour_date <- function(name = waiver(), - ..., - low = "#132B43", - high = "#56B1F7", - space = "Lab", - na.value = "grey50", - guide = "colourbar", - aesthetics = "colour") { +scale_colour_date <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "colour" +) { datetime_scale( - aesthetics = aesthetics, transform = "date", name = name, + aesthetics = aesthetics, + transform = "date", + name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -81,7 +93,10 @@ scale_color_date <- scale_colour_date #' @export #' @rdname scale_viridis #' @usage NULL -scale_fill_ordinal <- function(..., type = getOption("ggplot2.ordinal.fill", getOption("ggplot2.ordinal.colour"))) { +scale_fill_ordinal <- function( + ..., + type = getOption("ggplot2.ordinal.fill", getOption("ggplot2.ordinal.colour")) +) { type <- type %||% scale_fill_viridis_d args <- list2(...) args$call <- args$call %||% current_call() @@ -111,15 +126,20 @@ pal_ordinal <- function(colours, na.color = "grey50", alpha = TRUE) { #' @export #' @rdname scale_gradient #' @usage NULL -scale_fill_datetime <- function(name = waiver(), ..., - low = "#132B43", - high = "#56B1F7", - space = "Lab", - na.value = "grey50", - guide = "colourbar", - aesthetics = "fill") { +scale_fill_datetime <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill" +) { datetime_scale( - aesthetics = aesthetics, transform = "time", name = name, + aesthetics = aesthetics, + transform = "time", + name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -130,15 +150,20 @@ scale_fill_datetime <- function(name = waiver(), ..., #' @export #' @rdname scale_gradient #' @usage NULL -scale_fill_date <- function(name = waiver(), ..., - low = "#132B43", - high = "#56B1F7", - space = "Lab", - na.value = "grey50", - guide = "colourbar", - aesthetics = "fill") { +scale_fill_date <- function( + name = waiver(), + ..., + low = "#132B43", + high = "#56B1F7", + space = "Lab", + na.value = "grey50", + guide = "colourbar", + aesthetics = "fill" +) { datetime_scale( - aesthetics = aesthetics, transform = "date", name = name, + aesthetics = aesthetics, + transform = "date", + name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, diff --git a/R/zzz.R b/R/zzz.R index 9c5c300d8c..0866ffff3f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,6 +1,8 @@ .onAttach <- function(...) { withr::with_preserve_seed({ - if (!interactive() || stats::runif(1) > 0.1) return() + if (!interactive() || stats::runif(1) > 0.1) { + return() + } tip <- random_tip() packageStartupMessage(paste(strwrap(tip), collapse = "\n")) diff --git a/air.toml b/air.toml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/data-raw/diamonds.R b/data-raw/diamonds.R index 16e46e7618..ec87af5ae7 100644 --- a/data-raw/diamonds.R +++ b/data-raw/diamonds.R @@ -1,9 +1,13 @@ library(readr) -diamonds <- read_csv("data-raw/diamonds.csv", col_types = - list( +diamonds <- read_csv( + "data-raw/diamonds.csv", + col_types = list( cut = col_factor(c("Fair", "Good", "Very Good", "Premium", "Ideal"), TRUE), color = col_factor(c("D", "E", "F", "G", "H", "I", "J"), TRUE), - clarity = col_factor(c("I1", "SI2", "SI1", "VS2", "VS1", "VVS2", "VVS1", "IF"), TRUE) + clarity = col_factor( + c("I1", "SI2", "SI1", "VS2", "VS1", "VVS2", "VVS1", "IF"), + TRUE + ) ) ) diff --git a/data-raw/economics.R b/data-raw/economics.R index 1f773ed4bd..ea98cd216d 100644 --- a/data-raw/economics.R +++ b/data-raw/economics.R @@ -22,7 +22,9 @@ csv <- file.path(RAW_CSV_DIR, paste0(series, ".csv")) # walk2(url, csv, function(x, dest) download.file(x, destfile = dest)) # read the CSV files -fields <- map(csv, read_csv, +fields <- map( + csv, + read_csv, col_types = cols( DATE = col_date(format = ""), VALUE = col_double() diff --git a/data-raw/tx-housing.R b/data-raw/tx-housing.R index 0291360102..64a2de4ce3 100644 --- a/data-raw/tx-housing.R +++ b/data-raw/tx-housing.R @@ -25,34 +25,59 @@ tamu_table <- . %>% tables <- lapply(pages, tamu_table) data <- lapply(tables, . %>% .[-1, ] %>% to_char) %>% - Map(function(df, city) { - df$city <- city - df - }, ., names(.)) %>% + Map( + function(df, city) { + df$city <- city + df + }, + ., + names(.) + ) %>% bind_rows() %>% as_data_frame() data[data == "-"] <- NA -months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", - "Oct", "Nov", "Dec") +months <- c( + "Jan", + "Feb", + "Mar", + "Apr", + "May", + "Jun", + "Jul", + "Aug", + "Sep", + "Oct", + "Nov", + "Dec" +) txhousing <- data %>% mutate( - Sales = parse_numeric(Sales), - DollarVolume = parse_numeric(DollarVolume), - AveragePrice = parse_numeric(AveragePrice), - MedianPrice = parse_numeric(MedianPrice), + Sales = parse_numeric(Sales), + DollarVolume = parse_numeric(DollarVolume), + AveragePrice = parse_numeric(AveragePrice), + MedianPrice = parse_numeric(MedianPrice), TotalListings = parse_numeric(TotalListings), MonthsInventory = parse_numeric(MonthsInventory) ) %>% extract(Date, c("Year", "Month"), "(\\d*)-?([a-zA-Z]*)", convert = TRUE) %>% mutate( Year = zoo::na.locf(ifelse(Year == "", NA, Year)), - Month = match(Month, months)) %>% - select(city, year = Year, month = Month, sales = Sales, - volume = DollarVolume, average = AveragePrice, median = MedianPrice, - listings = TotalListings, inventory = MonthsInventory) %>% + Month = match(Month, months) + ) %>% + select( + city, + year = Year, + month = Month, + sales = Sales, + volume = DollarVolume, + average = AveragePrice, + median = MedianPrice, + listings = TotalListings, + inventory = MonthsInventory + ) %>% mutate(date = year + (month - 1) / 12) %>% # Don't need totals & Palestine is v. low quality filter(!(city %in% c("Texas Totals", "Palestine"))) %>% @@ -60,5 +85,10 @@ txhousing <- data %>% filter(year >= 2000) %>% select(-average) -write.csv(txhousing, "data-raw/tx-housing.csv", row.names = FALSE, quote = FALSE) +write.csv( + txhousing, + "data-raw/tx-housing.csv", + row.names = FALSE, + quote = FALSE +) devtools::use_data(txhousing, overwrite = TRUE) diff --git a/icons/icons.R b/icons/icons.R index 36ed8bfa8d..9aeb61b2df 100644 --- a/icons/icons.R +++ b/icons/icons.R @@ -16,23 +16,25 @@ write_icon <- function(name, code) { } write_icon("coord_cartesian", { - gTree(children = gList( - segmentsGrob( - c(0, 0.25), - c(0.25, 0), - c(1, 0.25), - c(0.25, 1), - gp = gpar(col = "grey50", lwd = 0.5) - ), - segmentsGrob( - c(0, 0.75), - c(0.75, 0), - c(1, 0.75), - c(0.75, 1), - gp = gpar(col = "grey50", lwd = 0.5) - ), - segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1)) - )) + gTree( + children = gList( + segmentsGrob( + c(0, 0.25), + c(0.25, 0), + c(1, 0.25), + c(0.25, 1), + gp = gpar(col = "grey50", lwd = 0.5) + ), + segmentsGrob( + c(0, 0.75), + c(0.75, 0), + c(1, 0.75), + c(0.75, 1), + gp = gpar(col = "grey50", lwd = 0.5) + ), + segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1)) + ) + ) }) write_icon("coord_fixed", { @@ -41,17 +43,22 @@ write_icon("coord_fixed", { write_icon("coord_flip", { angles <- seq(0, pi / 2, length.out = 20)[-c(1, 20)] - gTree(children = gList( - segmentsGrob(0, 0, 0, 1), - segmentsGrob(0, 0, 1, 0), - linesGrob(0.9 * sin(angles), 0.9 * cos(angles), - arrow = arrow(length = unit(0.05, "npc"))), - linesGrob( - 0.5 * sin(angles), - 0.5 * cos(angles), - arrow = arrow(ends = "first", length = unit(0.05, "npc")) + gTree( + children = gList( + segmentsGrob(0, 0, 0, 1), + segmentsGrob(0, 0, 1, 0), + linesGrob( + 0.9 * sin(angles), + 0.9 * cos(angles), + arrow = arrow(length = unit(0.05, "npc")) + ), + linesGrob( + 0.5 * sin(angles), + 0.5 * cos(angles), + arrow = arrow(ends = "first", length = unit(0.05, "npc")) + ) ) - )) + ) }) write_icon("coord_map", { @@ -66,56 +73,62 @@ file.copy("icons/coord_map.png", "icons/geom_map.png") file.copy("icons/coord_map.png", "icons/geom_sf.png") write_icon("coord_polar", { - circleGrob(r = c(0.1, 0.25, 0.45), gp = gpar(fill = NA)) + circleGrob(r = c(0.1, 0.25, 0.45), gp = gpar(fill = NA)) }) write_icon("coord_transform", { - breaks <- cumsum(1 / 2 ^ (1:5)) - gTree(children = gList( - segmentsGrob(breaks, 0, breaks, 1), - segmentsGrob(0, breaks, 1, breaks) - )) + breaks <- cumsum(1 / 2^(1:5)) + gTree( + children = gList( + segmentsGrob(breaks, 0, breaks, 1), + segmentsGrob(0, breaks, 1, breaks) + ) + ) }) # Faceting --------------------------------------------------------------------- write_icon("facet_grid", { - gTree(children = gList( - rectGrob( - 0, - 1, - width = 0.95, - height = 0.05, - hjust = 0, - vjust = 1, - gp = gpar(fill = "grey60", col = NA) - ), - rectGrob( - 0.95, - 0.95, - width = 0.05, - height = 0.95, - hjust = 0, - vjust = 1, - gp = gpar(fill = "grey60", col = NA) - ), - segmentsGrob(c(0, 0.475), c(0.475, 0), c(1, 0.475), c(0.475, 1)) - )) + gTree( + children = gList( + rectGrob( + 0, + 1, + width = 0.95, + height = 0.05, + hjust = 0, + vjust = 1, + gp = gpar(fill = "grey60", col = NA) + ), + rectGrob( + 0.95, + 0.95, + width = 0.05, + height = 0.95, + hjust = 0, + vjust = 1, + gp = gpar(fill = "grey60", col = NA) + ), + segmentsGrob(c(0, 0.475), c(0.475, 0), c(1, 0.475), c(0.475, 1)) + ) + ) }) write_icon("facet_wrap", { - gTree(children = gList( - rectGrob( - 0, - c(0.49, 1), - width = 1, - height = 0.05, - hjust = 0, - vjust = 1, - gp = gpar(fill = "grey60", col = NA) - ), - segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1)) - )) + gTree( + children = gList( + rectGrob( + 0, + c(0.49, 1), + width = 1, + height = 0.05, + hjust = 0, + vjust = 1, + gp = gpar(fill = "grey60", col = NA) + ), + segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1)) + ) + ) }) # Geoms ------------------------------------------------------------------------ @@ -137,20 +150,22 @@ write_icon("geom_bin2d", { n <- 5 x <- seq(0, 1, length.out = n + 1)[-(n + 1)] out <- expand.grid(x = x, y = x) - fill <- sqrt((out$x - 0.5) ^ 2 + (out$y - 0.5) ^ 2) + fill <- sqrt((out$x - 0.5)^2 + (out$y - 0.5)^2) pal <- scales::pal_seq_gradient("#56B1F7", "#132B43") rectGrob( - out$x + 1/n/2, - out$y + 1/n/2, - width = 1/n, - height = 1/n, + out$x + 1 / n / 2, + out$y + 1 / n / 2, + width = 1 / n, + height = 1 / n, gp = gpar(col = "grey20", fill = pal(scales::rescale(fill))) ) }) write_icon("geom_blank", { - rectGrob(0.5, 0.5, + rectGrob( + 0.5, + 0.5, height = 1, width = 1, gp = gpar(fill = "white", col = "black", lwd = 3) @@ -174,36 +189,40 @@ write_icon("geom_histogram", { }) write_icon("geom_boxplot", { - gTree(children = gList( - segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)), - rectGrob( - c(0.3, 0.7), - c(0.6, 0.8), - width = 0.3, - height = c(0.4, 0.4), - vjust = 1 - ), - segmentsGrob(c(0.15, 0.55), c(0.5, 0.6), c(0.45, 0.85), c(0.5, 0.6)) - )) + gTree( + children = gList( + segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)), + rectGrob( + c(0.3, 0.7), + c(0.6, 0.8), + width = 0.3, + height = c(0.4, 0.4), + vjust = 1 + ), + segmentsGrob(c(0.15, 0.55), c(0.5, 0.6), c(0.45, 0.85), c(0.5, 0.6)) + ) + ) }) write_icon("geom_crossbar", { - gTree(children = gList( - # crossbar - rectGrob( - 0.3, - 0.6, - width = 0.3, - height = c(0.4, 0.4), - vjust = 1 - ), - segmentsGrob(c(0.15), c(0.5), c(0.45), c(0.5)), - - # error bar - segmentsGrob(0.70, 0.5, 0.70, 0.90), - segmentsGrob(0.55, 0.5, 0.85, 0.50), - segmentsGrob(0.55, 0.9, 0.85, 0.90) - )) + gTree( + children = gList( + # crossbar + rectGrob( + 0.3, + 0.6, + width = 0.3, + height = c(0.4, 0.4), + vjust = 1 + ), + segmentsGrob(c(0.15), c(0.5), c(0.45), c(0.5)), + + # error bar + segmentsGrob(0.70, 0.5, 0.70, 0.90), + segmentsGrob(0.55, 0.5, 0.85, 0.50), + segmentsGrob(0.55, 0.9, 0.85, 0.90) + ) + ) }) write_icon("geom_dotplot", { @@ -229,13 +248,19 @@ write_icon("geom_path", { }) write_icon("geom_contour", { - gTree(children = gList(polygonGrob( - c(0.45, 0.5, 0.6, 0.5), c(0.5, 0.4, 0.55, 0.6) - ), - polygonGrob( - c(0.25, 0.6, 0.8, 0.5), c(0.5, 0.2, 0.75, 0.9), - gp = gpar(fill = NA) - ))) + gTree( + children = gList( + polygonGrob( + c(0.45, 0.5, 0.6, 0.5), + c(0.5, 0.4, 0.55, 0.6) + ), + polygonGrob( + c(0.25, 0.6, 0.8, 0.5), + c(0.5, 0.2, 0.75, 0.9), + gp = gpar(fill = NA) + ) + ) + ) }) write_icon("geom_hex", { @@ -281,16 +306,18 @@ write_icon("geom_jitter", { }) write_icon("geom_pointrange", { - gTree(children = gList( - segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)), - pointsGrob( - c(0.3, 0.7), - c(0.4, 0.6), - pch = 19, - gp = gpar(col = "black", cex = 0.5), - default.units = "npc" + gTree( + children = gList( + segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)), + pointsGrob( + c(0.3, 0.7), + c(0.4, 0.6), + pch = 19, + gp = gpar(col = "black", cex = 0.5), + default.units = "npc" + ) ) - )) + ) }) write_icon("geom_polygon", { @@ -302,15 +329,22 @@ write_icon("geom_polygon", { }) write_icon("geom_quantile", { - gTree(children = gList(linesGrob( - c(0, 0.3, 0.5, 0.8, 1), c(0.8, 0.65, 0.6, 0.6, 0.8) - ), - linesGrob( - c(0, 0.3, 0.5, 0.8, 1), c(0.55, 0.45, 0.5, 0.45, 0.55) - ), - linesGrob( - c(0, 0.3, 0.5, 0.8, 1), c(0.3, 0.25, 0.4, 0.3, 0.2) - ))) + gTree( + children = gList( + linesGrob( + c(0, 0.3, 0.5, 0.8, 1), + c(0.8, 0.65, 0.6, 0.6, 0.8) + ), + linesGrob( + c(0, 0.3, 0.5, 0.8, 1), + c(0.55, 0.45, 0.5, 0.45, 0.55) + ), + linesGrob( + c(0, 0.3, 0.5, 0.8, 1), + c(0.3, 0.25, 0.4, 0.3, 0.2) + ) + ) + ) }) write_icon("geom_raster", { @@ -346,7 +380,8 @@ write_icon("geom_spoke", { theta <- seq(0, 2 * pi, length.out = 10)[-1] r <- seq(0.1, 0.45, length.out = length(theta)) segmentsGrob( - 0.5, 0.5, + 0.5, + 0.5, 0.5 + sin(theta) * r, 0.5 + cos(theta) * r, gp = gpar(col = "grey20") @@ -354,9 +389,11 @@ write_icon("geom_spoke", { }) write_icon("geom_area", { - polygonGrob(c(0, 0, 0.3, 0.5, 0.8, 1, 1), + polygonGrob( + c(0, 0, 0.3, 0.5, 0.8, 1, 1), c(0, 1, 0.5, 0.6, 0.3, 0.8, 0), - gp = gpar(fill = "grey20", col = NA)) + gp = gpar(fill = "grey20", col = NA) + ) }) write_icon("geom_density", { @@ -375,21 +412,28 @@ write_icon("geom_rug", { }) write_icon("geom_segment", { - segmentsGrob(c(0.1, 0.3, 0.5, 0.7), + segmentsGrob( + c(0.1, 0.3, 0.5, 0.7), c(0.3, 0.5, 0.1, 0.9), c(0.2, 0.5, 0.7, 0.9), - c(0.8, 0.7, 0.4, 0.3)) + c(0.8, 0.7, 0.4, 0.3) + ) }) write_icon("geom_smooth", { - gTree(children = gList(polygonGrob( - c(0, 0.3, 0.5, 0.8, 1, 1, 0.8, 0.5, 0.3, 0), - c(0.5, 0.3, 0.4, 0.2, 0.3, 0.7, 0.5, 0.6, 0.5, 0.7), - gp = gpar(fill = "grey60", col = NA) - ), - linesGrob( - c(0, 0.3, 0.5, 0.8, 1), c(0.6, 0.4, 0.5, 0.4, 0.6) - ))) + gTree( + children = gList( + polygonGrob( + c(0, 0.3, 0.5, 0.8, 1, 1, 0.8, 0.5, 0.3, 0), + c(0.5, 0.3, 0.4, 0.2, 0.3, 0.7, 0.5, 0.6, 0.5, 0.7), + gp = gpar(fill = "grey60", col = NA) + ), + linesGrob( + c(0, 0.3, 0.5, 0.8, 1), + c(0.6, 0.4, 0.5, 0.4, 0.6) + ) + ) + ) }) write_icon("geom_text", { @@ -414,13 +458,15 @@ write_icon("geom_violin", { dnorm(y, mean = -.1, sd = 0.1) + dnorm(y, mean = 0.1, sd = 0.1) y <- c(y, rev(y)) - x1 <- c(x1,-rev(x1)) / max(8 * x1) - x2 <- c(x2,-rev(x2)) / max(8 * x2) + x1 <- c(x1, -rev(x1)) / max(8 * x1) + x2 <- c(x2, -rev(x2)) / max(8 * x2) gp <- gpar(fill = "black") - gTree(children = gList( - polygonGrob(x1 + .30, y + .35, default.units = "npc", gp = gp), - polygonGrob(x2 + .70, y + .55, default.units = "npc", gp = gp) - )) + gTree( + children = gList( + polygonGrob(x1 + .30, y + .35, default.units = "npc", gp = gp), + polygonGrob(x2 + .70, y + .55, default.units = "npc", gp = gp) + ) + ) }) # Position adjustments -------------------------------------------------------- @@ -478,10 +524,12 @@ write_icon("position_stack", { write_icon("scale_alpha", { x <- c(0.1, 0.3, 0.5, 0.7, 0.9) - rectGrob(x, + rectGrob( + x, width = 0.3, height = x, - gp = gpar(fill = scales::alpha("black", x), col = NA)) + gp = gpar(fill = scales::alpha("black", x), col = NA) + ) }) write_icon("scale_colour_brewer", { @@ -539,25 +587,36 @@ write_icon("scale_colour_viridis", { write_icon("scale_colour_grey", { - rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), + rectGrob( + c(0.1, 0.3, 0.5, 0.7, 0.9), width = 0.21, - gp = gpar(fill = gray(seq(0, 0.9, length.out = 5)), col = NA)) + gp = gpar(fill = gray(seq(0, 0.9, length.out = 5)), col = NA) + ) }) write_icon("scale_colour_hue", { - rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), + rectGrob( + c(0.1, 0.3, 0.5, 0.7, 0.9), width = 0.21, - gp = gpar(fill = hcl( - seq(0, 360, length.out = 6)[-6], c = 100, l = 65 - ), col = NA)) + gp = gpar( + fill = hcl( + seq(0, 360, length.out = 6)[-6], + c = 100, + l = 65 + ), + col = NA + ) + ) }) write_icon("scale_linetype", { - gTree(children = gList( - segmentsGrob(0, 0.25, 1, 0.25, gp = gpar(lty = 1, lwd = 3)), - segmentsGrob(0, 0.50, 1, 0.50, gp = gpar(lty = 2, lwd = 3)), - segmentsGrob(0, 0.75, 1, 0.75, gp = gpar(lty = 3, lwd = 3)) - )) + gTree( + children = gList( + segmentsGrob(0, 0.25, 1, 0.25, gp = gpar(lty = 1, lwd = 3)), + segmentsGrob(0, 0.50, 1, 0.50, gp = gpar(lty = 2, lwd = 3)), + segmentsGrob(0, 0.75, 1, 0.75, gp = gpar(lty = 3, lwd = 3)) + ) + ) }) write_icon("scale_colour_manual", { @@ -566,21 +625,25 @@ write_icon("scale_colour_manual", { write_icon("scale_shape", { gp <- gpar(lwd = 3) - gTree(children = gList( - circleGrob(0.7, 0.7, r = 0.1, gp = gp), - segmentsGrob(0.2, 0.3, 0.4, 0.3, gp = gp), - segmentsGrob(0.3, 0.2, 0.3, 0.4, gp = gp), - polygonGrob(c(0.2, 0.2, 0.4, 0.4), c(0.8, 0.6, 0.6, 0.8), gp = gp), - polygonGrob(c(0.6, 0.7, 0.8), c(0.2, 0.4, 0.2), gp = gp) - )) + gTree( + children = gList( + circleGrob(0.7, 0.7, r = 0.1, gp = gp), + segmentsGrob(0.2, 0.3, 0.4, 0.3, gp = gp), + segmentsGrob(0.3, 0.2, 0.3, 0.4, gp = gp), + polygonGrob(c(0.2, 0.2, 0.4, 0.4), c(0.8, 0.6, 0.6, 0.8), gp = gp), + polygonGrob(c(0.6, 0.7, 0.8), c(0.2, 0.4, 0.2), gp = gp) + ) + ) }) write_icon("scale_size", { pos <- c(0.15, 0.3, 0.5, 0.75) - circleGrob(pos, + circleGrob( + pos, pos, r = (c(0.1, 0.2, 0.3, 0.4) / 2.5), - gp = gpar(fill = "grey50", col = NA)) + gp = gpar(fill = "grey50", col = NA) + ) }) write_icon("scale_x_date", { diff --git a/tests/testthat/helper-density.R b/tests/testthat/helper-density.R index 1896437b8f..f49d5710f8 100644 --- a/tests/testthat/helper-density.R +++ b/tests/testthat/helper-density.R @@ -1,4 +1,3 @@ - # In R devel from 4.3.0 onwards, the density calculation has slightly changed, # which affects visual snapshots that use a density calculation, like # `geom_violin()` and `geom_density()`. @@ -13,7 +12,8 @@ # density method to use `old.coords = TRUE`. if ("old.coords" %in% names(formals(stats::density.default))) { registerS3method( - "density", "default", + "density", + "default", function(..., old.coords = TRUE) { stats::density.default(..., old.coords = old.coords) } diff --git a/tests/testthat/helper-facet.R b/tests/testthat/helper-facet.R index efcd7d748a..b866a8f021 100644 --- a/tests/testthat/helper-facet.R +++ b/tests/testthat/helper-facet.R @@ -1,4 +1,3 @@ - quos_list <- function(...) { new_quosures(list(...)) } diff --git a/tests/testthat/helper-plot-data.R b/tests/testthat/helper-plot-data.R index cf97be4122..5b9ecde647 100644 --- a/tests/testthat/helper-plot-data.R +++ b/tests/testthat/helper-plot-data.R @@ -5,7 +5,11 @@ cdata <- function(plot) { lapply(pieces@data, function(d) { dapply(d, "PANEL", function(panel_data) { scales <- pieces@layout$get_scales(panel_data$PANEL[1]) - panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces@layout$coord_params) + panel_params <- plot@coordinates$setup_panel_params( + scales$x, + scales$y, + params = pieces@layout$coord_params + ) plot@coordinates$transform(panel_data, panel_params) }) }) @@ -17,10 +21,8 @@ pranges <- function(plot) { x_ranges <- lapply(layout$panel_scales_x, function(scale) scale$get_limits()) y_ranges <- lapply(layout$panel_scales_y, function(scale) scale$get_limits()) - npscales <- plot@scales$non_position_scales() npranges <- lapply(npscales$scales$scales, function(scale) scale$get_limits()) - c(list(x = x_ranges, y = y_ranges), npranges) } diff --git a/tests/testthat/helper-vdiffr.R b/tests/testthat/helper-vdiffr.R index 20823ba45c..f941e83d3c 100644 --- a/tests/testthat/helper-vdiffr.R +++ b/tests/testthat/helper-vdiffr.R @@ -2,7 +2,10 @@ # VDIFFR_RUN_TESTS is explicitly set to "true", which should be the case only on # a GitHub Actions CI runner with stable version of R. -if (requireNamespace("vdiffr", quietly = TRUE) && utils::packageVersion('testthat') >= '3.0.3') { +if ( + requireNamespace("vdiffr", quietly = TRUE) && + utils::packageVersion('testthat') >= '3.0.3' +) { expect_doppelganger <- vdiffr::expect_doppelganger } else { # If vdiffr is not available and visual tests are explicitly required, raise error. diff --git a/tests/testthat/test-aes-calculated.R b/tests/testthat/test-aes-calculated.R index 2d389106cf..9ca3ef2e4f 100644 --- a/tests/testthat/test-aes-calculated.R +++ b/tests/testthat/test-aes-calculated.R @@ -24,14 +24,20 @@ test_that("strip_dots remove dots around calculated aesthetics", { test_that("strip_dots handles tidy evaluation pronouns", { expect_identical(strip_dots(aes(.data$x), strip_pronoun = TRUE)$x, quo(x)) - expect_identical(strip_dots(aes(.data[["x"]]), strip_pronoun = TRUE)$x, quo(x)) + expect_identical( + strip_dots(aes(.data[["x"]]), strip_pronoun = TRUE)$x, + quo(x) + ) var <- "y" f <- function() { var <- "x" aes(.data[[var]])$x } - expect_identical(quo_get_expr(strip_dots(f(), strip_pronoun = TRUE)), quote(x)) + expect_identical( + quo_get_expr(strip_dots(f(), strip_pronoun = TRUE)), + quote(x) + ) }) test_that("make_labels() deparses mappings properly", { @@ -42,7 +48,9 @@ test_that("make_labels() deparses mappings properly", { # symbol is always deparsed without backticks expect_identical(make_labels(aes(x = `a b`)), list(x = "a b")) # long expression is abbreviated with ... - x_lab <- make_labels(aes(x = 2 * x * exp(`coef 1` * x^2) * 2 * x * exp(`coef 1` * x^2) * 2 * x))$x + x_lab <- make_labels(aes( + x = 2 * x * exp(`coef 1` * x^2) * 2 * x * exp(`coef 1` * x^2) * 2 * x + ))$x expect_length(x_lab, 1L) expect_match(x_lab, "...$") # if the mapping is a literal or NULL, the aesthetics is used @@ -58,8 +66,10 @@ test_that("staged aesthetics warn appropriately for duplicated names", { expect_snapshot_warning( p <- ggplot(df, aes(x, y, label = lab)) + geom_label( - aes(colour = stage(lab, after_scale = colour), - color = after_scale(color)) + aes( + colour = stage(lab, after_scale = colour), + color = after_scale(color) + ) ) + # Guide would trigger another warning when plot is printed, due to the # `guide_geom.legend` also using `Geom$use_defaults` method, which we @@ -71,7 +81,6 @@ test_that("staged aesthetics warn appropriately for duplicated names", { }) test_that("calculated aesthetics throw warnings when lengths mismatch", { - df <- data.frame(x = 1:2) p <- ggplot(df, aes(x, x)) @@ -87,7 +96,6 @@ test_that("calculated aesthetics throw warnings when lengths mismatch", { p + geom_point(aes(colour = after_scale(c("red", "green", "blue")))) ) ) - }) test_that("A deprecated warning is issued when stat(var) or ..var.. is used", { @@ -99,14 +107,13 @@ test_that("A deprecated warning is issued when stat(var) or ..var.. is used", { }) test_that("functions can be masked", { - foo <- function(x) x + 10 bar <- function(x) x * 10 data <- data.frame(val = 10) mapping <- aes(x = val, y = foo(20)) - evaled <- eval_aesthetics(mapping, data = data, mask = list()) + evaled <- eval_aesthetics(mapping, data = data, mask = list()) expect_equal(evaled, list(x = 10, y = 30)) evaled <- eval_aesthetics(mapping, data = data, mask = list(foo = bar)) @@ -116,15 +123,21 @@ test_that("functions can be masked", { mapping <- aes(x = val, y = ggplot2::stage(10, 20, 30)) evaled <- eval_aesthetics(mapping, data = data, mask = list()) expect_equal(evaled, list(x = 10, y = 10)) - evaled <- eval_aesthetics(mapping, data = data, mask = list(stage = stage_calculated)) + evaled <- eval_aesthetics( + mapping, + data = data, + mask = list(stage = stage_calculated) + ) expect_equal(evaled, list(x = 10, y = 20)) - evaled <- eval_aesthetics(mapping, data = data, mask = list(stage = stage_scaled)) + evaled <- eval_aesthetics( + mapping, + data = data, + mask = list(stage = stage_scaled) + ) expect_equal(evaled, list(x = 10, y = 30)) - }) test_that("stage allows aesthetics that are only mapped to start", { - df <- data.frame(x = 1:2) start_unnamed <- aes(stage(x)) @@ -144,13 +157,12 @@ test_that("stage allows aesthetics that are only mapped to start", { eval_aesthetics(start_nulls, data = df), list(x = 1:2) ) - }) test_that("A geom can have scaled defaults (#6135)", { - test_geom <- ggproto( - NULL, GeomPoint, + NULL, + GeomPoint, default_aes = modify_list( GeomPoint$default_aes, aes(colour = after_scale(alpha(fill, 0.5)), fill = "black") diff --git a/tests/testthat/test-aes-setting.R b/tests/testthat/test-aes-setting.R index 2071921c03..68c23cd80a 100644 --- a/tests/testthat/test-aes-setting.R +++ b/tests/testthat/test-aes-setting.R @@ -47,9 +47,15 @@ test_that("alpha affects only fill colour of solid geoms", { expect_equal(get_layer_grob(poly)[[1]]$gp$col[[1]], "red") expect_equal(get_layer_grob(rect)[[1]]$gp$col[[1]], "red") - expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], "red") + expect_equal( + get_layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], + "red" + ) expect_equal(get_layer_grob(poly)[[1]]$gp$fill[[1]], "#FF000080") expect_equal(get_layer_grob(rect)[[1]]$gp$fill[[1]], "#FF000080") - expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], "#FF000080") + expect_equal( + get_layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], + "#FF000080" + ) }) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index b0922383cc..e52c8d990f 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -120,7 +120,6 @@ test_that("aes standardises aesthetic names", { }) test_that("warn_for_aes_extract_usage() warns for discouraged uses of $ and [[ within aes()", { - df <- data_frame(x = 1:5, nested_df = data_frame(x = 6:10)) expect_snapshot_warning( @@ -180,7 +179,7 @@ test_that("aes() supports `!!!` in named arguments (#2675)", { aes(x = 1, y = 2) ) expect_equal( - aes(, , !!!list(y = 1)), + aes(,, !!!list(y = 1)), aes(y = 1) ) expect_snapshot_error(aes(y = 1, !!!list(y = 2))) @@ -204,27 +203,34 @@ test_that("class_mapping() checks its inputs", { test_that("aesthetics are drawn correctly", { dat <- data_frame(xvar = letters[1:3], yvar = 7:9) - expect_doppelganger("stat='identity'", + expect_doppelganger( + "stat='identity'", ggplot(dat, aes(x = xvar, y = yvar)) + geom_bar(stat = "identity") ) - expect_doppelganger("stat='identity', width=0.5", - ggplot(dat, aes(x = xvar, y = yvar)) + geom_bar(stat = "identity", width = 0.5) + expect_doppelganger( + "stat='identity', width=0.5", + ggplot(dat, aes(x = xvar, y = yvar)) + + geom_bar(stat = "identity", width = 0.5) ) - expect_doppelganger("stat='count'", + expect_doppelganger( + "stat='count'", ggplot(dat, aes(x = xvar)) + geom_bar(stat = "count") ) - expect_doppelganger("stat='count', width=0.5", + expect_doppelganger( + "stat='count', width=0.5", ggplot(dat, aes(x = xvar)) + geom_bar(stat = "count", width = 0.5) ) }) test_that("alpha is drawn correctly", { d <- data.frame(x = 1, y = 1) - expect_doppelganger("Alpha set in colour", + expect_doppelganger( + "Alpha set in colour", ggplot(d, aes(x, y)) + geom_point(color = I("#cc000044"), size = I(50)) ) - expect_doppelganger("Alpha set in alpha", + expect_doppelganger( + "Alpha set in alpha", ggplot(d, aes(x, y)) + geom_point(color = I("#cc0000"), size = I(50), alpha = I(0.27)) ) diff --git a/tests/testthat/test-annotate.R b/tests/testthat/test-annotate.R index df8b648831..40da1d63f4 100644 --- a/tests/testthat/test-annotate.R +++ b/tests/testthat/test-annotate.R @@ -1,12 +1,22 @@ test_that("dates in segment annotation work", { - dt <- structure(list(month = structure(c(1364774400, 1377993600), - class = c("POSIXct", "POSIXt"), tzone = "UTC"), total = c(-10.3, - 11.7)), .Names = c("month", "total"), row.names = c(NA, -2L), class = - "data.frame") + dt <- structure( + list( + month = structure( + c(1364774400, 1377993600), + class = c("POSIXct", "POSIXt"), + tzone = "UTC" + ), + total = c(-10.3, 11.7) + ), + .Names = c("month", "total"), + row.names = c(NA, -2L), + class = "data.frame" + ) p <- ggplot(dt, aes(month, total)) + geom_point() + - annotate("segment", + annotate( + "segment", x = as.POSIXct("2013-04-01"), xend = as.POSIXct("2013-07-01"), y = -10, @@ -58,7 +68,10 @@ test_that("annotation_raster() and annotation_custom() requires cartesian coordi p <- ggplot() + annotation_custom( grob = grid::roundrectGrob(), - xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = Inf ) + coord_polar() expect_snapshot_error(ggplotGrob(p)) @@ -92,28 +105,35 @@ test_that("annotation_custom() and annotation_raster() adhere to scale transform p <- ggplot() + annotation_raster(rast, 1, 10, 1, 9) + - scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + + scale_x_continuous( + transform = "log10", + limits = c(0.1, 100), + expand = FALSE + ) + scale_y_continuous(limits = c(0, 10), expand = FALSE) ann <- get_layer_grob(p)[[1]] - expect_equal(as.numeric(ann$x), 1/3) - expect_equal(as.numeric(ann$y), 1/10) - expect_equal(as.numeric(ann$width), 1/3) - expect_equal(as.numeric(ann$height), 8/10) + expect_equal(as.numeric(ann$x), 1 / 3) + expect_equal(as.numeric(ann$y), 1 / 10) + expect_equal(as.numeric(ann$width), 1 / 3) + expect_equal(as.numeric(ann$height), 8 / 10) rast <- rasterGrob(rast, width = 1, height = 1) p <- ggplot() + annotation_custom(rast, 1, 10, 1, 9) + - scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + + scale_x_continuous( + transform = "log10", + limits = c(0.1, 100), + expand = FALSE + ) + scale_y_continuous(limits = c(0, 10), expand = FALSE) ann <- get_layer_grob(p)[[1]]$vp - expect_equal(as.numeric(ann$x), 1/2) - expect_equal(as.numeric(ann$y), 1/2) - expect_equal(as.numeric(ann$width), 1/3) - expect_equal(as.numeric(ann$height), 8/10) - + expect_equal(as.numeric(ann$x), 1 / 2) + expect_equal(as.numeric(ann$y), 1 / 2) + expect_equal(as.numeric(ann$width), 1 / 3) + expect_equal(as.numeric(ann$height), 8 / 10) }) test_that("annotation_borders() can create a map", { diff --git a/tests/testthat/test-build.R b/tests/testthat/test-build.R index cfb4cf6e4a..3e232d798c 100644 --- a/tests/testthat/test-build.R +++ b/tests/testthat/test-build.R @@ -34,8 +34,16 @@ test_that("non-position aesthetics are mapped", { expect_named( get_layer_data(l1, 1), c( - "x", "y", "fill", "group", "colour", "shape", "size", "PANEL", - "alpha", "stroke" + "x", + "y", + "fill", + "group", + "colour", + "shape", + "size", + "PANEL", + "alpha", + "stroke" ), ignore.order = TRUE ) diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index ea80cb5ce1..d38c19061f 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -13,7 +13,6 @@ test_that("clipping is on by default", { }) test_that("message when replacing non-default coordinate system", { - df <- data_frame(x = 1, y = 2) gg <- ggplot(df, aes(x, y)) @@ -22,7 +21,6 @@ test_that("message when replacing non-default coordinate system", { gg + coord_cartesian() + coord_cartesian(), "Adding new coordinate system" ) - }) test_that("guide names are not removed by `train_panel_guides()`", { @@ -37,17 +35,20 @@ test_that("guide names are not removed by `train_panel_guides()`", { layout$setup_panel_guides(guides_list(NULL), plot@layers) # Line showing change in outcome - expect_named(layout$panel_params[[1]]$guides$aesthetics, c("x", "y", "x.sec", "y.sec")) + expect_named( + layout$panel_params[[1]]$guides$aesthetics, + c("x", "y", "x.sec", "y.sec") + ) }) test_that("check coord limits errors only on bad inputs", { # Should return NULL if valid values are passed expect_null(check_coord_limits(NULL)) expect_null(check_coord_limits(1:2)) - expect_null(check_coord_limits(c(1,2))) + expect_null(check_coord_limits(c(1, 2))) # Should raise error if Scale object is passed - expect_snapshot(check_coord_limits(xlim(1,2)), error = TRUE) + expect_snapshot(check_coord_limits(xlim(1, 2)), error = TRUE) # Should raise error if vector of wrong length is passed expect_snapshot(check_coord_limits(1:3), error = TRUE) @@ -76,7 +77,6 @@ test_that("coords append a column to the layout correctly", { }) test_that("parse_coord_expand parses correctly", { - p <- parse_coord_expand(FALSE) expect_equal(p, rep(FALSE, 4)) @@ -89,22 +89,22 @@ test_that("parse_coord_expand parses correctly", { # Dependencies might use `expand = 1` p <- parse_coord_expand(c(1, 0)) expect_equal(p, c(TRUE, FALSE, TRUE, FALSE)) - }) test_that("coord expand takes a vector", { - base <- ggplot() + lims(x = c(0, 10), y = c(0, 10)) - p <- ggplot_build(base + coord_cartesian(expand = c(TRUE, FALSE, FALSE, TRUE))) + p <- ggplot_build( + base + coord_cartesian(expand = c(TRUE, FALSE, FALSE, TRUE)) + ) pp <- p@layout$panel_params[[1]] expect_equal(pp$x.range, c(-0.5, 10)) expect_equal(pp$y.range, c(0, 10.5)) - p <- ggplot_build(base + coord_cartesian(expand = c(top = FALSE, left = FALSE))) + p <- ggplot_build( + base + coord_cartesian(expand = c(top = FALSE, left = FALSE)) + ) pp <- p@layout$panel_params[[1]] expect_equal(pp$x.range, c(0, 10.5)) expect_equal(pp$y.range, c(-0.5, 10)) - }) - diff --git a/tests/testthat/test-coord-cartesian.R b/tests/testthat/test-coord-cartesian.R index e63663f7e4..5d78cd4a8e 100644 --- a/tests/testthat/test-coord-cartesian.R +++ b/tests/testthat/test-coord-cartesian.R @@ -16,10 +16,10 @@ test_that("clipping can be turned off and on", { test_that("cartesian coords throws error when limits are badly specified", { # throws error when limit is a Scale object instead of vector - expect_snapshot_error(ggplot() + coord_cartesian(xlim(1,1))) + expect_snapshot_error(ggplot() + coord_cartesian(xlim(1, 1))) # throws error when limit's length is different than two - expect_snapshot_error(ggplot() + coord_cartesian(ylim=1:3)) + expect_snapshot_error(ggplot() + coord_cartesian(ylim = 1:3)) }) test_that("cartesian coords can be reversed", { @@ -27,7 +27,9 @@ test_that("cartesian coords can be reversed", { aes(x = x, y = y) + geom_point() + coord_cartesian( - xlim = c(-1, 3), ylim = c(-1, 3), expand = FALSE, + xlim = c(-1, 3), + ylim = c(-1, 3), + expand = FALSE, reverse = "xy" ) + theme_test() + @@ -41,42 +43,67 @@ test_that("cartesian coords can be reversed", { test_that("cartesian coords draws correctly with limits", { p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() - expect_doppelganger("expand range", + expect_doppelganger( + "expand range", p + coord_cartesian(xlim = c(0, 10), ylim = c(0, 50)) ) - expect_doppelganger("contract range", + expect_doppelganger( + "contract range", p + coord_cartesian(xlim = c(2, 4), ylim = c(20, 40)) ) }) test_that("cartesian coords draws correctly with clipping on or off", { - df.in <- data_frame(label = c("inside", "inside", "inside", "inside"), - x = c(0, 1, 0.5, 0.5), - y = c(0.5, 0.5, 0, 1), - angle = c(90, 270, 0, 0), - hjust = c(0.5, 0.5, 0.5, 0.5), - vjust = c(1.1, 1.1, -0.1, 1.1)) + df.in <- data_frame( + label = c("inside", "inside", "inside", "inside"), + x = c(0, 1, 0.5, 0.5), + y = c(0.5, 0.5, 0, 1), + angle = c(90, 270, 0, 0), + hjust = c(0.5, 0.5, 0.5, 0.5), + vjust = c(1.1, 1.1, -0.1, 1.1) + ) - df.out <- data_frame(label = c("outside", "outside", "outside", "outside"), - x = c(0, 1, 0.5, 0.5), - y = c(0.5, 0.5, 0, 1), - angle = c(90, 270, 0, 0), - hjust = c(0.5, 0.5, 0.5, 0.5), - vjust = c(-0.1, -0.1, 1.1, -0.1)) + df.out <- data_frame( + label = c("outside", "outside", "outside", "outside"), + x = c(0, 1, 0.5, 0.5), + y = c(0.5, 0.5, 0, 1), + angle = c(90, 270, 0, 0), + hjust = c(0.5, 0.5, 0.5, 0.5), + vjust = c(-0.1, -0.1, 1.1, -0.1) + ) - p <- ggplot(mapping = aes(x, y, label = label, angle = angle, hjust = hjust, vjust = vjust)) + + p <- ggplot( + mapping = aes( + x, + y, + label = label, + angle = angle, + hjust = hjust, + vjust = vjust + ) + ) + geom_text(data = df.in) + geom_text(data = df.out) + scale_x_continuous(breaks = NULL, name = NULL) + scale_y_continuous(breaks = NULL, name = NULL) + - theme(plot.margin = margin(20, 20, 20, 20), - panel.spacing = grid::unit(10, "pt")) + theme( + plot.margin = margin(20, 20, 20, 20), + panel.spacing = grid::unit(10, "pt") + ) - expect_doppelganger("clip on by default, only 'inside' visible", + expect_doppelganger( + "clip on by default, only 'inside' visible", p + coord_cartesian(xlim = c(0, 1), ylim = c(0, 1), expand = FALSE) ) - expect_doppelganger("clip turned off, both 'inside' and 'outside' visible", - p + coord_cartesian(xlim = c(0, 1), ylim = c(0, 1), expand = FALSE, clip = "off") + expect_doppelganger( + "clip turned off, both 'inside' and 'outside' visible", + p + + coord_cartesian( + xlim = c(0, 1), + ylim = c(0, 1), + expand = FALSE, + clip = "off" + ) ) }) diff --git a/tests/testthat/test-coord-flip.R b/tests/testthat/test-coord-flip.R index fc63748418..0c850ea64d 100644 --- a/tests/testthat/test-coord-flip.R +++ b/tests/testthat/test-coord-flip.R @@ -1,9 +1,12 @@ test_that("secondary labels are correctly turned off", { # Using a visual test because the labels are only generated during rendering - expect_doppelganger("turning off secondary title with coord_flip", + expect_doppelganger( + "turning off secondary title with coord_flip", ggplot(mtcars, aes(x = mpg, y = cyl)) + geom_point() + - scale_x_continuous(sec.axis = dup_axis(guide = guide_axis(title = NULL))) + + scale_x_continuous( + sec.axis = dup_axis(guide = guide_axis(title = NULL)) + ) + coord_flip() + theme_test() + theme( @@ -15,8 +18,8 @@ test_that("secondary labels are correctly turned off", { test_that("flip coords throws error when limits are badly specified", { # throws error when limit is a Scale object instead of vector - expect_snapshot_error(ggplot() + coord_flip(xlim(1,1))) + expect_snapshot_error(ggplot() + coord_flip(xlim(1, 1))) # throws error when limit's length is different than two - expect_snapshot_error(ggplot() + coord_flip(ylim=1:3)) + expect_snapshot_error(ggplot() + coord_flip(ylim = 1:3)) }) diff --git a/tests/testthat/test-coord-map.R b/tests/testthat/test-coord-map.R index 9a8c9dc0b1..49e9000e80 100644 --- a/tests/testthat/test-coord-map.R +++ b/tests/testthat/test-coord-map.R @@ -34,7 +34,7 @@ test_that("Inf is squished to range", { skip_if(packageVersion("base") < "3.5.0") d <- cdata( ggplot(data_frame(x = 0, y = 0)) + - geom_point(aes(x,y)) + + geom_point(aes(x, y)) + annotate("text", -Inf, Inf, label = "Top-left") + coord_map() ) @@ -45,15 +45,15 @@ test_that("Inf is squished to range", { test_that("coord map throws error when limits are badly specified", { # throws error when limit is a Scale object instead of vector - expect_snapshot_error(ggplot() + coord_map(xlim=xlim(1,1))) + expect_snapshot_error(ggplot() + coord_map(xlim = xlim(1, 1))) # throws error when limit's length is different than two - expect_snapshot_error(ggplot() + coord_cartesian(ylim=1:3)) + expect_snapshot_error(ggplot() + coord_cartesian(ylim = 1:3)) }) test_that("coord_map throws informative warning about guides", { skip_if_not_installed("mapproj") expect_snapshot_warning( - ggplot_build(ggplot() + coord_map() + guides(x = guide_axis())) + ggplot_build(ggplot() + coord_map() + guides(x = guide_axis())) ) }) diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index f45b76d194..77c5926477 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -1,10 +1,11 @@ test_that("polar distance is calculated correctly", { dat <- data_frame( - theta = c(0, 2*pi, 2, 6, 6, 1, 1, 0), - r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, 0.5)) + theta = c(0, 2 * pi, 2, 6, 6, 1, 1, 0), + r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, 0.5) + ) scales <- list( - x = scale_x_continuous(limits = c(0, 2*pi)), + x = scale_x_continuous(limits = c(0, 2 * pi)), y = scale_y_continuous(limits = c(0, 1)) ) coord <- coord_polar() @@ -16,8 +17,10 @@ test_that("polar distance is calculated correctly", { maxlen <- spiral_arc_length(1 / (2 * pi), 0, 2 * pi) # These are the expected lengths. I think they're correct... - expect_equal(dists, - c(0, -1.225737494, -2, -0.5, -5, -0.25, -0.6736885011) / maxlen) + expect_equal( + dists, + c(0, -1.225737494, -2, -0.5, -5, -0.25, -0.6736885011) / maxlen + ) # The picture can be visualized with: # ggplot(dat, aes(x=theta, y=r)) + geom_path() + @@ -25,10 +28,9 @@ test_that("polar distance is calculated correctly", { }) test_that("polar distance calculation ignores NA's", { - # These are r and theta values; we'll swap them around for testing x1 <- c(0, 0.5, 0.5, NA, 1) - x2 <- c(0, 1, 2, 0, 1) + x2 <- c(0, 1, 2, 0, 1) dists <- dist_polar(x1, x2) expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE)) @@ -37,15 +39,15 @@ test_that("polar distance calculation ignores NA's", { # NA on the end x1 <- c(0, 0.5, 0.5, 1, NA) - x2 <- c(0, 1, 2, 0, 1) + x2 <- c(0, 1, 2, 0, 1) dists <- dist_polar(x1, x2) expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE)) dists <- dist_polar(x2, x1) expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE)) # NAs in each vector - also have NaN - x1 <- c(0, 0.5, 0.5, 1, NA) - x2 <- c(NaN, 1, 2, NA, 1) + x1 <- c(0, 0.5, 0.5, 1, NA) + x2 <- c(NaN, 1, 2, NA, 1) dists <- dist_polar(x1, x2) expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE)) dists <- dist_polar(x2, x1) @@ -80,15 +82,14 @@ test_that("Inf is squished to range", { }) test_that("coord_polar can have free scales in facets", { - p <- ggplot(data_frame0(x = c(1, 2)), aes(1, x)) + geom_col() + coord_polar(theta = "y") - sc <- get_panel_scales(p + facet_wrap(~ x), 1, 1) + sc <- get_panel_scales(p + facet_wrap(~x), 1, 1) expect_equal(sc$y$get_limits(), c(0, 2)) - sc <- get_panel_scales(p + facet_wrap(~ x, scales = "free"), 1, 1) + sc <- get_panel_scales(p + facet_wrap(~x, scales = "free"), 1, 1) expect_equal(sc$y$get_limits(), c(0, 1)) sc <- get_panel_scales(p + facet_grid(x ~ .), 1, 1) @@ -105,7 +106,6 @@ test_that("coord_polar throws informative warning about guides", { }) test_that("coord_radial warns about axes", { - p <- ggplot(mtcars, aes(disp, mpg)) + geom_point() @@ -119,11 +119,9 @@ test_that("coord_radial warns about axes", { expect_snapshot_warning(ggplotGrob( p + coord_radial(start = 0.1 * pi, end = 0.4 * pi, r.axis.inside = FALSE) )) - }) test_that("bounding box calculations are sensible", { - # Full cirle expect_equal( polar_bbox(arc = c(0, 2 * pi)), @@ -156,7 +154,6 @@ test_that("bounding box calculations are sensible", { }) test_that("when both x and y are AsIs, they are not transformed", { - p <- ggplot() + annotate("text", x = I(0.75), y = I(0.25), label = "foo") + scale_x_continuous(limits = c(0, 10)) + @@ -178,7 +175,6 @@ test_that("when both x and y are AsIs, they are not transformed", { coord_radial() expect_snapshot_warning(ggplotGrob(p)) - }) test_that("radial coords can be reversed", { @@ -228,7 +224,8 @@ test_that("polar coordinates draw correctly", { ) dat <- data_frame(x = rep(0:1, 4), y = rep(c(1, 10, 40, 80), each = 2)) - expect_doppelganger("three-concentric-circles", + expect_doppelganger( + "three-concentric-circles", ggplot(dat, aes(x, y, group = factor(y))) + geom_path() + coord_polar() + @@ -236,11 +233,12 @@ test_that("polar coordinates draw correctly", { ) dat <- data_frame( - theta = c(0, 2*pi, 2, 6, 6, 1, 1, 0), - r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, 0.5), - g = 1:8 + theta = c(0, 2 * pi, 2, 6, 6, 1, 1, 0), + r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, 0.5), + g = 1:8 ) - expect_doppelganger("Rays, circular arcs, and spiral arcs", + expect_doppelganger( + "Rays, circular arcs, and spiral arcs", ggplot(dat, aes(theta, r, colour = g)) + geom_path(show.legend = FALSE) + geom_point(colour = "black") + @@ -249,29 +247,33 @@ test_that("polar coordinates draw correctly", { ) dat <- data_frame(x = LETTERS[1:3], y = 1:3) - expect_doppelganger("rose plot with has equal spacing", + expect_doppelganger( + "rose plot with has equal spacing", ggplot(dat, aes(x, y)) + geom_bar(stat = "identity") + coord_polar() + theme ) - expect_doppelganger("racetrack plot: closed and no center hole", + expect_doppelganger( + "racetrack plot: closed and no center hole", ggplot(dat, aes(x, y)) + geom_bar(stat = "identity") + coord_polar(theta = "y") + theme ) - expect_doppelganger("racetrack plot: closed and has center hole", + expect_doppelganger( + "racetrack plot: closed and has center hole", ggplot(dat, aes(x, y)) + geom_bar(stat = "identity") + coord_polar(theta = "y") + scale_x_discrete(expand = c(0, 0.6)) + theme ) - expect_doppelganger("secondary axis ticks and labels", + expect_doppelganger( + "secondary axis ticks and labels", ggplot(dat, aes(x, y, group = factor(y))) + geom_blank() + - scale_y_continuous(sec.axis = sec_axis(~. * 0.1, name = "sec y")) + + scale_y_continuous(sec.axis = sec_axis(~ . * 0.1, name = "sec y")) + coord_polar() + theme_test() + theme(axis.text.x = element_blank()) @@ -279,11 +281,10 @@ test_that("polar coordinates draw correctly", { }) test_that("coord_radial() draws correctly", { - # Theme to test for axis placement theme <- theme( axis.line.theta = element_line(colour = "tomato"), - axis.line.r = element_line(colour = "dodgerblue"), + axis.line.r = element_line(colour = "dodgerblue"), ) sec_guides <- guides( @@ -300,40 +301,48 @@ test_that("coord_radial() draws correctly", { theme expect_doppelganger("inner.radius with all axes", { - p + coord_radial(inner.radius = 0.3, r.axis.inside = FALSE) + - sec_guides + p + coord_radial(inner.radius = 0.3, r.axis.inside = FALSE) + sec_guides }) expect_doppelganger("partial with all axes", { - p + coord_radial(start = 0.25 * pi, end = 0.75 * pi, inner.radius = 0.3, - r.axis.inside = TRUE, theta = "y") + + p + + coord_radial( + start = 0.25 * pi, + end = 0.75 * pi, + inner.radius = 0.3, + r.axis.inside = TRUE, + theta = "y" + ) + sec_guides }) df <- data_frame0( - x = 1:5, lab = c("cat", "strawberry\ncake", "coffee", "window", "fluid") + x = 1:5, + lab = c("cat", "strawberry\ncake", "coffee", "window", "fluid") ) ggplot(df, aes(x, label = lab)) + - geom_text(aes(y = "0 degrees"), angle = 0) + + geom_text(aes(y = "0 degrees"), angle = 0) + geom_text(aes(y = "90 degrees"), angle = 90) + - coord_radial(start = 0.5 * pi, end = 1.5 * pi, - rotate.angle = TRUE) + + coord_radial(start = 0.5 * pi, end = 1.5 * pi, rotate.angle = TRUE) + theme expect_doppelganger( "bottom half circle with rotated text", ggplot(df, aes(x, label = lab)) + - geom_text(aes(y = "0 degrees"), angle = 0) + + geom_text(aes(y = "0 degrees"), angle = 0) + geom_text(aes(y = "90 degrees"), angle = 90) + - coord_radial(start = 0.5 * pi, end = 1.5 * pi, - rotate.angle = TRUE, r.axis.inside = FALSE) + + coord_radial( + start = 0.5 * pi, + end = 1.5 * pi, + rotate.angle = TRUE, + r.axis.inside = FALSE + ) + theme ) }) test_that("coord_radial()'s axis internal placement works", { - df <- data.frame(x = c(0, 360), y = c(1, 14)) expect_doppelganger( diff --git a/tests/testthat/test-coord-train.R b/tests/testthat/test-coord-train.R index 39344d8e2d..626a9f51c7 100644 --- a/tests/testthat/test-coord-train.R +++ b/tests/testthat/test-coord-train.R @@ -1,12 +1,12 @@ test_that("NA's don't appear in breaks", { - # Returns true if any major/minor breaks have an NA any_NA_major_minor <- function(trained) { ns <- names(trained)[grepl("(\\.major)|(\\.minor)$", names(trained))] for (n in ns) { - if (!is.null(trained[n]) && anyNA(trained[n])) + if (!is.null(trained[n]) && anyNA(trained[n])) { return(TRUE) + } } return(FALSE) @@ -23,11 +23,26 @@ test_that("NA's don't appear in breaks", { expect_true(anyNA(scale_y$break_positions())) # Check the various types of coords to make sure they don't have NA breaks - expect_false(any_NA_major_minor(coord_polar()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_transform()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_polar()$setup_panel_params( + scale_x, + scale_y + ))) + expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params( + scale_x, + scale_y + ))) + expect_false(any_NA_major_minor(coord_transform()$setup_panel_params( + scale_x, + scale_y + ))) + expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params( + scale_x, + scale_y + ))) skip_if_not_installed("mapproj") - expect_false(any_NA_major_minor(coord_map()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_map()$setup_panel_params( + scale_x, + scale_y + ))) }) diff --git a/tests/testthat/test-coord-transform.R b/tests/testthat/test-coord-transform.R index 5711ea5768..fa573212a0 100644 --- a/tests/testthat/test-coord-transform.R +++ b/tests/testthat/test-coord-transform.R @@ -1,5 +1,5 @@ test_that("warnings are generated when coord_transform() results in new infinite values", { - p <- ggplot(head(diamonds, 20)) + + p <- ggplot(head(diamonds, 20)) + geom_bar(aes(x = cut)) + coord_transform(y = "log10") @@ -113,7 +113,7 @@ test_that("second axes display in coord_transform()", { geom_point() + scale_y_continuous( sec.axis = sec_axis( - transform = ~log2(.), + transform = ~ log2(.), breaks = c(3.5, 4, 4.5, 5, 5.5), name = "log2(hwy)" ), @@ -126,10 +126,10 @@ test_that("second axes display in coord_transform()", { test_that("coord_transform() throws error when limits are badly specified", { # throws error when limit is a Scale object instead of vector - expect_snapshot_error(ggplot() + coord_transform(xlim=xlim(1,1))) + expect_snapshot_error(ggplot() + coord_transform(xlim = xlim(1, 1))) # throws error when limit's length is different than two - expect_snapshot_error(ggplot() + coord_transform(ylim=1:3)) + expect_snapshot_error(ggplot() + coord_transform(ylim = 1:3)) }) test_that("transformed coords can be reversed", { @@ -137,8 +137,11 @@ test_that("transformed coords can be reversed", { aes(x = x, y = y) + geom_point() + coord_transform( - x = "log10", y = "log10", - xlim = c(0.1, 1000), ylim = c(0.1, 1000), expand = FALSE, + x = "log10", + y = "log10", + xlim = c(0.1, 1000), + ylim = c(0.1, 1000), + expand = FALSE, reverse = "xy" ) + theme_test() + diff --git a/tests/testthat/test-coord_sf.R b/tests/testthat/test-coord_sf.R index 9e33c73ce0..1ad849dc0a 100644 --- a/tests/testthat/test-coord_sf.R +++ b/tests/testthat/test-coord_sf.R @@ -2,8 +2,22 @@ test_that("basic plot builds without error", { skip_if_not_installed("sf") nc_tiny_coords <- matrix( - c(-81.473, -81.741, -81.67, -81.345, -81.266, -81.24, -81.473, - 36.234, 36.392, 36.59, 36.573, 36.437, 36.365, 36.234), + c( + -81.473, + -81.741, + -81.67, + -81.345, + -81.266, + -81.24, + -81.473, + 36.234, + 36.392, + 36.59, + 36.573, + 36.437, + 36.365, + 36.234 + ), ncol = 2 ) @@ -47,7 +61,10 @@ test_that("graticule lines and axes can be removed via scales", { test_that("axis labels are correct for manual breaks", { skip_if_not_installed("sf") - plot <- ggplot(sf::st_polygon(list(matrix(1e3*c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2)))) + + plot <- ggplot(sf::st_polygon(list(matrix( + 1e3 * c(1, 2, 3, 1, 1, 3, 2, 1), + ncol = 2 + )))) + geom_sf() # autogenerated labels @@ -70,7 +87,10 @@ test_that("axis labels are correct for manual breaks", { test_that("axis labels can be set manually", { skip_if_not_installed("sf") - plot <- ggplot(sf::st_polygon(list(matrix(1e3*c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2)))) + + plot <- ggplot(sf::st_polygon(list(matrix( + 1e3 * c(1, 2, 3, 1, 1, 3, 2, 1), + ncol = 2 + )))) + geom_sf() # character labels @@ -114,7 +134,10 @@ test_that("axis labels can be set manually", { test_that("factors are treated like character labels and are not parsed", { skip_if_not_installed("sf") - plot <- ggplot(sf::st_polygon(list(matrix(1e3*c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2)))) + + plot <- ggplot(sf::st_polygon(list(matrix( + 1e3 * c(1, 2, 3, 1, 1, 3, 2, 1), + ncol = 2 + )))) + geom_sf() b <- ggplot_build( @@ -125,7 +148,11 @@ test_that("factors are treated like character labels and are not parsed", { ) + scale_y_continuous( breaks = c(1000, 1500, 2000), - labels = factor(c("1 * degree * N", "1.5 * degree * N", "2 * degree * N")) + labels = factor(c( + "1 * degree * N", + "1.5 * degree * N", + "2 * degree * N" + )) ) ) graticule <- b@layout$panel_params[[1]]$graticule @@ -142,7 +169,10 @@ test_that("factors are treated like character labels and are not parsed", { test_that("expressions can be mixed with character labels", { skip_if_not_installed("sf") - plot <- ggplot(sf::st_polygon(list(matrix(1e3*c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2)))) + + plot <- ggplot(sf::st_polygon(list(matrix( + 1e3 * c(1, 2, 3, 1, 1, 3, 2, 1), + ncol = 2 + )))) + geom_sf() b <- ggplot_build( @@ -197,7 +227,7 @@ test_that("degree labels are automatically parsed", { skip_if_not_installed("sf") data <- sf::st_sfc( - sf::st_polygon(list(matrix(1e1*c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2))), + sf::st_polygon(list(matrix(1e1 * c(1, 2, 3, 1, 1, 3, 2, 1), ncol = 2))), crs = 4326 # basic long-lat crs ) plot <- ggplot(data) + geom_sf() @@ -236,7 +266,10 @@ test_that("default crs works", { skip_if_not_installed("sf") polygon <- sf::st_sfc( - sf::st_polygon(list(matrix(c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), ncol = 2))), + sf::st_polygon(list(matrix( + c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), + ncol = 2 + ))), crs = 4326 # basic long-lat crs ) polygon <- sf::st_transform(polygon, crs = 3347) @@ -260,29 +293,29 @@ test_that("default crs works", { # projected sf objects can be mixed with regular geoms using non-projected data expect_doppelganger( "non-sf geoms using long-lat", - p + geom_point(data = points, aes(x, y)) + - coord_sf(default_crs = 4326) + p + geom_point(data = points, aes(x, y)) + coord_sf(default_crs = 4326) ) # coord limits can be specified in long-lat expect_doppelganger( "limits specified in long-lat", - p + geom_point(data = points, aes(x, y)) + + p + + geom_point(data = points, aes(x, y)) + coord_sf(xlim = c(-80.5, -76), ylim = c(36, 41), default_crs = 4326) ) # by default limits are specified in projected coords lims <- sf_transform_xy( list(x = c(-80.5, -76, -78.25, -78.25), y = c(38.5, 38.5, 36, 41)), - 3347, 4326 + 3347, + 4326 ) expect_doppelganger( "limits specified in projected coords", - p + geom_point(data = points_trans, aes(x, y)) + + p + + geom_point(data = points_trans, aes(x, y)) + coord_sf(xlim = lims$x[1:2], ylim = lims$y[3:4]) ) - - }) test_that("sf_transform_xy() works", { @@ -290,7 +323,7 @@ test_that("sf_transform_xy() works", { data <- list( city = c("Charlotte", "Raleigh", "Greensboro"), - x = c(-80.843, -78.639, -79.792), + x = c(-80.843, -78.639, -79.792), y = c(35.227, 35.772, 36.073) ) @@ -311,11 +344,9 @@ test_that("sf_transform_xy() works", { expect_identical(data$city, out2$city) expect_true(all(abs(out2$x - data$x) < 0.01)) expect_true(all(abs(out2$y - data$y) < 0.01)) - }) test_that("when both x and y are AsIs, they are not transformed", { - skip_if_not_installed("sf") p <- ggplot() + @@ -327,18 +358,20 @@ test_that("when both x and y are AsIs, they are not transformed", { grob <- get_layer_grob(p)[[1]] location <- c(as.numeric(grob$x), as.numeric(grob$y)) expect_equal(location, c(0.75, 0.25)) - }) test_that("coord_sf() can use function breaks and n.breaks", { - polygon <- sf::st_sfc( - sf::st_polygon(list(matrix(c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), ncol = 2))), + sf::st_polygon(list(matrix( + c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), + ncol = 2 + ))), crs = 4326 # basic long-lat crs ) polygon <- sf::st_transform(polygon, crs = 3347) - p <- ggplot(polygon) + geom_sf(fill = NA) + + p <- ggplot(polygon) + + geom_sf(fill = NA) + scale_x_continuous(breaks = breaks_width(0.5)) + scale_y_continuous(n.breaks = 4) @@ -358,16 +391,22 @@ test_that("coord_sf() can use function breaks and n.breaks", { test_that("coord_sf() uses the guide system", { skip_if_not_installed("sf") polygon <- sf::st_sfc( - sf::st_polygon(list(matrix(c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), ncol = 2))), + sf::st_polygon(list(matrix( + c(-80, -76, -76, -80, -80, 35, 35, 40, 40, 35), + ncol = 2 + ))), crs = 4326 # basic long-lat crs ) polygon <- sf::st_transform(polygon, crs = 3347) - p <- ggplot(polygon) + geom_sf(fill = NA) + + p <- ggplot(polygon) + + geom_sf(fill = NA) + coord_sf(label_graticule = "NSWE") + # All of the labels scale_x_continuous(guide = guide_none("guide_none() with title")) + - scale_y_continuous(guide = guide_axis(angle = 45), - name = "title from scale") + + scale_y_continuous( + guide = guide_axis(angle = 45), + name = "title from scale" + ) + guides( x.sec = guide_axis(angle = -45), y.sec = guide_axis(n.dodge = 2, title = "Secondary guide via `guides()`") @@ -382,10 +421,10 @@ test_that("coord_sf() uses the guide system", { test_that("coord_sf() throws error when limits are badly specified", { skip_if_not_installed("sf") # throws error when limit is a Scale object instead of vector - expect_snapshot_error(ggplot() + coord_sf(xlim(1,1))) + expect_snapshot_error(ggplot() + coord_sf(xlim(1, 1))) # throws error when limit's length is different than two - expect_snapshot_error(ggplot() + coord_sf(ylim=1:3)) + expect_snapshot_error(ggplot() + coord_sf(ylim = 1:3)) }) test_that("sf coords can be reversed", { @@ -394,7 +433,9 @@ test_that("sf coords can be reversed", { p <- ggplot(sf::st_multipoint(cbind(c(0, 2), c(0, 2)))) + geom_sf() + coord_sf( - xlim = c(-1, 3), ylim = c(-1, 3), expand = FALSE, + xlim = c(-1, 3), + ylim = c(-1, 3), + expand = FALSE, reverse = "xy" ) + theme_test() + @@ -403,7 +444,6 @@ test_that("sf coords can be reversed", { }) test_that("coord_sf() can render with empty graticules", { - skip_if_not_installed("sf") # Skipping this test on CRAN as changes upstream in {sf} might affect # this test, i.e. when suddenly graticules *do* work diff --git a/tests/testthat/test-draw-key.R b/tests/testthat/test-draw-key.R index 223bfd6d5c..13ceea7b40 100644 --- a/tests/testthat/test-draw-key.R +++ b/tests/testthat/test-draw-key.R @@ -4,27 +4,34 @@ test_that("alternative key glyphs work", { df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) # specify key glyph by name - expect_doppelganger("time series and polygon key glyphs", + expect_doppelganger( + "time series and polygon key glyphs", ggplot(df, aes(x, y)) + geom_line(aes(color = "line"), key_glyph = "timeseries") + geom_point(aes(fill = z), pch = 21, size = 3, key_glyph = "polygon") + guides(fill = guide_legend(order = 1)) - ) + ) # specify key glyph by function - expect_doppelganger("rectangle and dotplot key glyphs", + expect_doppelganger( + "rectangle and dotplot key glyphs", ggplot(df, aes(x, y)) + geom_line(aes(color = "line"), key_glyph = draw_key_rect) + - geom_point(aes(fill = z), pch = 21, size = 3, stroke = 2, key_glyph = draw_key_dotplot) + + geom_point( + aes(fill = z), + pch = 21, + size = 3, + stroke = 2, + key_glyph = draw_key_dotplot + ) + guides(fill = guide_legend(order = 1)) ) }) test_that("keys can communicate their size", { - draw_key_dummy <- function(data, params, size) { grob <- circleGrob(r = unit(1, "cm")) - attr(grob, "width") <- 2 + attr(grob, "width") <- 2 attr(grob, "height") <- 2 grob } @@ -45,26 +52,31 @@ test_that("horizontal key glyphs work", { upper = 2:3, min = -1:0, max = 3:4, - group1 = c("a","b"), - group2 = c("c","d") + group1 = c("a", "b"), + group2 = c("c", "d") ) - p <- ggplot(df, aes( - x = middle, - xmiddle = middle, - xlower = lower, - xupper = upper, - xmin = min, - xmax = max - )) + p <- ggplot( + df, + aes( + x = middle, + xmiddle = middle, + xlower = lower, + xupper = upper, + xmin = min, + xmax = max + ) + ) - expect_doppelganger("horizontal boxplot and crossbar", + expect_doppelganger( + "horizontal boxplot and crossbar", p + geom_boxplot(aes(y = group1, color = group1), stat = "identity") + geom_crossbar(aes(y = group2, fill = group2)) + guides(color = guide_legend(order = 1)) ) - expect_doppelganger("horizontal linerange and pointrange", + expect_doppelganger( + "horizontal linerange and pointrange", p + geom_linerange(aes(y = group1, color = group1)) + geom_pointrange(aes(y = group2, shape = group2)) + @@ -73,15 +85,17 @@ test_that("horizontal key glyphs work", { }) test_that("keep_draw_key", { - - key <- data_frame0(.value = c("A", "C")) + key <- data_frame0(.value = c("A", "C")) data <- data_frame0(foo = c("A", "B"), bar = c("B", "C")) - expect_true( keep_key_data(key, data, "foo", show = TRUE)) + expect_true(keep_key_data(key, data, "foo", show = TRUE)) expect_false(keep_key_data(key, data, "foo", show = FALSE)) expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, FALSE)) expect_equal(keep_key_data(key, data, "bar", show = NA), c(FALSE, TRUE)) - expect_equal(keep_key_data(key, data, c("foo", "bar"), show = NA), c(TRUE, TRUE)) + expect_equal( + keep_key_data(key, data, c("foo", "bar"), show = NA), + c(TRUE, TRUE) + ) # Named show expect_true( @@ -97,7 +111,7 @@ test_that("keep_draw_key", { ) # Missing values - key <- data_frame0(.value = c("A", "B", NA)) + key <- data_frame0(.value = c("A", "B", NA)) data <- data_frame0(foo = c("A", "B", "C")) # 'C' should count as NA expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, TRUE, TRUE)) @@ -113,5 +127,4 @@ test_that("keep_draw_key", { suppressWarnings(scale_alpha_discrete()) expect_doppelganger("appropriate colour key with alpha key as lines", p) - }) diff --git a/tests/testthat/test-empty-data.R b/tests/testthat/test-empty-data.R index e6fe24ce38..cd9a288538 100644 --- a/tests/testthat/test-empty-data.R +++ b/tests/testthat/test-empty-data.R @@ -1,11 +1,16 @@ -df0 <- data_frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = numeric(0)) +df0 <- data_frame( + mpg = numeric(0), + wt = numeric(0), + am = numeric(0), + cyl = numeric(0) +) test_that("layers with empty data are silently omitted", { # Empty data (no visible points) - d <- ggplot(df0, aes(mpg,wt)) + geom_point() + d <- ggplot(df0, aes(mpg, wt)) + geom_point() expect_equal(nrow(get_layer_data(d)), 0) - d <- ggplot() + geom_point(data = df0, aes(mpg,wt)) + d <- ggplot() + geom_point(data = df0, aes(mpg, wt)) expect_equal(nrow(get_layer_data(d)), 0) # Regular mtcars data, x=mpg, y=wt, normal points and points from empty data frame @@ -98,5 +103,5 @@ test_that("missing layers generate one grob per panel", { base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) expect_length(get_layer_grob(base), 1) - expect_length(get_layer_grob(base + facet_wrap(~ g)), 2) + expect_length(get_layer_grob(base + facet_wrap(~g)), 2) }) diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 71f78c1cf2..e50ae38ec5 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -1,17 +1,29 @@ test_that("as_facets_list() coerces formulas", { expect_identical(as_facets_list(~foo), list(quos(), quos(foo = foo))) - expect_identical(as_facets_list(~foo + bar), list(quos(), quos(foo = foo, bar = bar))) - expect_identical(as_facets_list(foo ~ bar), list(quos(foo = foo), quos(bar = bar))) + expect_identical( + as_facets_list(~ foo + bar), + list(quos(), quos(foo = foo, bar = bar)) + ) + expect_identical( + as_facets_list(foo ~ bar), + list(quos(foo = foo), quos(bar = bar)) + ) exp <- list(quos(foo = foo, bar = bar), quos(baz = baz, bam = bam)) expect_identical(as_facets_list(foo + bar ~ baz + bam), exp) - exp <- list(quos(`foo()`= foo(), `bar()` = bar()), quos(`baz()` = baz(), `bam()` = bam())) + exp <- list( + quos(`foo()` = foo(), `bar()` = bar()), + quos(`baz()` = baz(), `bam()` = bam()) + ) expect_identical(as_facets_list(foo() + bar() ~ baz() + bam()), exp) }) test_that("as_facets_list() coerces strings containing formulas", { - expect_identical(as_facets_list("foo ~ bar"), as_facets_list(local(foo ~ bar, globalenv()))) + expect_identical( + as_facets_list("foo ~ bar"), + as_facets_list(local(foo ~ bar, globalenv())) + ) }) test_that("as_facets_list() coerces character vectors", { @@ -49,10 +61,13 @@ test_that("facets reject aes()", { test_that("compact_facets() returns a quosures object with compacted", { expect_identical(compact_facets(vars(foo)), quos(foo = foo)) - expect_identical(compact_facets(~foo + bar), quos(foo = foo, bar = bar)) + expect_identical(compact_facets(~ foo + bar), quos(foo = foo, bar = bar)) f <- function(x) { - expect_identical(compact_facets(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar)) + expect_identical( + compact_facets(vars(foo, {{ x }}, bar)), + quos(foo = foo, bar = bar) + ) } f(NULL) @@ -60,11 +75,20 @@ test_that("compact_facets() returns a quosures object with compacted", { }) test_that("grid_as_facets_list() returns a list of quosures objects with compacted", { - expect_identical(grid_as_facets_list(vars(foo), NULL), list(rows = quos(foo = foo), cols = quos())) - expect_identical(grid_as_facets_list(~foo, NULL), list(rows = quos(), cols = quos(foo = foo))) + expect_identical( + grid_as_facets_list(vars(foo), NULL), + list(rows = quos(foo = foo), cols = quos()) + ) + expect_identical( + grid_as_facets_list(~foo, NULL), + list(rows = quos(), cols = quos(foo = foo)) + ) f <- function(x) { - expect_identical(grid_as_facets_list(vars(foo, {{ x }}, bar), NULL), list(rows = quos(foo = foo, bar = bar), cols = quos())) + expect_identical( + grid_as_facets_list(vars(foo, {{ x }}, bar), NULL), + list(rows = quos(foo = foo, bar = bar), cols = quos()) + ) } f(NULL) @@ -78,10 +102,22 @@ test_that("compact_facets() and grid_as_facets_list() accept empty specs", { expect_identical(compact_facets(list(. ~ .)), quos()) expect_identical(compact_facets(list(NULL)), quos()) - expect_identical(grid_as_facets_list(list(), NULL), list(rows = quos(), cols = quos())) - expect_identical(grid_as_facets_list(. ~ ., NULL), list(rows = quos(), cols = quos())) - expect_identical(grid_as_facets_list(list(. ~ .), NULL), list(rows = quos(), cols = quos())) - expect_identical(grid_as_facets_list(list(NULL), NULL), list(rows = quos(), cols = quos())) + expect_identical( + grid_as_facets_list(list(), NULL), + list(rows = quos(), cols = quos()) + ) + expect_identical( + grid_as_facets_list(. ~ ., NULL), + list(rows = quos(), cols = quos()) + ) + expect_identical( + grid_as_facets_list(list(. ~ .), NULL), + list(rows = quos(), cols = quos()) + ) + expect_identical( + grid_as_facets_list(list(NULL), NULL), + list(rows = quos(), cols = quos()) + ) }) test_that("facets split up the data", { @@ -136,9 +172,15 @@ test_that("facet_grid() accepts vars()", { expect_identical(grid$params$cols, quos(bar = bar)) expect_equal(facet_grid(vars(am, vs))$params, facet_grid(am + vs ~ .)$params) - expect_equal(facet_grid(vars(am, vs), vars(cyl))$params, facet_grid(am + vs ~ cyl)$params) + expect_equal( + facet_grid(vars(am, vs), vars(cyl))$params, + facet_grid(am + vs ~ cyl)$params + ) expect_equal(facet_grid(NULL, vars(cyl))$params, facet_grid(. ~ cyl)$params) - expect_equal(facet_grid(vars(am, vs), TRUE)$params, facet_grid(am + vs ~ ., margins = TRUE)$params) + expect_equal( + facet_grid(vars(am, vs), TRUE)$params, + facet_grid(am + vs ~ ., margins = TRUE)$params + ) }) test_that("facet_grid() fails if passed both a formula and a vars()", { @@ -215,7 +257,8 @@ test_that("shrink parameter affects scaling", { r2 <- pranges(l2) expect_equal(r2$y[[1]], c(2, 2)) - l3 <- ggplot(df, aes(1, y)) + stat_summary(fun = "mean") + + l3 <- ggplot(df, aes(1, y)) + + stat_summary(fun = "mean") + facet_null(shrink = FALSE) r3 <- pranges(l3) expect_equal(r3$y[[1]], c(1, 3)) @@ -223,7 +266,7 @@ test_that("shrink parameter affects scaling", { test_that("facet variables", { expect_identical(facet_null()$vars(), character(0)) - expect_identical(facet_wrap(~ a)$vars(), "a") + expect_identical(facet_wrap(~a)$vars(), "a") expect_identical(facet_grid(a ~ b)$vars(), c("a", "b")) }) @@ -236,7 +279,6 @@ test_that("facet gives clear error if ", { }) test_that("facet_grid `axis_labels` argument can be overruled", { - f <- facet_grid(vars(cyl), axes = "all", axis.labels = "all") expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) @@ -246,39 +288,62 @@ test_that("facet_grid `axis_labels` argument can be overruled", { # Overrule when only drawing at margins f <- facet_grid(vars(cyl), axes = "margins", axis.labels = "margins") expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - }) test_that("facet_wrap `axis_labels` argument can be overruled", { - # The folllowing three should all draw axis labels - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "all") + f <- facet_wrap( + vars(cyl), + scales = "fixed", + axes = "all", + axis.labels = "all" + ) expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "all") expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "all") + f <- facet_wrap( + vars(cyl), + scales = "fixed", + axes = "margins", + axis.labels = "all" + ) expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) # The only case when labels shouldn't be drawn is when scales are fixed but # the axes are to be drawn - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "margins") + f <- facet_wrap( + vars(cyl), + scales = "fixed", + axes = "all", + axis.labels = "margins" + ) expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE)) # Should draw labels because scales are free - f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "margins") + f <- facet_wrap( + vars(cyl), + scales = "free", + axes = "all", + axis.labels = "margins" + ) expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) # Should draw labels because only drawing at margins - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "margins") + f <- facet_wrap( + vars(cyl), + scales = "fixed", + axes = "margins", + axis.labels = "margins" + ) expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - }) test_that("facet_grid `axes` can draw inner axes.", { df <- data_frame( - x = 1:4, y = 1:4, + x = 1:4, + y = 1:4, fx = c("A", "A", "B", "B"), fy = c("c", "d", "c", "d") ) @@ -303,7 +368,9 @@ test_that("facet_grid `axes` can draw inner axes.", { test_that("facet_wrap `axes` can draw inner axes.", { df <- data_frame( - x = 1, y = 1, facet = LETTERS[1:4] + x = 1, + y = 1, + facet = LETTERS[1:4] ) p <- ggplot(df, aes(x, y)) + geom_point() @@ -376,7 +443,12 @@ test_that("combine_vars() generates the correct combinations", { ) attr(df_all, "out.attrs") <- NULL - vars_all <- vars(letter = letter, number = number, boolean = boolean, factor = factor) + vars_all <- vars( + letter = letter, + number = number, + boolean = boolean, + factor = factor + ) expect_equal( combine_vars(list(df_one), vars = vars_all), @@ -395,21 +467,23 @@ test_that("combine_vars() generates the correct combinations", { # they appear in the data (in addition to keeping unused factor levels) expect_equal( combine_vars(list(df_one), vars = vars_all, drop = FALSE), - df_all[order(df_all$letter, df_all$number, df_all$boolean, df_all$factor), ], - ignore_attr = TRUE # do not compare `row.names` + df_all[ + order(df_all$letter, df_all$number, df_all$boolean, df_all$factor), + ], + ignore_attr = TRUE # do not compare `row.names` ) expect_snapshot_error( combine_vars( list(data.frame(a = 1:2, b = 2:3), data.frame(a = 1:2, c = 2:3)), - vars = vars(b=b, c=c) + vars = vars(b = b, c = c) ) ) expect_snapshot_error( combine_vars( list(data.frame(a = 1:2), data.frame(b = numeric())), - vars = vars(b=b) + vars = vars(b = b) ) ) }) @@ -427,7 +501,11 @@ test_that("drop = FALSE in combine_vars() keeps unused factor levels", { }) test_that("combine_vars() generates the correct combinations with multiple data frames", { - df <- expand.grid(letter = c("a", "b"), number = c(1, 2), boolean = c(TRUE, FALSE)) + df <- expand.grid( + letter = c("a", "b"), + number = c(1, 2), + boolean = c(TRUE, FALSE) + ) vars <- vars(letter = letter, number = number) expect_identical( @@ -449,13 +527,25 @@ test_that("combine_vars() generates the correct combinations with multiple data }) test_that("eval_facet() is tolerant for missing columns (#2963)", { - expect_null(eval_facet(quo(2 * x), data_frame(foo = 1), possible_columns = c("x"))) - expect_null(eval_facet(quo(2 * .data$x), data_frame(foo = 1), possible_columns = c("x"))) + expect_null(eval_facet( + quo(2 * x), + data_frame(foo = 1), + possible_columns = c("x") + )) + expect_null(eval_facet( + quo(2 * .data$x), + data_frame(foo = 1), + possible_columns = c("x") + )) # Even if there's the same name of external variable, eval_facet() returns NULL before # reaching to the variable bar <- 2 - expect_null(eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("bar"))) + expect_null(eval_facet( + quo(2 * bar), + data_frame(foo = 1), + possible_columns = c("bar") + )) # If there's no same name of columns, the external variable is used expect_equal( eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("x")), @@ -464,7 +554,11 @@ test_that("eval_facet() is tolerant for missing columns (#2963)", { # If the expression contains any non-existent variable, it fails expect_snapshot( - eval_facet(quo(no_such_variable * x), data_frame(foo = 1), possible_columns = c("x")), + eval_facet( + quo(no_such_variable * x), + data_frame(foo = 1), + possible_columns = c("x") + ), error = TRUE ) }) @@ -481,7 +575,6 @@ test_that("check_layout() throws meaningful errors", { # Visual tests ------------------------------------------------------------ test_that("facet labels respect both justification and margin arguments", { - df <- data_frame( x = 1:2, y = 1:2, @@ -495,8 +588,10 @@ test_that("facet labels respect both justification and margin arguments", { theme_test() p1 <- base + - theme(strip.text.x = element_text(hjust = 0, margin = margin(5, 5, 5, 5)), - strip.text.y = element_text(hjust = 0, margin = margin(5, 5, 5, 5))) + theme( + strip.text.x = element_text(hjust = 0, margin = margin(5, 5, 5, 5)), + strip.text.y = element_text(hjust = 0, margin = margin(5, 5, 5, 5)) + ) p2 <- base + theme( @@ -517,14 +612,14 @@ test_that("facet labels respect both justification and margin arguments", { }) test_that("facet's 'axis_labels' argument correctly omits labels", { - base <- ggplot(mtcars, aes(mpg, disp)) + geom_point() + guides(x = "axis", y = "axis", x.sec = "axis", y.sec = "axis") expect_doppelganger( "facet_grid with omitted inner axis labels", - base + facet_grid(vars(cyl), vars(vs), axes = "all", axis.labels = "margins") + base + + facet_grid(vars(cyl), vars(vs), axes = "all", axis.labels = "margins") ) expect_doppelganger( diff --git a/tests/testthat/test-facet-labels.R b/tests/testthat/test-facet-labels.R index f755e93aa8..e69d45d2f1 100644 --- a/tests/testthat/test-facet-labels.R +++ b/tests/testthat/test-facet-labels.R @@ -45,8 +45,14 @@ test_that("labellers handle facet labels properly", { expect_identical(label_value(labels), labels) expect_identical(label_value(labels, FALSE), list(c("a, c", "b, d"))) - expect_identical(label_both(labels), list(c("var1: a", "var1: b"), c("var2: c", "var2: d"))) - expect_identical(label_both(labels, FALSE), list(c("var1, var2: a, c", "var1, var2: b, d"))) + expect_identical( + label_both(labels), + list(c("var1: a", "var1: b"), c("var2: c", "var2: d")) + ) + expect_identical( + label_both(labels, FALSE), + list(c("var1, var2: a, c", "var1, var2: b, d")) + ) }) test_that("labellers handle plotmath expressions", { @@ -84,25 +90,49 @@ test_that("labeller() dispatches labellers", { expect_equal(get_labels_matrix(p2), expected_cyl_both) # facet_wrap() shouldn't get both rows and cols - p3 <- p + facet_wrap(~cyl, labeller = labeller( - .cols = label_both, .rows = label_both)) + p3 <- p + + facet_wrap( + ~cyl, + labeller = labeller( + .cols = label_both, + .rows = label_both + ) + ) expect_snapshot(ggplotGrob(p3), error = TRUE) # facet_grid() can get both rows and cols - p4 <- p + facet_grid(am ~ cyl, labeller = labeller( - .cols = label_both, .rows = label_both)) + p4 <- p + + facet_grid( + am ~ cyl, + labeller = labeller( + .cols = label_both, + .rows = label_both + ) + ) expect_equal(get_labels_matrix(p4, "rows"), expected_am_both) expect_equal(get_labels_matrix(p4, "cols"), expected_cyl_both) # Cannot have a specific labeller for a variable which already has a # margin-wide labeller - p5 <- p + facet_wrap(~cyl, labeller = labeller( - .rows = label_both, cyl = label_value)) + p5 <- p + + facet_wrap( + ~cyl, + labeller = labeller( + .rows = label_both, + cyl = label_value + ) + ) expect_snapshot(ggplotGrob(p5), error = TRUE) # Variables can be attributed labellers - p6 <- p + facet_grid(am + cyl ~ ., labeller = labeller( - am = label_both, cyl = label_both)) + p6 <- p + + facet_grid( + am + cyl ~ ., + labeller = labeller( + am = label_both, + cyl = label_both + ) + ) expect_equal( get_labels_matrix(p6, "rows"), cbind( @@ -126,7 +156,8 @@ test_that("as_labeller() deals with non-labellers", { expect_equal(get_labels_matrix(p1), cbind(c("zero", "one"))) # Non-labeller function taking character vectors - p2 <- p + facet_wrap(~am, labeller = labeller(am = function(x) paste0(x, "-foo"))) + p2 <- p + + facet_wrap(~am, labeller = labeller(am = function(x) paste0(x, "-foo"))) expect_equal(get_labels_matrix(p2), cbind(c("0-foo", "1-foo"))) }) @@ -148,12 +179,11 @@ test_that("parsed labels are rendered correctly", { "parsed facet labels", ggplot(df, aes(x, y)) + labs(x = NULL, y = NULL) + - facet_wrap(~ f, labeller = label_parsed) + facet_wrap(~f, labeller = label_parsed) ) }) test_that("outside-justified labels are justified across panels", { - df <- data.frame( x = c("X\nX\nX\nX\nX", "X"), y = c("YYYYY", "Y"), @@ -170,9 +200,9 @@ test_that("outside-justified labels are justified across panels", { facet_grid(f1 ~ f2, scales = "free") + guides(x.sec = "axis", y.sec = "axis") + theme( - axis.text.y.left = element_text(hjust = 0), - axis.text.y.right = element_text(hjust = 1), - axis.text.x.top = element_text(vjust = 1), + axis.text.y.left = element_text(hjust = 0), + axis.text.y.right = element_text(hjust = 1), + axis.text.x.top = element_text(vjust = 1), axis.text.x.bottom = element_text(vjust = 0) ) diff --git a/tests/testthat/test-facet-layout.R b/tests/testthat/test-facet-layout.R index a008a0c80d..e60cca79d2 100644 --- a/tests/testthat/test-facet-layout.R +++ b/tests/testthat/test-facet-layout.R @@ -10,15 +10,15 @@ panel_layout <- function(facet, data) { } test_that("grid: single row and single col are equivalent", { - row <- panel_layout(facet_grid(a~.), list(a)) - col <- panel_layout(facet_grid(.~a), list(a)) + row <- panel_layout(facet_grid(a ~ .), list(a)) + col <- panel_layout(facet_grid(. ~ a), list(a)) expect_equal(row$ROW, 1:2) expect_equal(row$ROW, col$COL) expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")]) - row <- panel_layout(facet_grid(a~.), list(a, b)) - col <- panel_layout(facet_grid(.~a), list(a, b)) + row <- panel_layout(facet_grid(a ~ .), list(a, b)) + col <- panel_layout(facet_grid(. ~ a), list(a, b)) expect_equal(row$ROW, 1:3) expect_equal(row$ROW, col$COL) @@ -27,17 +27,16 @@ test_that("grid: single row and single col are equivalent", { test_that("grid: includes all combinations", { d <- data_frame(a = c(1, 2), b = c(2, 1)) - all <- panel_layout(facet_grid(a~b), list(d)) + all <- panel_layout(facet_grid(a ~ b), list(d)) expect_equal(nrow(all), 4) }) test_that("wrap: layout sorting is correct", { - dummy <- list(data_frame0(x = 1:5)) test <- panel_layout(facet_wrap(~x, dir = "lt"), dummy) - expect_equal(test$ROW, rep(c(1,2), c(3, 2))) + expect_equal(test$ROW, rep(c(1, 2), c(3, 2))) expect_equal(test$COL, c(1:3, 1:2)) test <- panel_layout(facet_wrap(~x, dir = "tl"), dummy) @@ -67,21 +66,20 @@ test_that("wrap: layout sorting is correct", { test <- panel_layout(facet_wrap(~x, dir = "br"), dummy) expect_equal(test$ROW, c(2, 1, 2, 1, 2)) expect_equal(test$COL, c(3, 3, 2, 2, 1)) - }) test_that("wrap and grid are equivalent for 1d data", { - rowg <- panel_layout(facet_grid(a~.), list(a)) + rowg <- panel_layout(facet_grid(a ~ .), list(a)) roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a)) expect_equal(roww, rowg) - colg <- panel_layout(facet_grid(.~a), list(a)) + colg <- panel_layout(facet_grid(. ~ a), list(a)) colw <- panel_layout(facet_wrap(~a, nrow = 1), list(a)) expect_equal(colw, colg) }) test_that("grid: crossed rows/cols create no more combinations than necessary", { - facet <- facet_grid(a~b) + facet <- facet_grid(a ~ b) one <- panel_layout(facet, list(a)) expect_equal(nrow(one), 4) @@ -100,13 +98,13 @@ test_that("grid: crossed rows/cols create no more combinations than necessary", }) test_that("grid: nested rows/cols create no more combinations than necessary", { - one <- panel_layout(facet_grid(drv+cyl~.), list(mpg)) + one <- panel_layout(facet_grid(drv + cyl ~ .), list(mpg)) expect_equal(one$PANEL, factor(1:9)) expect_equal(one$ROW, 1:9) }) test_that("grid: margins add correct combinations", { - one <- panel_layout(facet_grid(a~b, margins = TRUE), list(a)) + one <- panel_layout(facet_grid(a ~ b, margins = TRUE), list(a)) expect_equal(nrow(one), 4 + 2 + 2 + 1) }) @@ -127,10 +125,10 @@ test_that("wrap: as.table = FALSE gets axes", { }) test_that("grid: as.table reverses rows", { - one <- panel_layout(facet_grid(a~., as.table = FALSE), list(a)) + one <- panel_layout(facet_grid(a ~ ., as.table = FALSE), list(a)) expect_equal(as.character(one$a), c("2", "1")) - two <- panel_layout(facet_grid(a~., as.table = TRUE), list(a)) + two <- panel_layout(facet_grid(a ~ ., as.table = TRUE), list(a)) expect_equal(as.character(two$a), c("1", "2")) }) @@ -158,22 +156,21 @@ test_that("wrap: drop = FALSE preserves unused levels", { }) test_that("grid: drop = FALSE preserves unused levels", { - grid_a <- panel_layout(facet_grid(a~., drop = FALSE), list(a2)) + grid_a <- panel_layout(facet_grid(a ~ ., drop = FALSE), list(a2)) expect_equal(nrow(grid_a), 4) expect_equal(as.character(grid_a$a), as.character(1:4)) - grid_b <- panel_layout(facet_grid(b~., drop = FALSE), list(a2)) + grid_b <- panel_layout(facet_grid(b ~ ., drop = FALSE), list(a2)) expect_equal(nrow(grid_b), 4) expect_equal(as.character(grid_b$b), as.character(4:1)) - grid_ab <- panel_layout(facet_grid(a~b, drop = FALSE), list(a2)) + grid_ab <- panel_layout(facet_grid(a ~ b, drop = FALSE), list(a2)) expect_equal(nrow(grid_ab), 16) expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4))) expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4))) }) test_that("wrap: space = 'free_x/y' sets panel sizes", { - df <- data.frame(x = 1:3) p <- ggplot(df, aes(x, x)) + geom_point() + @@ -203,9 +200,9 @@ test_that("missing values get a panel", { wrap_a <- panel_layout(facet_wrap(~a), list(a3)) wrap_b <- panel_layout(facet_wrap(~b), list(a3)) wrap_c <- panel_layout(facet_wrap(~c), list(a3)) - grid_a <- panel_layout(facet_grid(a~.), list(a3)) - grid_b <- panel_layout(facet_grid(b~.), list(a3)) - grid_c <- panel_layout(facet_grid(c~.), list(a3)) + grid_a <- panel_layout(facet_grid(a ~ .), list(a3)) + grid_b <- panel_layout(facet_grid(b ~ .), list(a3)) + grid_c <- panel_layout(facet_grid(c ~ .), list(a3)) expect_equal(nrow(wrap_a), 4) expect_equal(nrow(wrap_b), 4) @@ -243,12 +240,12 @@ test_that("facet_wrap throws errors at bad layout specs", { test_that("facet_grid throws errors at bad layout specs", { p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + - facet_grid(.~gear, scales = "free") + + facet_grid(. ~ gear, scales = "free") + coord_fixed() expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + - facet_grid(.~gear, space = "free") + + facet_grid(. ~ gear, space = "free") + theme(aspect.ratio = 1) expect_snapshot_error(ggplotGrob(p)) }) @@ -260,13 +257,14 @@ test_that("facet_grid can respect coord aspect with free scales/space", { facet_grid( rows = vars(y == "C"), cols = vars(x %in% c("e", "f")), - scales = "free", space = "free" + scales = "free", + space = "free" ) + coord_fixed(3, expand = FALSE) gt <- ggplotGrob(p) - width <- gt$widths[panel_cols(gt)$l] + width <- gt$widths[panel_cols(gt)$l] height <- gt$heights[panel_rows(gt)$t] - expect_equal(as.numeric(width), c(4, 2)) + expect_equal(as.numeric(width), c(4, 2)) expect_equal(as.numeric(height), c(6, 3)) }) diff --git a/tests/testthat/test-facet-map.R b/tests/testthat/test-facet-map.R index 4ce6e24329..ce5d7a2c8a 100644 --- a/tests/testthat/test-facet-map.R +++ b/tests/testthat/test-facet-map.R @@ -9,7 +9,7 @@ panel_map_one <- function(facet, data, plot_data = data) { } test_that("two col cases with no missings adds a single extra column", { - loc <- panel_map_one(facet_grid(cyl~vs), mtcars) + loc <- panel_map_one(facet_grid(cyl ~ vs), mtcars) expect_equal(nrow(loc), nrow(mtcars)) expect_equal(ncol(loc), ncol(mtcars) + 1) @@ -19,7 +19,7 @@ test_that("two col cases with no missings adds a single extra column", { }) test_that("margins add extra data", { - loc <- panel_map_one(facet_grid(a~b, margins = "b"), df) + loc <- panel_map_one(facet_grid(a ~ b, margins = "b"), df) expect_equal(nrow(loc), nrow(df) * 2) @@ -29,7 +29,7 @@ test_that("margins add extra data", { }) test_that("grid: missing facet columns are duplicated", { - facet <- facet_grid(a~b) + facet <- facet_grid(a ~ b) loc_a <- panel_map_one(facet, df_a, plot_data = df) expect_equal(nrow(loc_a), 4) @@ -45,7 +45,7 @@ test_that("grid: missing facet columns are duplicated", { }) test_that("wrap: missing facet columns are duplicated", { - facet <- facet_wrap(~a+b, ncol = 1) + facet <- facet_wrap(~ a + b, ncol = 1) loc_a <- panel_map_one(facet, df_a, plot_data = df) expect_equal(nrow(loc_a), 4) @@ -62,7 +62,9 @@ test_that("wrap: missing facet columns are duplicated", { }) test_that("wrap and grid can facet by a date variable", { - date_df <- data_frame(date_var = as.Date(c("1971-12-11", "1987-01-13", "2000-01-01"))) + date_df <- data_frame( + date_var = as.Date(c("1971-12-11", "1987-01-13", "2000-01-01")) + ) wrap <- facet_wrap(~date_var) loc_wrap <- panel_map_one(wrap, date_df) @@ -78,7 +80,9 @@ test_that("wrap and grid can facet by a date variable", { }) test_that("wrap and grid can facet by a POSIXct variable", { - date_df <- data_frame(date_var = as.POSIXct(c("1971-12-11", "1987-01-13", "2000-01-01"))) + date_df <- data_frame( + date_var = as.POSIXct(c("1971-12-11", "1987-01-13", "2000-01-01")) + ) wrap <- facet_wrap(~date_var) loc_wrap <- panel_map_one(wrap, date_df) @@ -94,14 +98,13 @@ test_that("wrap and grid can facet by a POSIXct variable", { }) test_that("wrap: layer layout is respected", { - df <- expand.grid(x = LETTERS[1:2], y = 1:3) p <- ggplot(df, aes(x, y)) + geom_point(colour = "red", layout = "fixed") + geom_point() + geom_point(colour = "blue", layout = 5) + - facet_wrap(~ x + y) + facet_wrap(~ x + y) b <- ggplot_build(p) expect_equal( @@ -119,7 +122,6 @@ test_that("wrap: layer layout is respected", { }) test_that("grid: layer layout is respected", { - df <- expand.grid(x = LETTERS[1:2], y = 1:3) p <- ggplot(df, aes(x, y)) + @@ -157,7 +159,7 @@ test_that("grid: layer layout is respected", { # Missing behaviour ---------------------------------------------------------- a3 <- data_frame( -# a = c(1:3, NA), Not currently supported + # a = c(1:3, NA), Not currently supported b = factor(c(1:3, NA)), c = factor(c(1:3, NA), exclude = NULL) ) @@ -173,23 +175,26 @@ test_that("wrap: missing values are located correctly", { }) test_that("grid: missing values are located correctly", { - facet <- facet_grid(b~.) + facet <- facet_grid(b ~ .) loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) expect_equal(as.character(loc_b$PANEL), "4") - facet <- facet_grid(c~.) + facet <- facet_grid(c ~ .) loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) expect_equal(as.character(loc_c$PANEL), "4") }) # Facet order ---------------------------------------------------------------- -get_layout <- function(p) ggplot_build(p)@layout$layout +get_layout <- function(p) ggplot_build(p)@layout$layout # Data with factor f with levels CBA -d <- data_frame(x = 1:9, y = 1:9, +d <- data_frame( + x = 1:9, + y = 1:9, fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]), - fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1])) + fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1]) +) # Data with factor f with only level B d2 <- data_frame(x = 1:9, y = 2:10, fx = factor("a"), fy = factor("B")) @@ -200,55 +205,79 @@ test_that("grid: facet order follows default data frame order", { # CBA for rows 1:3 # cba for cols 1:3 lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + geom_point()) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) + expect_equal(as.character(lay$fy), c("C", "B", "A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$COL]) # When adding d2, facets should still be in order: # CBA for rows 1:3 # cba for cols 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + - geom_blank(data = d2) + geom_point()) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) + lay <- get_layout( + ggplot(d, aes(x, y)) + + facet_grid(fy ~ fx) + + geom_blank(data = d2) + + geom_point() + ) + expect_equal(as.character(lay$fy), c("C", "B", "A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$COL]) # With no default data: should search each layer in order # BCA for rows 1:3 # acb for cols 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + - geom_blank(data = d2) + geom_point(data = d)) - expect_equal(as.character(lay$fy), c("B","C","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("a","c","b")[lay$COL]) + lay <- get_layout( + ggplot(mapping = aes(x, y)) + + facet_grid(fy ~ fx) + + geom_blank(data = d2) + + geom_point(data = d) + ) + expect_equal(as.character(lay$fy), c("B", "C", "A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("a", "c", "b")[lay$COL]) # Same as previous, but different layer order. # CBA for rows 1:3 # cba for cols 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + - geom_point(data = d) + geom_blank(data = d2)) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) + lay <- get_layout( + ggplot(mapping = aes(x, y)) + + facet_grid(fy ~ fx) + + geom_point(data = d) + + geom_blank(data = d2) + ) + expect_equal(as.character(lay$fy), c("C", "B", "A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$COL]) }) test_that("wrap: facet order follows default data frame order", { # Facets should be in order: # cba for panels 1:3 lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + geom_point()) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$PANEL]) # When adding d2, facets should still be in order: # cba for panels 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + - geom_blank(data = d2) + geom_point()) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) + lay <- get_layout( + ggplot(d, aes(x, y)) + + facet_wrap(~fx) + + geom_blank(data = d2) + + geom_point() + ) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$PANEL]) # With no default data: should search each layer in order # acb for panels 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + - geom_blank(data = d2) + geom_point(data = d)) - expect_equal(as.character(lay$fx), c("a","c","b")[lay$PANEL]) + lay <- get_layout( + ggplot(mapping = aes(x, y)) + + facet_wrap(~fx) + + geom_blank(data = d2) + + geom_point(data = d) + ) + expect_equal(as.character(lay$fx), c("a", "c", "b")[lay$PANEL]) # Same as previous, but different layer order. # cba for panels 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + - geom_point(data = d) + geom_blank(data = d2)) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) + lay <- get_layout( + ggplot(mapping = aes(x, y)) + + facet_wrap(~fx) + + geom_point(data = d) + + geom_blank(data = d2) + ) + expect_equal(as.character(lay$fx), c("c", "b", "a")[lay$PANEL]) }) diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index 2f1080877f..dbf838af74 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -147,7 +147,8 @@ test_that("padding is only added if axis is present", { expect_length(pg$widths, 18) pg <- ggplotGrob( - p + scale_x_continuous(position = "top") + + p + + scale_x_continuous(position = "top") + scale_y_continuous(position = "right") ) expect_length(pg$heights, 20) @@ -157,7 +158,8 @@ test_that("padding is only added if axis is present", { # Also add padding with negative ticks and no text (#5251) pg <- ggplotGrob( - p + scale_x_continuous(labels = NULL, position = "top") + + p + + scale_x_continuous(labels = NULL, position = "top") + theme(axis.ticks.length.x.top = unit(-2, "mm")) ) expect_length(pg$heights, 20) @@ -178,7 +180,8 @@ test_that("padding is only added if axis is present", { expect_equal(as.character(pg$widths[7]), "1cm") pg <- ggplotGrob( - p + scale_x_continuous(position = "top") + + p + + scale_x_continuous(position = "top") + scale_y_continuous(position = "right") ) expect_length(pg$heights, 19) @@ -210,7 +213,6 @@ test_that("strip clipping can be set from the theme", { }) test_that("strip labels can be accessed", { - expect_null(get_strip_labels(ggplot())) expect_equal( @@ -226,4 +228,3 @@ test_that("strip labels can be accessed", { ) ) }) - diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 2650884942..51f7924c2a 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -3,27 +3,41 @@ test_that("spatial polygons have correct ordering", { skip_if_not_installed("sp") }) - - make_square <- function(x = 0, y = 0, height = 1, width = 1){ - delx <- width/2 - dely <- height/2 - sp::Polygon(matrix(c(x + delx, x - delx,x - delx,x + delx,x + delx , - y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2)) + make_square <- function(x = 0, y = 0, height = 1, width = 1) { + delx <- width / 2 + dely <- height / 2 + sp::Polygon(matrix( + c( + x + delx, + x - delx, + x - delx, + x + delx, + x + delx, + y - dely, + y - dely, + y + dely, + y + dely, + y - dely + ), + ncol = 2 + )) } - make_hole <- function(x = 0, y = 0, height = 0.5, width = 0.5){ + make_hole <- function(x = 0, y = 0, height = 0.5, width = 0.5) { p <- make_square(x = x, y = y, height = height, width = width) p@hole <- TRUE p } - fake_data <- data_frame(ids = 1:5, region = c(1,1,2,3,4)) + fake_data <- data_frame(ids = 1:5, region = c(1, 1, 2, 3, 4)) rownames(fake_data) <- 1:5 - polys <- list(sp::Polygons(list(make_square(), make_hole()), 1), - sp::Polygons(list(make_square(1,0), make_square(2, 0)), 2), - sp::Polygons(list(make_square(1,1)), 3), - sp::Polygons(list(make_square(0,1)), 4), - sp::Polygons(list(make_square(0,3)), 5)) + polys <- list( + sp::Polygons(list(make_square(), make_hole()), 1), + sp::Polygons(list(make_square(1, 0), make_square(2, 0)), 2), + sp::Polygons(list(make_square(1, 1)), 3), + sp::Polygons(list(make_square(0, 1)), 4), + sp::Polygons(list(make_square(0, 3)), 5) + ) polys_sp <- sp::SpatialPolygons(polys) fake_sp <- sp::SpatialPolygonsDataFrame(polys_sp, fake_data) @@ -72,7 +86,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Unhealthy data-frame-like (matrix with no colnames) - expect_snapshot(fortify(cbind(X, Y, Z, deparse.level=0)), error = TRUE) + expect_snapshot(fortify(cbind(X, Y, Z, deparse.level = 0)), error = TRUE) # Healthy data-frame-like (matrix with colnames) @@ -92,11 +106,11 @@ test_that("fortify.default can handle healthy data-frame-like objects", { as.data.frame.foo <- function(x, row.names = NULL, ...) { key <- if (is.null(names(x))) rownames(x) else names(x) - data.frame(key=key, value=unname(unclass(x))) + data.frame(key = key, value = unname(unclass(x))) } registerS3method("as.data.frame", "foo", as.data.frame.foo) - expect_identical(fortify(object), data.frame(key=names(object), value=Y)) + expect_identical(fortify(object), data.frame(key = names(object), value = Y)) # Rejected by fortify.default() because of unhealthy dim() behavior @@ -129,7 +143,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Rejected by fortify.default() because of unhealthy colnames() behavior - dimnames.foo <- function(x) list() # this breaks colnames() + dimnames.foo <- function(x) list() # this breaks colnames() registerS3method("dimnames", "foo", dimnames.foo) expect_snapshot(fortify(object), error = TRUE) @@ -166,7 +180,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { as.data.frame.foo <- function(x, row.names = NULL, ...) { key <- if (is.null(names(x))) rownames(x) else names(x) - data.frame(oops=key, value=unname(unclass(x))) + data.frame(oops = key, value = unname(unclass(x))) } registerS3method("as.data.frame", "foo", as.data.frame.foo) expect_snapshot(fortify(object), error = TRUE) diff --git a/tests/testthat/test-function-args.R b/tests/testthat/test-function-args.R index c5e4e56907..2e8abfec8e 100644 --- a/tests/testthat/test-function-args.R +++ b/tests/testthat/test-function-args.R @@ -1,6 +1,9 @@ filter_args <- function(x) { all_names <- names(x) - all_names <- setdiff(all_names, c("self", "data", "scales", "coordinates", "...")) + all_names <- setdiff( + all_names, + c("self", "data", "scales", "coordinates", "...") + ) x[all_names] } @@ -28,19 +31,31 @@ test_that("geom_xxx and GeomXxx$draw arg defaults match", { # These aren't actually geoms, or need special parameters and can't be tested this way. geom_fun_names <- setdiff( geom_fun_names, - c("geom_map", "geom_sf", "geom_smooth", "geom_column", "geom_area", - "geom_density", "annotation_custom", "annotation_map", "annotation_raster", - "annotation_id", "geom_errorbarh") + c( + "geom_map", + "geom_sf", + "geom_smooth", + "geom_column", + "geom_area", + "geom_density", + "annotation_custom", + "annotation_map", + "annotation_raster", + "annotation_id", + "geom_errorbarh" + ) ) # For each geom_xxx function and the corresponding GeomXxx$draw and # GeomXxx$draw_groups functions, make sure that if they have same args, that # the args have the same default values. lapply(geom_fun_names, function(geom_fun_name) { - geom_fun <- ggplot2_ns[[geom_fun_name]] + geom_fun <- ggplot2_ns[[geom_fun_name]] geom <- geom_fun()$geom - if (!is_geom(geom)) # for geoms that return more than one thing + if (!is_geom(geom)) { + # for geoms that return more than one thing return() + } fun_args <- formals(geom_fun) draw_args <- c( @@ -51,9 +66,16 @@ test_that("geom_xxx and GeomXxx$draw arg defaults match", { common_names <- intersect(names(fun_args), names(draw_args)) - expect_identical(fun_args[common_names], draw_args[common_names], - info = paste0("Mismatch between arg defaults for ", geom_fun_name, - " and ", class(geom_fun()$geom)[1], "'s $draw and/or $draw_group functions.") + expect_identical( + fun_args[common_names], + draw_args[common_names], + info = paste0( + "Mismatch between arg defaults for ", + geom_fun_name, + " and ", + class(geom_fun()$geom)[1], + "'s $draw and/or $draw_group functions." + ) ) }) }) @@ -74,19 +96,29 @@ test_that("stat_xxx and StatXxx$compute_panel arg defaults match", { # StatXxx$compute_group functions, make sure that if they have same args, that # the args have the same default values. lapply(stat_fun_names, function(stat_fun_name) { - stat_fun <- ggplot2_ns[[stat_fun_name]] - calculate <- stat_fun()$stat$compute_panel + stat_fun <- ggplot2_ns[[stat_fun_name]] + calculate <- stat_fun()$stat$compute_panel calculate_groups <- stat_fun()$stat$compute_group fun_args <- formals(stat_fun) - calc_args <- c(ggproto_formals(calculate), ggproto_formals(calculate_groups)) + calc_args <- c( + ggproto_formals(calculate), + ggproto_formals(calculate_groups) + ) calc_args <- filter_args(calc_args) common_names <- intersect(names(fun_args), names(calc_args)) - expect_identical(fun_args[common_names], calc_args[common_names], - info = paste0("Mismatch between arg defaults for ", stat_fun_name, - " and ", class(stat_fun()$stat)[1], "'s $compute_panel and/or $compute_group functions.") + expect_identical( + fun_args[common_names], + calc_args[common_names], + info = paste0( + "Mismatch between arg defaults for ", + stat_fun_name, + " and ", + class(stat_fun()$stat)[1], + "'s $compute_panel and/or $compute_group functions." + ) ) }) }) diff --git a/tests/testthat/test-geom-.R b/tests/testthat/test-geom-.R index 02e0ed9710..1c691e72d0 100644 --- a/tests/testthat/test-geom-.R +++ b/tests/testthat/test-geom-.R @@ -7,7 +7,6 @@ test_that("aesthetic checking in geom throws correct errors", { }) test_that("get_geom_defaults can use various sources", { - test <- get_geom_defaults(geom_point) expect_equal(test$colour, "black") @@ -46,7 +45,6 @@ test_that("geom defaults can be set and reset", { }) test_that("updating geom aesthetic defaults preserves class and order", { - original_defaults <- GeomPoint$default_aes update_geom_defaults("point", aes(color = "red")) @@ -61,14 +59,10 @@ test_that("updating geom aesthetic defaults preserves class and order", { expect_equal(updated_defaults, intended_defaults) update_geom_defaults("point", NULL) - }) - - test_that("updating stat aesthetic defaults preserves class and order", { - original_defaults <- StatBin$default_aes update_stat_defaults("bin", aes(y = after_stat(density))) @@ -79,10 +73,12 @@ test_that("updating stat aesthetic defaults preserves class and order", { intended_defaults <- original_defaults intended_defaults[["y"]] <- expr(after_stat(density)) - attr(intended_defaults[["y"]], ".Environment") <- attr(updated_defaults[["y"]], ".Environment") + attr(intended_defaults[["y"]], ".Environment") <- attr( + updated_defaults[["y"]], + ".Environment" + ) expect_equal(updated_defaults, intended_defaults) update_stat_defaults("bin", NULL) - }) diff --git a/tests/testthat/test-geom-bar.R b/tests/testthat/test-geom-bar.R index 4fb34ef4e6..a634b7ef52 100644 --- a/tests/testthat/test-geom-bar.R +++ b/tests/testthat/test-geom-bar.R @@ -24,11 +24,13 @@ test_that("geom_bar works in both directions", { }) test_that("geom_bar default widths considers panels", { + dat <- data_frame0( + x = c(1:2, 1:2 + 0.1), + y = 1, + PANEL = factor(rep(1:2, each = 2)) + ) - dat <- data_frame0(x = c(1:2, 1:2 + 0.1), y = 1, - PANEL = factor(rep(1:2, each = 2))) - - layer <- geom_bar() + layer <- geom_bar() params <- layer$geom_params # Default should be panel-wise resolution (0.9), not data-wise resolution (0.1) diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index 9d977501ff..225e0552b6 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -1,7 +1,7 @@ # thanks wch for providing the test code test_that("geom_boxplot range includes all outliers", { - dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) - p <- ggplot_build(ggplot(dat, aes(x,y)) + geom_boxplot()) + dat <- data_frame(x = 1, y = c(-(1:20)^3, (1:20)^3)) + p <- ggplot_build(ggplot(dat, aes(x, y)) + geom_boxplot()) miny <- p@layout$panel_params[[1]]$y.range[1] maxy <- p@layout$panel_params[[1]]$y.range[2] @@ -20,7 +20,7 @@ test_that("geom_boxplot range includes all outliers", { }) test_that("geom_boxplot works in both directions", { - dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) + dat <- data_frame(x = 1, y = c(-(1:20)^3, (1:20)^3)) p <- ggplot(dat, aes(x, y)) + geom_boxplot() x <- get_layer_data(p) @@ -36,7 +36,7 @@ test_that("geom_boxplot works in both directions", { }) test_that("geom_boxplot for continuous x gives warning if more than one x (#992)", { - dat <- expand.grid(x = 1:2, y = c(-(1:5) ^ 3, (1:5) ^ 3) ) + dat <- expand.grid(x = 1:2, y = c(-(1:5)^3, (1:5)^3)) bplot <- function(aes = NULL, extra = list()) { ggplot_build(ggplot(dat, aes) + geom_boxplot(aes) + extra) @@ -90,11 +90,15 @@ test_that("boxplots with a group size >1 error", { # Visual tests ------------------------------------------------------------ test_that("boxplot draws correctly", { - expect_doppelganger("outlier colours", - ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + geom_boxplot(outlier.size = 5) + expect_doppelganger( + "outlier colours", + ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + + geom_boxplot(outlier.size = 5) ) - expect_doppelganger("staples", - ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + geom_boxplot(staplewidth = 0.5) + expect_doppelganger( + "staples", + ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + + geom_boxplot(staplewidth = 0.5) ) expect_doppelganger( "customised style", @@ -103,7 +107,7 @@ test_that("boxplot draws correctly", { outlier.shape = 6, whisker.linetype = 2, median.colour = "red", - box.colour = "black", + box.colour = "black", staple.linewidth = 1, staplewidth = 0.25 ) diff --git a/tests/testthat/test-geom-col.R b/tests/testthat/test-geom-col.R index 32840fbd9e..5e27c6264e 100644 --- a/tests/testthat/test-geom-col.R +++ b/tests/testthat/test-geom-col.R @@ -21,7 +21,7 @@ test_that("geom_col works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) }) test_that("geom_col supports alignment of columns", { diff --git a/tests/testthat/test-geom-curve.R b/tests/testthat/test-geom-curve.R index 05f959916e..4ad6c4c1b1 100644 --- a/tests/testthat/test-geom-curve.R +++ b/tests/testthat/test-geom-curve.R @@ -1,5 +1,4 @@ test_that("geom_curve flipping works", { - df <- data.frame(x = c(1, 2), xend = c(2, 3), y = 1, yend = c(2, 1.5)) p <- ggplot(df, aes(x, y, xend = xend, yend = yend)) + @@ -7,5 +6,4 @@ test_that("geom_curve flipping works", { expect_doppelganger("standard geom_curve", p) expect_doppelganger("flipped geom_curve", p + scale_y_reverse()) - }) diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index fa43204e67..106d7ac291 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -1,7 +1,11 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped set.seed(111) -dat <- data_frame(x = rep(LETTERS[1:2], 15), y = rnorm(30), g = rep(LETTERS[3:5], 10)) +dat <- data_frame( + x = rep(LETTERS[1:2], 15), + y = rnorm(30), + g = rep(LETTERS[3:5], 10) +) test_that("dodging works", { p <- ggplot(dat, aes(x = x, y = y, fill = g)) + @@ -30,8 +34,8 @@ test_that("dodging works", { expect_true(all(abs(df$x - (xbase + xoffset)) < 1e-6)) # Check that xmin and xmax are in the right place - expect_true(all(abs(df$xmax - df$x - dwidth/2) < 1e-6)) - expect_true(all(abs(df$x - df$xmin - dwidth/2) < 1e-6)) + expect_true(all(abs(df$xmax - df$x - dwidth / 2) < 1e-6)) + expect_true(all(abs(df$x - df$xmin - dwidth / 2) < 1e-6)) }) test_that("binning works", { @@ -55,32 +59,36 @@ test_that("binning works", { test_that("NA's result in warning from stat_bindot", { set.seed(122) dat <- data_frame(x = rnorm(20)) - dat$x[c(2,10)] <- NA + dat$x[c(2, 10)] <- NA # Need to assign it to a var here so that it doesn't automatically print - expect_snapshot_warning(ggplot_build(ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.2))) + expect_snapshot_warning(ggplot_build( + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.2) + )) }) test_that("when binning on y-axis, limits depend on the panel", { - p <- ggplot(mtcars, aes(factor(cyl), mpg)) + - geom_dotplot(binaxis='y', binwidth = 1/30 * diff(range(mtcars$mpg))) + p <- ggplot(mtcars, aes(factor(cyl), mpg)) + + geom_dotplot(binaxis = 'y', binwidth = 1 / 30 * diff(range(mtcars$mpg))) - b1 <- ggplot_build(p + facet_wrap(~am)) - b2 <- ggplot_build(p + facet_wrap(~am, scales = "free_y")) + b1 <- ggplot_build(p + facet_wrap(~am)) + b2 <- ggplot_build(p + facet_wrap(~am, scales = "free_y")) - equal_limits1 <- (b1@layout$panel_params[[1]]$y.range == b1@layout$panel_params[[2]]$y.range) - equal_limits2 <- (b2@layout$panel_params[[1]]$y.range == b2@layout$panel_params[[2]]$y.range) + equal_limits1 <- (b1@layout$panel_params[[1]]$y.range == + b1@layout$panel_params[[2]]$y.range) + equal_limits2 <- (b2@layout$panel_params[[1]]$y.range == + b2@layout$panel_params[[2]]$y.range) - expect_true(all(equal_limits1)) - expect_false(all(equal_limits2)) + expect_true(all(equal_limits1)) + expect_false(all(equal_limits2)) }) test_that("weight aesthetic is checked", { - p <- ggplot(mtcars, aes(x = mpg, weight = gear/3)) + - geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) + p <- ggplot(mtcars, aes(x = mpg, weight = gear / 3)) + + geom_dotplot(binwidth = 1 / 30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) p <- ggplot(mtcars, aes(x = mpg, weight = -gear)) + - geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) + geom_dotplot(binwidth = 1 / 30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) }) @@ -91,100 +99,183 @@ test_that("geom_dotplot draws correctly", { dat <- data_frame(x = rnorm(20), g = rep(LETTERS[1:2], 10)) # Basic dotplot with binning along x axis - expect_doppelganger("basic dotplot with dot-density binning, binwidth = .4", + expect_doppelganger( + "basic dotplot with dot-density binning, binwidth = .4", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4) ) - expect_doppelganger("histodot binning (equal bin spacing)", + expect_doppelganger( + "histodot binning (equal bin spacing)", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, method = "histodot") ) - expect_doppelganger("dots stacked closer: stackratio=.5, fill=white", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackratio = 0.5, fill = "white") + expect_doppelganger( + "dots stacked closer: stackratio=.5, fill=white", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, stackratio = 0.5, fill = "white") ) - expect_doppelganger("larger dots: dotsize=1.5, fill=white", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, dotsize = 1.4, fill = "white") + expect_doppelganger( + "larger dots: dotsize=1.5, fill=white", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, dotsize = 1.4, fill = "white") ) # Stacking methods - expect_doppelganger("stack up", + expect_doppelganger( + "stack up", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "up") ) - expect_doppelganger("stack down", + expect_doppelganger( + "stack down", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "down") ) - expect_doppelganger("stack center", + expect_doppelganger( + "stack center", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "center") ) - expect_doppelganger("stack centerwhole", + expect_doppelganger( + "stack centerwhole", ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "centerwhole") ) # Stacking methods with coord_flip - expect_doppelganger("stack up with coord_flip", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "up") + coord_flip() + expect_doppelganger( + "stack up with coord_flip", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, stackdir = "up") + + coord_flip() ) - expect_doppelganger("stack down with coord_flip", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "down") + coord_flip() + expect_doppelganger( + "stack down with coord_flip", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, stackdir = "down") + + coord_flip() ) - expect_doppelganger("stack center with coord_flip", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "center") + coord_flip() + expect_doppelganger( + "stack center with coord_flip", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, stackdir = "center") + + coord_flip() ) - expect_doppelganger("stack centerwhole with coord_flip", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "centerwhole") + coord_flip() + expect_doppelganger( + "stack centerwhole with coord_flip", + ggplot(dat, aes(x)) + + geom_dotplot(binwidth = 0.4, stackdir = "centerwhole") + + coord_flip() ) # Binning along x, with groups - expect_doppelganger("multiple groups, bins not aligned", + expect_doppelganger( + "multiple groups, bins not aligned", ggplot(dat, aes(x, fill = g)) + geom_dotplot(binwidth = 0.4, alpha = 0.4) ) - expect_doppelganger("multiple groups, bins aligned", - ggplot(dat, aes(x, fill = g)) + geom_dotplot(binwidth = 0.4, alpha = 0.4, binpositions = "all") + expect_doppelganger( + "multiple groups, bins aligned", + ggplot(dat, aes(x, fill = g)) + + geom_dotplot(binwidth = 0.4, alpha = 0.4, binpositions = "all") ) # Binning along y axis - expect_doppelganger("bin along y, stack center", - ggplot(dat, aes(0, x)) + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "center") + expect_doppelganger( + "bin along y, stack center", + ggplot(dat, aes(0, x)) + + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "center") ) - expect_doppelganger("bin along y, stack centerwhole", - ggplot(dat, aes(0, x)) + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "centerwhole") + expect_doppelganger( + "bin along y, stack centerwhole", + ggplot(dat, aes(0, x)) + + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "centerwhole") ) - expect_doppelganger("bin along y, stack centerwhole, histodot", - ggplot(dat, aes(0, x)) + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "centerwhole", method = "histodot") + expect_doppelganger( + "bin along y, stack centerwhole, histodot", + ggplot(dat, aes(0, x)) + + geom_dotplot( + binwidth = 0.4, + binaxis = "y", + stackdir = "centerwhole", + method = "histodot" + ) ) # Binning along y, with multiple grouping factors - dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(LETTERS[1:2]), 45)) + dat2 <- data_frame( + x = rep(factor(LETTERS[1:3]), 30), + y = rnorm(90), + g = rep(factor(LETTERS[1:2]), 45) + ) - expect_doppelganger("bin x, three y groups, stack centerwhole", - ggplot(dat2, aes(y, x)) + geom_dotplot(binwidth = 0.25, binaxis = "x", stackdir = "centerwhole") + expect_doppelganger( + "bin x, three y groups, stack centerwhole", + ggplot(dat2, aes(y, x)) + + geom_dotplot(binwidth = 0.25, binaxis = "x", stackdir = "centerwhole") ) - expect_doppelganger("bin y, three x groups, stack centerwhole", - ggplot(dat2, aes(x, y)) + geom_dotplot(binwidth = 0.25, binaxis = "y", stackdir = "centerwhole") + expect_doppelganger( + "bin y, three x groups, stack centerwhole", + ggplot(dat2, aes(x, y)) + + geom_dotplot(binwidth = 0.25, binaxis = "y", stackdir = "centerwhole") ) - expect_doppelganger("bin y, three x groups, bins aligned across groups", - ggplot(dat2, aes(x, y)) + geom_dotplot(binwidth = 0.25, binaxis = "y", stackdir = "center", binpositions = "all") + expect_doppelganger( + "bin y, three x groups, bins aligned across groups", + ggplot(dat2, aes(x, y)) + + geom_dotplot( + binwidth = 0.25, + binaxis = "y", + stackdir = "center", + binpositions = "all" + ) ) - expect_doppelganger("bin y, three x groups, bins aligned, coord_flip", - ggplot(dat2, aes(x, y)) + geom_dotplot(binwidth = 0.25, binaxis = "y", stackdir = "center", binpositions = "all") + + expect_doppelganger( + "bin y, three x groups, bins aligned, coord_flip", + ggplot(dat2, aes(x, y)) + + geom_dotplot( + binwidth = 0.25, + binaxis = "y", + stackdir = "center", + binpositions = "all" + ) + coord_flip() ) - expect_doppelganger("bin y, dodged", - ggplot(dat2, aes("foo", y, fill = x)) + scale_y_continuous(breaks = seq(-4, 4, 0.4)) + - geom_dotplot(binwidth = 0.25, position = "dodge", binaxis = "y", stackdir = "center") + expect_doppelganger( + "bin y, dodged", + ggplot(dat2, aes("foo", y, fill = x)) + + scale_y_continuous(breaks = seq(-4, 4, 0.4)) + + geom_dotplot( + binwidth = 0.25, + position = "dodge", + binaxis = "y", + stackdir = "center" + ) ) - expect_doppelganger("bin y, dodged, coord_flip", - ggplot(dat2, aes("foo", y, fill = x)) + scale_y_continuous(breaks = seq(-4, 4, 0.4)) + - geom_dotplot(binwidth = 0.25, position = "dodge", binaxis = "y", stackdir = "center") + + expect_doppelganger( + "bin y, dodged, coord_flip", + ggplot(dat2, aes("foo", y, fill = x)) + + scale_y_continuous(breaks = seq(-4, 4, 0.4)) + + geom_dotplot( + binwidth = 0.25, + position = "dodge", + binaxis = "y", + stackdir = "center" + ) + coord_flip() ) - expect_doppelganger("bin y, three x groups, fill and dodge", - ggplot(dat2, aes(x, y, fill = g)) + scale_y_continuous(breaks = seq(-4 ,4, 0.4)) + - geom_dotplot(binwidth = 0.2, position = "dodge", binaxis = "y", stackdir = "center") + expect_doppelganger( + "bin y, three x groups, fill and dodge", + ggplot(dat2, aes(x, y, fill = g)) + + scale_y_continuous(breaks = seq(-4, 4, 0.4)) + + geom_dotplot( + binwidth = 0.2, + position = "dodge", + binaxis = "y", + stackdir = "center" + ) ) - expect_doppelganger("bin y, continous x-axis, grouping by x", - ggplot(dat2, aes(as.numeric(x), y, group = x)) + geom_dotplot(binwidth = 0.2, binaxis = "y", stackdir = "center") + expect_doppelganger( + "bin y, continous x-axis, grouping by x", + ggplot(dat2, aes(as.numeric(x), y, group = x)) + + geom_dotplot(binwidth = 0.2, binaxis = "y", stackdir = "center") ) - expect_doppelganger("bin y, continous x-axis, single x group", - ggplot(dat2, aes(as.numeric(x), y)) + geom_dotplot(binwidth = 0.2, binaxis = "y", stackdir = "center") + expect_doppelganger( + "bin y, continous x-axis, single x group", + ggplot(dat2, aes(as.numeric(x), y)) + + geom_dotplot(binwidth = 0.2, binaxis = "y", stackdir = "center") ) # border width and size @@ -199,30 +290,68 @@ test_that("geom_dotplot draws correctly", { ) ) + geom_dotplot(binwidth = 0.4, fill = "red", col = "blue") + - continuous_scale("stroke", palette = function(x) scales::rescale(x, to = c(1, 6))) + + continuous_scale("stroke", palette = function(x) { + scales::rescale(x, to = c(1, 6)) + }) + guides(linetype = guide_legend(order = 1)) ) # Stacking groups - expect_doppelganger("3 stackgroups, dot-density with aligned bins", - ggplot(dat2, aes(y, fill = x)) + geom_dotplot(binwidth = 0.25, stackgroups = TRUE, binpositions = "all", alpha = 0.5) + expect_doppelganger( + "3 stackgroups, dot-density with aligned bins", + ggplot(dat2, aes(y, fill = x)) + + geom_dotplot( + binwidth = 0.25, + stackgroups = TRUE, + binpositions = "all", + alpha = 0.5 + ) ) - expect_doppelganger("3 stackgroups, histodot", - ggplot(dat2, aes(y, fill = x)) + geom_dotplot(binwidth = 0.25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + expect_doppelganger( + "3 stackgroups, histodot", + ggplot(dat2, aes(y, fill = x)) + + geom_dotplot( + binwidth = 0.25, + stackgroups = TRUE, + method = "histodot", + alpha = 0.5 + ) ) - expect_doppelganger("3 stackgroups, bin y, histodot", - ggplot(dat2, aes(1, y, fill = x)) + geom_dotplot(binaxis = "y", binwidth = 0.25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + expect_doppelganger( + "3 stackgroups, bin y, histodot", + ggplot(dat2, aes(1, y, fill = x)) + + geom_dotplot( + binaxis = "y", + binwidth = 0.25, + stackgroups = TRUE, + method = "histodot", + alpha = 0.5 + ) ) # This one is currently broken but it would be a really rare case, and it # probably requires a really ugly hack to fix - expect_doppelganger("bin y, dodging, 3 stackgroups, histodot", + expect_doppelganger( + "bin y, dodging, 3 stackgroups, histodot", ggplot(dat2, aes(x, y, fill = g)) + - geom_dotplot(binaxis = "y", binwidth = 0.25, stackgroups = TRUE, method = "histodot", - alpha = 0.5, stackdir = "centerwhole") + geom_dotplot( + binaxis = "y", + binwidth = 0.25, + stackgroups = TRUE, + method = "histodot", + alpha = 0.5, + stackdir = "centerwhole" + ) ) - expect_doppelganger("facets, 3 groups, histodot, stackgroups", - ggplot(dat2, aes(y, fill = g)) + geom_dotplot(binwidth = 0.25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + + expect_doppelganger( + "facets, 3 groups, histodot, stackgroups", + ggplot(dat2, aes(y, fill = g)) + + geom_dotplot( + binwidth = 0.25, + stackgroups = TRUE, + method = "histodot", + alpha = 0.5 + ) + facet_grid(x ~ .) ) @@ -236,19 +365,45 @@ test_that("geom_dotplot draws correctly", { )) expect_snapshot_warning(expect_doppelganger( "2 NA values, bin along y, stack center", - ggplot(dat2, aes(0, x)) + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "center") + ggplot(dat2, aes(0, x)) + + geom_dotplot(binwidth = 0.4, binaxis = "y", stackdir = "center") )) }) test_that("stackratio != 1 works", { df <- data.frame(x = c(rep(1, 3), rep(2, 2))) - expect_doppelganger("stackratio = 1.5", + expect_doppelganger( + "stackratio = 1.5", ggplot(df) + geom_hline(yintercept = 0) + - geom_dotplot(aes(x), binwidth = 0.5, stackdir = "down", stackratio = 1.5, fill = NA) + - geom_dotplot(aes(x + 3), binwidth = 0.5, stackdir = "up", stackratio = 1.5, fill = NA) + - geom_dotplot(aes(x + 6), binwidth = 0.5, stackdir = "center", stackratio = 1.5, fill = NA) + - geom_dotplot(aes(x + 9), binwidth = 0.5, stackdir = "centerwhole", stackratio = 1.5, fill = NA) + geom_dotplot( + aes(x), + binwidth = 0.5, + stackdir = "down", + stackratio = 1.5, + fill = NA + ) + + geom_dotplot( + aes(x + 3), + binwidth = 0.5, + stackdir = "up", + stackratio = 1.5, + fill = NA + ) + + geom_dotplot( + aes(x + 6), + binwidth = 0.5, + stackdir = "center", + stackratio = 1.5, + fill = NA + ) + + geom_dotplot( + aes(x + 9), + binwidth = 0.5, + stackdir = "centerwhole", + stackratio = 1.5, + fill = NA + ) ) }) diff --git a/tests/testthat/test-geom-errorbar.R b/tests/testthat/test-geom-errorbar.R index bdfdf3f88d..5aa998f60b 100644 --- a/tests/testthat/test-geom-errorbar.R +++ b/tests/testthat/test-geom-errorbar.R @@ -1,5 +1,4 @@ test_that("geom_errorbarh throws deprecation messages", { - lifecycle::expect_deprecated(geom_errorbarh()) p <- ggplot( diff --git a/tests/testthat/test-geom-hex.R b/tests/testthat/test-geom-hex.R index 498f00d407..bb74f826dc 100644 --- a/tests/testthat/test-geom-hex.R +++ b/tests/testthat/test-geom-hex.R @@ -22,7 +22,8 @@ test_that("size and linetype are applied", { }) test_that("bin size are picked up from stat", { - expect_doppelganger("single hex bin with width and height of 0.1", + expect_doppelganger( + "single hex bin with width and height of 0.1", ggplot(data.frame(x = 0, y = 0)) + geom_hex(aes(x = x, y = y), binwidth = c(0.1, 0.1)) + coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) @@ -32,10 +33,9 @@ test_that("bin size are picked up from stat", { test_that("geom_hex works in non-linear coordinate systems", { p <- ggplot(mpg, aes(displ, hwy)) + geom_hex() - expect_doppelganger("hex bin plot with sqrt-transformed y", + expect_doppelganger( + "hex bin plot with sqrt-transformed y", p + coord_transform(y = "sqrt") ) - expect_doppelganger("hex bin plot in polar coordinates", - p + coord_polar() - ) + expect_doppelganger("hex bin plot in polar coordinates", p + coord_polar()) }) diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-hline-vline-abline.R index 8a324dcf4c..7ee633a1b1 100644 --- a/tests/testthat/test-geom-hline-vline-abline.R +++ b/tests/testthat/test-geom-hline-vline-abline.R @@ -1,4 +1,3 @@ - # Visual tests ------------------------------------------------------------ test_that("check h/v/abline transformed on basic projections", { @@ -35,16 +34,15 @@ test_that("curved lines in map projections", { geom_hline(yintercept = -38.6) + # roughly Taupo geom_vline(xintercept = 176) - expect_doppelganger("straight lines in mercator", - nzmap + coord_map() - ) - expect_doppelganger("lines curved in azequalarea", - nzmap + coord_map(projection = 'azequalarea', orientation = c(-36.92, 174.6, 0)) + expect_doppelganger("straight lines in mercator", nzmap + coord_map()) + expect_doppelganger( + "lines curved in azequalarea", + nzmap + + coord_map(projection = 'azequalarea', orientation = c(-36.92, 174.6, 0)) ) }) test_that("geom_abline is clipped to x/y ranges", { - df <- data.frame(slope = c(-0.2, -1, -5, 5, 1, 0.2)) p <- ggplot(df) + diff --git a/tests/testthat/test-geom-label.R b/tests/testthat/test-geom-label.R index ec94fe7c4b..f053a7bd52 100644 --- a/tests/testthat/test-geom-label.R +++ b/tests/testthat/test-geom-label.R @@ -17,7 +17,8 @@ test_that("geom_label() rotates labels", { vps <- lapply( get_layer_grob(p, 1)[[1]]$children, - `[[`, "vp" + `[[`, + "vp" ) angle_out <- unname(vapply(vps, `[[`, numeric(1), "angle")) expect_equal(angle_in, angle_out) diff --git a/tests/testthat/test-geom-path.R b/tests/testthat/test-geom-path.R index 161508459a..b87821b741 100644 --- a/tests/testthat/test-geom-path.R +++ b/tests/testthat/test-geom-path.R @@ -1,17 +1,27 @@ test_that("keep_mid_true drops leading/trailing FALSE", { expect_equal(keep_mid_true(c(FALSE, FALSE)), c(FALSE, FALSE)) - expect_equal(keep_mid_true(c(FALSE, TRUE, FALSE, TRUE, FALSE)), c(FALSE, TRUE, TRUE, TRUE, FALSE)) - expect_equal(keep_mid_true(c(TRUE, TRUE, FALSE, TRUE, FALSE)), c(TRUE, TRUE, TRUE, TRUE, FALSE)) - expect_equal(keep_mid_true(c(FALSE, TRUE, FALSE, TRUE, TRUE)), c(FALSE, TRUE, TRUE, TRUE, TRUE)) + expect_equal( + keep_mid_true(c(FALSE, TRUE, FALSE, TRUE, FALSE)), + c(FALSE, TRUE, TRUE, TRUE, FALSE) + ) + expect_equal( + keep_mid_true(c(TRUE, TRUE, FALSE, TRUE, FALSE)), + c(TRUE, TRUE, TRUE, TRUE, FALSE) + ) + expect_equal( + keep_mid_true(c(FALSE, TRUE, FALSE, TRUE, TRUE)), + c(FALSE, TRUE, TRUE, TRUE, TRUE) + ) }) test_that("geom_path() throws meaningful error on bad combination of varying aesthetics", { - p <- ggplot(economics, aes(unemploy/pop, psavert, colour = pop)) + geom_path(linetype = 2) + p <- ggplot(economics, aes(unemploy / pop, psavert, colour = pop)) + + geom_path(linetype = 2) expect_snapshot_error(ggplotGrob(p)) }) test_that("repair_segment_arrow() repairs sensibly", { - group <- c(1,1,1,1,2,2) + group <- c(1, 1, 1, 1, 2, 2) ans <- repair_segment_arrow(arrow(ends = "last"), group) expect_equal(ans$ends, rep(2L, 4)) @@ -40,21 +50,30 @@ test_that("stairstep() exists with error when an invalid `direction` is given", test_that("stairstep() output is correct for direction = 'vh'", { df <- data_frame(x = 1:3, y = 1:3) - stepped_expected <- data_frame(x = c(1L, 1L, 2L, 2L, 3L), y = c(1L, 2L, 2L, 3L, 3L)) + stepped_expected <- data_frame( + x = c(1L, 1L, 2L, 2L, 3L), + y = c(1L, 2L, 2L, 3L, 3L) + ) stepped <- stairstep(df, direction = "vh") expect_equal(stepped, stepped_expected) }) test_that("stairstep() output is correct for direction = 'hv'", { df <- data_frame(x = 1:3, y = 1:3) - stepped_expected <- data_frame(x = c(1L, 2L, 2L, 3L, 3L), y = c(1L, 1L, 2L, 2L, 3L)) + stepped_expected <- data_frame( + x = c(1L, 2L, 2L, 3L, 3L), + y = c(1L, 1L, 2L, 2L, 3L) + ) stepped <- stairstep(df, direction = "hv") expect_equal(stepped, stepped_expected) }) test_that("stairstep() output is correct for direction = 'mid'", { df <- data_frame(x = 1:3, y = 1:3) - stepped_expected <- data_frame(x = c(1, 1.5, 1.5, 2.5, 2.5, 3), y = c(1L, 1L, 2L, 2L, 3L, 3L)) + stepped_expected <- data_frame( + x = c(1, 1.5, 1.5, 2.5, 2.5, 3), + y = c(1L, 1L, 2L, 2L, 3L, 3L) + ) stepped <- stairstep(df, direction = "mid") expect_equal(stepped, stepped_expected) }) @@ -67,23 +86,31 @@ test_that("geom_path draws correctly", { nCategory <- 5 nItem <- 6 - df <- data_frame(category = rep(LETTERS[1:nCategory], 1, each = nItem), - item = paste("Item#", rep(1:nItem, nCategory, each = 1), sep = ''), - value = rep(1:nItem, nCategory, each = 1) + runif(nCategory * nItem) * 0.8) + df <- data_frame( + category = rep(LETTERS[1:nCategory], 1, each = nItem), + item = paste("Item#", rep(1:nItem, nCategory, each = 1), sep = ''), + value = rep(1:nItem, nCategory, each = 1) + runif(nCategory * nItem) * 0.8 + ) df2 <- df[c(1, 2, 7, 8, 13, 14, 3:6, 9:12, 15:nrow(df)), ] - expect_doppelganger("lines", + expect_doppelganger( + "lines", ggplot(df) + geom_path(aes(x = value, y = category, group = item)) ) - expect_doppelganger("lines, changed order, should have same appearance", + expect_doppelganger( + "lines, changed order, should have same appearance", ggplot(df2) + geom_path(aes(x = value, y = category, group = item)) ) - expect_doppelganger("lines, colour", - ggplot(df) + geom_path(aes(x = value, y = category, group = item, colour = item)) + expect_doppelganger( + "lines, colour", + ggplot(df) + + geom_path(aes(x = value, y = category, group = item, colour = item)) ) - expect_doppelganger("lines, colour, changed order, should have same appearance", - ggplot(df2) + geom_path(aes(x = value, y = category, group = item, colour = item)) + expect_doppelganger( + "lines, colour, changed order, should have same appearance", + ggplot(df2) + + geom_path(aes(x = value, y = category, group = item, colour = item)) ) }) @@ -91,7 +118,7 @@ test_that("NA linetype is dropped with warning", { df <- data_frame(x = 1:2, y = 1:2, z = "a") expect_snapshot_warning(expect_doppelganger( - "NA linetype", - ggplot(df, aes(x, y)) + geom_path(linetype = NA) + "NA linetype", + ggplot(df, aes(x, y)) + geom_path(linetype = NA) )) }) diff --git a/tests/testthat/test-geom-polygon.R b/tests/testthat/test-geom-polygon.R index eec237f588..8d5a3d6a1e 100644 --- a/tests/testthat/test-geom-polygon.R +++ b/tests/testthat/test-geom-polygon.R @@ -1,19 +1,35 @@ - # Visual tests ------------------------------------------------------------ skip_if(utils::packageVersion('grid') < "3.6") test_that("geom_polygon draws correctly", { - tbl <- data_frame( x = c( - 0, 10, 10, 0, - 20, 30, 30, 20, - 22, 28, 28, 22 + 0, + 10, + 10, + 0, + 20, + 30, + 30, + 20, + 22, + 28, + 28, + 22 ), y = c( - 0, 0, 10, 10, - 20, 20, 30, 30, - 22, 22, 28, 28 + 0, + 0, + 10, + 10, + 20, + 20, + 30, + 30, + 22, + 22, + 28, + 28 ), group = c(rep(1, 4), rep(2, 8)), subgroup = c(rep(1, 8), rep(2, 4)) @@ -26,7 +42,6 @@ test_that("geom_polygon draws correctly", { }) test_that("geom_polygon is closed before munching", { - df <- data_frame0( x = c(1, 1, 4, 4, 2, 2, 3, 3), y = c(1, 4, 4, 1, 2, 3, 3, 2), @@ -41,11 +56,11 @@ test_that("geom_polygon is closed before munching", { built <- ggplot_build(p) coord <- built@plot@coordinates - data <- built@data[[1]] + data <- built@data[[1]] param <- built@layout$panel_params[[1]] closed <- coord_munch(coord, data, param, is_closed = TRUE) - open <- coord_munch(coord, data, param, is_closed = FALSE) + open <- coord_munch(coord, data, param, is_closed = FALSE) p <- ggplot(mapping = aes(x = x, y = y, group = subgroup)) + geom_polygon(aes(colour = "closed"), data = closed, fill = NA) + diff --git a/tests/testthat/test-geom-quantile.R b/tests/testthat/test-geom-quantile.R index 7b6feecb9b..056f787ffd 100644 --- a/tests/testthat/test-geom-quantile.R +++ b/tests/testthat/test-geom-quantile.R @@ -18,10 +18,7 @@ test_that("geom_quantile matches quantile regression", { quants <- c(0.25, 0.5, 0.75) pred_rq <- predict( - quantreg::rq(y ~ x, - tau = quants, - data = df - ), + quantreg::rq(y ~ x, tau = quants, data = df), data_frame( x = seq(min(x), max(x), length.out = 100) ) diff --git a/tests/testthat/test-geom-raster.R b/tests/testthat/test-geom-raster.R index 4ce3ad2a7d..1ca66a0c89 100644 --- a/tests/testthat/test-geom-raster.R +++ b/tests/testthat/test-geom-raster.R @@ -24,52 +24,74 @@ test_that("geom_raster draws correctly", { # 3 x 2 ---------------------------------------------------------------------- df <- data_frame(x = rep(c(-1, 1), each = 3), y = rep(-1:1, 2), z = 1:6) - expect_doppelganger("3 x 2", + expect_doppelganger( + "3 x 2", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") ) - expect_doppelganger("3 x 2, set limits", - ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") + - xlim(-2, 2) + ylim(-2, 2) + expect_doppelganger( + "3 x 2, set limits", + ggplot(df, aes(x, y, fill = z)) + + geom_raster() + + geom_point(colour = "red") + + xlim(-2, 2) + + ylim(-2, 2) ) - expect_doppelganger("3 x 2, just = (0, 0)", - ggplot(df, aes(x, y, fill = z)) + geom_raster(hjust = 0, vjust = 0) + + expect_doppelganger( + "3 x 2, just = (0, 0)", + ggplot(df, aes(x, y, fill = z)) + + geom_raster(hjust = 0, vjust = 0) + geom_point(colour = "red") ) # 1 x 3 ---------------------------------------------------------------------- df <- data_frame(x = -1:1, y = 0, z = 1:3) - expect_doppelganger("1 x 3", + expect_doppelganger( + "1 x 3", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") ) - expect_doppelganger("1 x 3, set limits", - ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") + - xlim(-2, 2) + ylim(-2, 2) + expect_doppelganger( + "1 x 3, set limits", + ggplot(df, aes(x, y, fill = z)) + + geom_raster() + + geom_point(colour = "red") + + xlim(-2, 2) + + ylim(-2, 2) ) - expect_doppelganger("1 x 3, just = (0, 0)", - ggplot(df, aes(x, y, fill = z)) + geom_raster(hjust = 0, vjust = 0) + + expect_doppelganger( + "1 x 3, just = (0, 0)", + ggplot(df, aes(x, y, fill = z)) + + geom_raster(hjust = 0, vjust = 0) + geom_point(colour = "red") ) # 3 x 1 ---------------------------------------------------------------------- df <- data_frame(x = 0, y = -1:1, z = 1:3) - expect_doppelganger("3 x 1", + expect_doppelganger( + "3 x 1", ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") ) - expect_doppelganger("3 x 1, set limits", - ggplot(df, aes(x, y, fill = z)) + geom_raster() + geom_point(colour = "red") + - xlim(-2, 2) + ylim(-2, 2) + expect_doppelganger( + "3 x 1, set limits", + ggplot(df, aes(x, y, fill = z)) + + geom_raster() + + geom_point(colour = "red") + + xlim(-2, 2) + + ylim(-2, 2) ) - expect_doppelganger("3 x 1, just = (0, 0)", - ggplot(df, aes(x, y, fill = z)) + geom_raster(hjust = 0, vjust = 0) + + expect_doppelganger( + "3 x 1, just = (0, 0)", + ggplot(df, aes(x, y, fill = z)) + + geom_raster(hjust = 0, vjust = 0) + geom_point(colour = "red") ) # In non-linear coordinates df <- data.frame(x = c(1, 2, 1, 2), y = c(1, 1, 2, 2), fill = LETTERS[1:4]) suppressMessages( - expect_doppelganger("rectangle fallback", + expect_doppelganger( + "rectangle fallback", ggplot(df, aes(x, y, fill = fill)) + geom_raster() + coord_polar() ) ) @@ -80,14 +102,16 @@ test_that("geom_raster draws correctly", { df$col <- (df$x + df$y) %% 2 df$col[df$x == 5 & df$col == 1] <- NA df$col[df$y == 5 & df$col == 0] <- NA - expect_doppelganger("irregular categorical", + expect_doppelganger( + "irregular categorical", ggplot(df, aes(x, y, fill = factor(col))) + geom_raster() ) # Categorical axes ----------------------------------------------------------- df <- expand.grid(x = c("A", "B"), y = c("C", "D")) - expect_doppelganger("discrete positions", + expect_doppelganger( + "discrete positions", ggplot(df, aes(x, y, fill = interaction(x, y))) + geom_raster() ) }) diff --git a/tests/testthat/test-geom-rect.R b/tests/testthat/test-geom-rect.R index 204df65ef2..1cbe1261bb 100644 --- a/tests/testthat/test-geom-rect.R +++ b/tests/testthat/test-geom-rect.R @@ -1,11 +1,14 @@ test_that("geom_rect can derive corners", { - corners <- c("xmin", "xmax", "ymin", "ymax") full <- data.frame( - xmin = c(1, 2), xmax = c(3, 6), - ymin = c(1, 2), ymax = c(3, 6), - width = c(2, 4), height = c(2, 4), - x = c(2, 4), y = c(2, 4) + xmin = c(1, 2), + xmax = c(3, 6), + ymin = c(1, 2), + ymax = c(3, 6), + width = c(2, 4), + height = c(2, 4), + x = c(2, 4), + y = c(2, 4) ) test <- full[, c("xmin", "ymin", "width", "height")] diff --git a/tests/testthat/test-geom-ribbon.R b/tests/testthat/test-geom-ribbon.R index 6bd08875f1..288c06d525 100644 --- a/tests/testthat/test-geom-ribbon.R +++ b/tests/testthat/test-geom-ribbon.R @@ -1,22 +1,31 @@ test_that("geom_ribbon() checks the aesthetics", { huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron)) p <- ggplot(huron) + - geom_ribbon(aes(year, ymin = level - 5, ymax = level + 5), orientation = "y") + geom_ribbon( + aes(year, ymin = level - 5, ymax = level + 5), + orientation = "y" + ) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(huron) + - geom_ribbon(aes(y = year, xmin = level - 5, xmax = level + 5), orientation = "x") + geom_ribbon( + aes(y = year, xmin = level - 5, xmax = level + 5), + orientation = "x" + ) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(huron) + geom_ribbon(aes(year, ymin = level - 5, ymax = level + 5, linewidth = year)) expect_snapshot_error(ggplotGrob(p)) - expect_snapshot_error(geom_ribbon(aes(year, ymin = level - 5, ymax = level + 5), outline.type = "test")) + expect_snapshot_error(geom_ribbon( + aes(year, ymin = level - 5, ymax = level + 5), + outline.type = "test" + )) }) test_that("NAs are dropped from the data", { df <- data_frame(x = 1:5, y = c(1, 1, NA, 1, 1)) - p <- ggplot(df, aes(x))+ + p <- ggplot(df, aes(x)) + geom_ribbon(aes(ymin = y - 1, ymax = y + 1)) p <- ggplot_build(p) @@ -29,9 +38,11 @@ test_that("NAs are dropped from the data", { }) test_that("geom_ribbon works in both directions", { - dat <- data_frame(x = seq_len(5), - ymin = c(1, 2, 1.5, 1.8, 1), - ymax = c(4, 6, 5, 4.5, 5.2)) + dat <- data_frame( + x = seq_len(5), + ymin = c(1, 2, 1.5, 1.8, 1), + ymax = c(4, 6, 5, 4.5, 5.2) + ) p <- ggplot(dat, aes(x, ymin = ymin, ymax = ymax)) + geom_ribbon() x <- get_layer_data(p) @@ -43,7 +54,7 @@ test_that("geom_ribbon works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) }) test_that("outline.type option works", { @@ -52,15 +63,20 @@ test_that("outline.type option works", { p <- ggplot(df, aes(x, ymin = -y, ymax = y)) g_ribbon_default <- get_layer_grob(p + geom_ribbon())[[1]] - g_ribbon_upper <- get_layer_grob(p + geom_ribbon(outline.type = "upper"))[[1]] - g_ribbon_lower <- get_layer_grob(p + geom_ribbon(outline.type = "lower"))[[1]] - g_ribbon_full <- get_layer_grob(p + geom_ribbon(outline.type = "full"))[[1]] - g_area_default <- get_layer_grob(ggplot(df, aes(x, y)) + geom_area(stat = "identity"))[[1]] + g_ribbon_upper <- get_layer_grob(p + geom_ribbon(outline.type = "upper"))[[1]] + g_ribbon_lower <- get_layer_grob(p + geom_ribbon(outline.type = "lower"))[[1]] + g_ribbon_full <- get_layer_grob(p + geom_ribbon(outline.type = "full"))[[1]] + g_area_default <- get_layer_grob( + ggplot(df, aes(x, y)) + geom_area(stat = "identity") + )[[1]] # default expect_s3_class(g_ribbon_default$children[[1]]$children[[1]], "polygon") expect_s3_class(g_ribbon_default$children[[1]]$children[[2]], "polyline") - expect_equal(g_ribbon_default$children[[1]]$children[[2]]$id, rep(c(1L, 2L), each = 4)) + expect_equal( + g_ribbon_default$children[[1]]$children[[2]]$id, + rep(c(1L, 2L), each = 4) + ) # upper expect_s3_class(g_ribbon_upper$children[[1]]$children[[1]], "polygon") diff --git a/tests/testthat/test-geom-rug.R b/tests/testthat/test-geom-rug.R index 108d030ca0..dc18419ac9 100644 --- a/tests/testthat/test-geom-rug.R +++ b/tests/testthat/test-geom-rug.R @@ -20,7 +20,7 @@ test_that("coord_flip flips the rugs", { }) test_that("Rug length needs unit object", { - p <- ggplot(df, aes(x,y)) + p <- ggplot(df, aes(x, y)) expect_snapshot_error(print(p + geom_rug(length = 0.01))) }) @@ -31,26 +31,24 @@ test_that("Rug lengths are correct", { expect_equal(a[[1]]$children[[1]]$x0, unit(0, "npc")) expect_equal(a[[1]]$children[[1]]$x1, unit(0.03, "npc")) - p <- ggplot(df, aes(x, y)) + geom_point() + geom_rug(sides = 'l', length = unit(12, "pt")) + p <- ggplot(df, aes(x, y)) + + geom_point() + + geom_rug(sides = 'l', length = unit(12, "pt")) b <- get_layer_grob(p, 2) # Check default length is changed expect_equal(a[[1]]$children[[1]]$x0, unit(0, "npc")) expect_equal(b[[1]]$children[[1]]$x1, unit(12, "pt")) - }) -test_that( - "geom_rug() warns about missing values when na.rm = FALSE", - { - df2 <- df - n_missing <- 2 - df2$x[sample(nrow(df2), size = n_missing)] <- NA +test_that("geom_rug() warns about missing values when na.rm = FALSE", { + df2 <- df + n_missing <- 2 + df2$x[sample(nrow(df2), size = n_missing)] <- NA - p1 <- ggplot(df2, aes(x = x)) + geom_rug() - p2 <- ggplot(df2, aes(x = x)) + geom_rug(na.rm = TRUE) + p1 <- ggplot(df2, aes(x = x)) + geom_rug() + p2 <- ggplot(df2, aes(x = x)) + geom_rug(na.rm = TRUE) - expect_snapshot_warning(ggplotGrob(p1)) - expect_no_warning(ggplotGrob(p2)) - } -) + expect_snapshot_warning(ggplotGrob(p1)) + expect_no_warning(ggplotGrob(p2)) +}) diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index 6503cf7678..590370904a 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -1,63 +1,95 @@ test_that("geom_sf() determines the legend type automatically", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } mp <- sf::st_sf( - geometry = sf::st_sfc(sf::st_multipoint(rbind(c(1,1), c(2,2), c(3,3)))), - v = "a") + geometry = sf::st_sfc(sf::st_multipoint(rbind(c(1, 1), c(2, 2), c(3, 3)))), + v = "a" + ) - s1 <- rbind(c(0,3),c(0,4),c(1,5),c(2,5)) - s2 <- rbind(c(0.2,3), c(0.2,4), c(1,4.8), c(2,4.8)) - s3 <- rbind(c(0,4.4), c(0.6,5)) + s1 <- rbind(c(0, 3), c(0, 4), c(1, 5), c(2, 5)) + s2 <- rbind(c(0.2, 3), c(0.2, 4), c(1, 4.8), c(2, 4.8)) + s3 <- rbind(c(0, 4.4), c(0.6, 5)) mls <- sf::st_sf( - geometry = sf::st_sfc(sf::st_multilinestring(list(s1,s2,s3))), - v = "a") + geometry = sf::st_sfc(sf::st_multilinestring(list(s1, s2, s3))), + v = "a" + ) - p1 <- rbind(c(0,0), c(1,0), c(3,2), c(2,4), c(1,4), c(0,0)) - p2 <- rbind(c(1,1), c(1,2), c(2,2), c(1,1)) - p3 <- rbind(c(3,0), c(4,0), c(4,1), c(3,1), c(3,0)) - p4 <- rbind(c(3.3,0.3), c(3.8,0.3), c(3.8,0.8), c(3.3,0.8), c(3.3,0.3))[5:1,] - p5 <- rbind(c(3,3), c(4,2), c(4,3), c(3,3)) + p1 <- rbind(c(0, 0), c(1, 0), c(3, 2), c(2, 4), c(1, 4), c(0, 0)) + p2 <- rbind(c(1, 1), c(1, 2), c(2, 2), c(1, 1)) + p3 <- rbind(c(3, 0), c(4, 0), c(4, 1), c(3, 1), c(3, 0)) + p4 <- rbind(c(3.3, 0.3), c(3.8, 0.3), c(3.8, 0.8), c(3.3, 0.8), c(3.3, 0.3))[ + 5:1, + ] + p5 <- rbind(c(3, 3), c(4, 2), c(4, 3), c(3, 3)) mpol <- sf::st_sf( - geometry = sf::st_sfc(sf::st_multipolygon(list(list(p1,p2), list(p3,p4), list(p5)))), - v = "a") + geometry = sf::st_sfc(sf::st_multipolygon(list( + list(p1, p2), + list(p3, p4), + list(p5) + ))), + v = "a" + ) fun_geom_sf <- function(sf, show.legend) { - p <- ggplot() + geom_sf(aes(colour = v), data = sf, show.legend = show.legend) + p <- ggplot() + + geom_sf(aes(colour = v), data = sf, show.legend = show.legend) ggplot_build(p) } # test the automatic choice expect_true(fun_geom_sf(mp, TRUE)@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "point") + expect_identical( + fun_geom_sf(mp, TRUE)@plot@layers[[1]]$computed_geom_params$legend, + "point" + ) expect_true(fun_geom_sf(mls, TRUE)@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "line") + expect_identical( + fun_geom_sf(mls, TRUE)@plot@layers[[1]]$computed_geom_params$legend, + "line" + ) expect_true(fun_geom_sf(mpol, TRUE)@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "other") + expect_identical( + fun_geom_sf(mpol, TRUE)@plot@layers[[1]]$computed_geom_params$legend, + "other" + ) # test that automatic choice can be overridden manually expect_true(fun_geom_sf(mp, "point")@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") + expect_identical( + fun_geom_sf(mp, "point")@plot@layers[[1]]$computed_geom_params$legend, + "point" + ) expect_true(fun_geom_sf(mls, "point")@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") + expect_identical( + fun_geom_sf(mls, "point")@plot@layers[[1]]$computed_geom_params$legend, + "point" + ) expect_true(fun_geom_sf(mpol, "point")@plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") + expect_identical( + fun_geom_sf(mpol, "point")@plot@layers[[1]]$computed_geom_params$legend, + "point" + ) }) test_that("geom_sf() determines the legend type from mapped geometry column", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } - p1 <- rbind(c(1,1), c(2,2), c(3,3)) - s1 <- rbind(c(0,3), c(0,4), c(1,5), c(2,5)) - s2 <- rbind(c(0.2,3), c(0.2,4), c(1,4.8), c(2,4.8)) - s3 <- rbind(c(0,4.4), c(0.6,5)) + p1 <- rbind(c(1, 1), c(2, 2), c(3, 3)) + s1 <- rbind(c(0, 3), c(0, 4), c(1, 5), c(2, 5)) + s2 <- rbind(c(0.2, 3), c(0.2, 4), c(1, 4.8), c(2, 4.8)) + s3 <- rbind(c(0, 4.4), c(0.6, 5)) d_sf <- sf::st_sf( g_point = sf::st_sfc(sf::st_multipoint(p1)), @@ -78,7 +110,9 @@ test_that("geom_sf() determines the legend type from mapped geometry column", { test_that("geom_sf() removes rows containing missing aes", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } grob_xy_length <- function(x) { g <- get_layer_grob(x)[[1]] @@ -101,14 +135,20 @@ test_that("geom_sf() removes rows containing missing aes", { ) # default colour scale maps a colour even to a NA, so identity scale is needed to see if NA is removed expect_snapshot_warning( - expect_identical(grob_xy_length(p + geom_sf(aes(colour = colour)) + scale_colour_identity()), - c(1L, 1L)) + expect_identical( + grob_xy_length( + p + geom_sf(aes(colour = colour)) + scale_colour_identity() + ), + c(1L, 1L) + ) ) }) test_that("geom_sf() handles alpha properly", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } sfc <- sf::st_sfc( sf::st_point(0:1), @@ -155,11 +195,27 @@ test_that("errors are correctly triggered", { test_that("geom_sf draws correctly", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } nc_tiny_coords <- matrix( - c(-81.473, -81.741, -81.67, -81.345, -81.266, -81.24, -81.473, - 36.234, 36.392, 36.59, 36.573, 36.437, 36.365, 36.234), + c( + -81.473, + -81.741, + -81.67, + -81.345, + -81.266, + -81.24, + -81.473, + 36.234, + 36.392, + 36.59, + 36.573, + 36.437, + 36.365, + 36.234 + ), ncol = 2 ) @@ -170,20 +226,24 @@ test_that("geom_sf draws correctly", { ) ) - # Perform minimal tests - pts <- sf::st_sf(a = 1:2, geometry = sf::st_sfc(sf::st_point(0:1), sf::st_point(1:2))) + pts <- sf::st_sf( + a = 1:2, + geometry = sf::st_sfc(sf::st_point(0:1), sf::st_point(1:2)) + ) plot <- ggplot() + geom_sf(data = pts) expect_no_error(ggplot_build(plot)) - expect_doppelganger("North Carolina county boundaries", + expect_doppelganger( + "North Carolina county boundaries", ggplot() + geom_sf(data = nc, linetype = 2) + coord_sf(datum = 4326) ) - pts <- sf::st_sf(a = 1:2, geometry = sf::st_sfc(sf::st_point(0:1), sf::st_point(1:2))) - expect_doppelganger("spatial points", - ggplot() + geom_sf(data = pts) + pts <- sf::st_sf( + a = 1:2, + geometry = sf::st_sfc(sf::st_point(0:1), sf::st_point(1:2)) ) + expect_doppelganger("spatial points", ggplot() + geom_sf(data = pts)) }) test_that("geom_sf data type renders appropriate legends", { @@ -230,7 +290,7 @@ test_that("geom_sf data type renders appropriate legends", { test_that("geom_sf uses combinations of geometry correctly", { skip_if_not_installed("sf") - t <- seq(0, 2 *pi, length.out = 10) + t <- seq(0, 2 * pi, length.out = 10) data <- sf::st_sf(sf::st_sfc( sf::st_multipoint(cbind(1:2, 3:4)), sf::st_multilinestring(list( @@ -241,10 +301,12 @@ test_that("geom_sf uses combinations of geometry correctly", { cbind(cos(t), zapsmall(sin(t))), cbind(cos(t), zapsmall(sin(t))) + 5 )), - sf::st_geometrycollection(x = list( - sf::st_point(x = c(3, 2)), - sf::st_linestring(cbind(c(2, 4, 4), c(1, 1, 3))) - )), + sf::st_geometrycollection( + x = list( + sf::st_point(x = c(3, 2)), + sf::st_linestring(cbind(c(2, 4, 4), c(1, 1, 3))) + ) + ), sf::st_linestring(x = cbind(c(2, 6), c(-1, 3))), sf::st_point(c(5, 0)) )) @@ -255,7 +317,7 @@ test_that("geom_sf uses combinations of geometry correctly", { withr::defer({ update_geom_defaults("point", NULL) - update_geom_defaults("line", NULL) + update_geom_defaults("line", NULL) }) expect_doppelganger( @@ -266,11 +328,27 @@ test_that("geom_sf uses combinations of geometry correctly", { test_that("geom_sf_text() and geom_sf_label() draws correctly", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } nc_tiny_coords <- matrix( - c(-81.473, -81.741, -81.67, -81.345, -81.266, -81.24, -81.473, - 36.234, 36.392, 36.59, 36.573, 36.437, 36.365, 36.234), + c( + -81.473, + -81.741, + -81.67, + -81.345, + -81.266, + -81.24, + -81.473, + 36.234, + 36.392, + 36.59, + 36.573, + 36.437, + 36.365, + 36.234 + ), ncol = 2 ) @@ -284,18 +362,22 @@ test_that("geom_sf_text() and geom_sf_label() draws correctly", { # In order to avoid warning, transform to a projected coordinate system nc_3857 <- sf::st_transform(nc, 3857) - expect_doppelganger("Texts for North Carolina", + expect_doppelganger( + "Texts for North Carolina", ggplot() + geom_sf_text(data = nc_3857, aes(label = NAME)) ) - expect_doppelganger("Labels for North Carolina", + expect_doppelganger( + "Labels for North Carolina", ggplot() + geom_sf_label(data = nc_3857, aes(label = NAME)) ) }) test_that("geom_sf draws arrows correctly", { skip_if_not_installed("sf") - if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") + if (packageVersion("sf") < "0.5.3") { + skip("Need sf 0.5.3") + } nc_tiny_coords <- data_frame( x = c(-81.473, -81.741, -81.67, -81.345, -81.266, -81.24, -81.473), @@ -303,27 +385,35 @@ test_that("geom_sf draws arrows correctly", { ) nc <- sf::st_linestring( - sf::st_coordinates(sf::st_as_sf(nc_tiny_coords, coords = c("x", "y"), crs = 4326)) - ) + sf::st_coordinates(sf::st_as_sf( + nc_tiny_coords, + coords = c("x", "y"), + crs = 4326 + )) + ) nc2 <- sf::st_cast( sf::st_sfc( sf::st_multilinestring(lapply( 1:(length(sf::st_coordinates(nc)[, 1]) - 1), - function(x) rbind( + function(x) { + rbind( as.numeric(sf::st_coordinates(nc)[x, 1:2]), as.numeric(sf::st_coordinates(nc)[x + 1, 1:2]) - ) - ) - ) - ), "LINESTRING" + ) + } + )) + ), + "LINESTRING" ) - expect_doppelganger("North Carolina county boundaries with arrow", + expect_doppelganger( + "North Carolina county boundaries with arrow", ggplot() + geom_sf(data = nc, arrow = arrow()) + coord_sf(datum = 4326) ) - expect_doppelganger("North Carolina county boundaries with more than one arrow", + expect_doppelganger( + "North Carolina county boundaries with more than one arrow", ggplot() + geom_sf(data = nc2, arrow = arrow()) + coord_sf(datum = 4326) ) }) diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index 270bf3760f..3eb07fd829 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -1,10 +1,14 @@ test_that("data is ordered by x", { df <- data_frame(x = c(1, 5, 2, 3, 4), y = 1:5) - ps <- ggplot(df, aes(x, y))+ + ps <- ggplot(df, aes(x, y)) + geom_smooth(stat = "identity", se = FALSE) - expect_equal(get_layer_data(ps)[c("x", "y")], df[order(df$x), ], ignore_attr = TRUE) + expect_equal( + get_layer_data(ps)[c("x", "y")], + df[order(df$x), ], + ignore_attr = TRUE + ) }) test_that("geom_smooth works in both directions", { @@ -20,7 +24,7 @@ test_that("geom_smooth works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) }) test_that("default smoothing methods for small and large data sets work", { @@ -104,7 +108,8 @@ test_that("a fallback message is thrown when `method = 'gam'` and {mgcv} is abse with_mocked_bindings( expect_message( - ggplot_build(p), regexp = "Falling back to `method = \"lm\"`" + ggplot_build(p), + regexp = "Falling back to `method = \"lm\"`" ), is_installed = function(...) FALSE ) @@ -113,9 +118,11 @@ test_that("a fallback message is thrown when `method = 'gam'` and {mgcv} is abse # Visual tests ------------------------------------------------------------ test_that("geom_smooth() works with alternative stats", { - df <- data_frame(x = c(1, 1, 2, 2, 1, 1, 2, 2), - y = c(1, 2, 2, 3, 2, 3, 1, 2), - fill = c(rep("A", 4), rep("B", 4))) + df <- data_frame( + x = c(1, 1, 2, 2, 1, 1, 2, 2), + y = c(1, 2, 2, 3, 2, 3, 1, 2), + fill = c(rep("A", 4), rep("B", 4)) + ) expect_doppelganger("ribbon turned on in geom_smooth", { ggplot(df, aes(x, y, color = fill, fill = fill)) + diff --git a/tests/testthat/test-geom-text.R b/tests/testthat/test-geom-text.R index 8fe509e724..60ed2d4599 100644 --- a/tests/testthat/test-geom-text.R +++ b/tests/testthat/test-geom-text.R @@ -3,7 +3,6 @@ test_that("geom_text() checks input", { }) test_that("geom_text() drops missing angles", { - df <- data_frame0(x = 1, y = 1, label = "A", angle = 0) geom <- geom_text() @@ -58,67 +57,82 @@ test_that("outward moves text away from center", { test_that("inward points close to center are centered", { expect_equal( - compute_just(c("inward", "inward", "inward"), c(0.5 - 1e-3, 0.5, 0.5 + 1e-3)), + compute_just( + c("inward", "inward", "inward"), + c(0.5 - 1e-3, 0.5, 0.5 + 1e-3) + ), c(0.5, 0.5, 0.5) ) }) test_that("inward moves text towards center at 90 degrees", { expect_equal( - compute_just(c("inward", "inward", "inward"), - c(0, 0.5, 1), - c(0, 0.5, 1), - c(90, 90, 90)), + compute_just( + c("inward", "inward", "inward"), + c(0, 0.5, 1), + c(0, 0.5, 1), + c(90, 90, 90) + ), c(0, 0.5, 1.0) ) }) test_that("outward moves text away from center at 90 degrees", { expect_equal( - compute_just(c("outward", "outward", "outward"), - c(0, 0, 0), - c(0, 0.5, 1), - c(90, 90, 90)), + compute_just( + c("outward", "outward", "outward"), + c(0, 0, 0), + c(0, 0.5, 1), + c(90, 90, 90) + ), c(1.0, 0.5, 0) ) }) test_that("only inward and outward respond to angle", { expect_equal( - compute_just(c("inward", "left", "outward"), - c(0, 0, 0), - c(0, 0.5, 1), - c(90, 90, 90)), + compute_just( + c("inward", "left", "outward"), + c(0, 0, 0), + c(0, 0.5, 1), + c(90, 90, 90) + ), c(0.0, 0.0, 0.0) ) }) test_that("inward moves text towards center at 150 degrees", { expect_equal( - compute_just(c("inward", "inward", "inward"), - c(0, 0.5, 1), - c(0, 0.5, 1), - c(150, 150, 150)), + compute_just( + c("inward", "inward", "inward"), + c(0, 0.5, 1), + c(0, 0.5, 1), + c(150, 150, 150) + ), c(1.0, 0.5, 0.0) ) }) test_that("inward moves text towards center at -90 degrees", { expect_equal( - compute_just(c("inward", "inward", "inward"), - c(0, 0.5, 1), - c(0, 0.5, 1), - c(-90, -90, -90)), + compute_just( + c("inward", "inward", "inward"), + c(0, 0.5, 1), + c(0, 0.5, 1), + c(-90, -90, -90) + ), c(1.0, 0.5, 0.0) ) }) test_that("outward moves text away from center at 450 degrees", { expect_equal( - compute_just(c("inward", "inward", "inward"), - c(0, 0, 0), - c(0, 0.5, 1), - c(450, 450, 450)), + compute_just( + c("inward", "inward", "inward"), + c(0, 0, 0), + c(0, 0.5, 1), + c(450, 450, 450) + ), c(0.0, 0.5, 1.0) ) }) diff --git a/tests/testthat/test-geom-tile.R b/tests/testthat/test-geom-tile.R index 9034e3c9f7..a454489872 100644 --- a/tests/testthat/test-geom-tile.R +++ b/tests/testthat/test-geom-tile.R @@ -5,7 +5,9 @@ test_that("accepts width and height params", { expect_equal(out1$xmin, new_mapped_discrete(c(0.5, 1.5))) expect_equal(out1$xmax, new_mapped_discrete(c(1.5, 2.5))) - out2 <- get_layer_data(ggplot(df, aes(x, y)) + geom_tile(width = 0.5, height = 0.5)) + out2 <- get_layer_data( + ggplot(df, aes(x, y)) + geom_tile(width = 0.5, height = 0.5) + ) expect_equal(out2$xmin, new_mapped_discrete(c(0.75, 1.75))) expect_equal(out2$xmax, new_mapped_discrete(c(1.25, 2.25))) }) @@ -18,8 +20,10 @@ test_that("accepts width and height aesthetics", { out <- get_layer_data(p) boundary <- data_frame0( - xmin = c(-1, -2), xmax = c(1, 2), - ymin = c(-1, -2), ymax = c(1, 2) + xmin = c(-1, -2), + xmax = c(1, 2), + ymin = c(-1, -2), + ymax = c(1, 2) ) expect_equal(out[c("xmin", "xmax", "ymin", "ymax")], boundary) }) @@ -30,7 +34,9 @@ test_that("accepts linejoin parameter", { gp1 <- get_layer_grob(ggplot(df, aes(x, y)) + geom_tile())[[1]]$gp expect_equal(gp1$linejoin, "mitre") - gp2 <- get_layer_grob(ggplot(df, aes(x, y)) + geom_tile(linejoin = "round"))[[1]]$gp + gp2 <- get_layer_grob(ggplot(df, aes(x, y)) + geom_tile(linejoin = "round"))[[ + 1 + ]]$gp expect_equal(gp2$linejoin, "round") }) diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index ff3cae8de8..f3d85ac836 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -10,8 +10,14 @@ test_that("range is expanded", { coord_cartesian(expand = FALSE) expand_a <- stats::bw.nrd0(df$y[df$x == "a"]) * 3 expand_b <- stats::bw.nrd0(df$y[df$x == "b"]) * 3 - expect_equal(get_panel_scales(p, 1)$y$dimension(), c(0 - expand_a, 1 + expand_a)) - expect_equal(get_panel_scales(p, 2)$y$dimension(), c(0 - expand_b, 2 + expand_b)) + expect_equal( + get_panel_scales(p, 1)$y$dimension(), + c(0 - expand_a, 1 + expand_a) + ) + expect_equal( + get_panel_scales(p, 2)$y$dimension(), + c(0 - expand_b, 2 + expand_b) + ) }) test_that("geom_violin works in both directions", { @@ -25,21 +31,23 @@ test_that("geom_violin works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) }) # create_quantile_segment_frame ------------------------------------------------- test_that("create_quantile_segment_frame functions for 3 quantiles", { - density.data <- data_frame(y = (1:256)/256, density = 1/256) # uniform density + density.data <- data_frame(y = (1:256) / 256, density = 1 / 256) # uniform density qs <- c(0.25, 0.5, 0.75) # 3 quantiles - expect_equal(create_quantile_segment_frame(density.data, qs)$y, - rep(qs, each = 2)) + expect_equal( + create_quantile_segment_frame(density.data, qs)$y, + rep(qs, each = 2) + ) }) test_that("quantiles do not fail on zero-range data", { - zero.range.data <- data_frame(y = rep(1,3)) + zero.range.data <- data_frame(y = rep(1, 3)) p <- ggplot(zero.range.data) + geom_violin(aes(1, y), quantiles = 0.5, quantile.linetype = NULL) @@ -82,43 +90,56 @@ test_that("quantiles do not issue warning", { test_that("geom_violin draws correctly", { set.seed(111) dat <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90)) - dat <- dat[dat$x != "C" | c(TRUE, FALSE),] # Keep half the C's + dat <- dat[dat$x != "C" | c(TRUE, FALSE), ] # Keep half the C's - expect_doppelganger("basic", - ggplot(dat, aes(x = x, y = y)) + geom_violin() - ) - expect_doppelganger("scale area to sample size (C is smaller)", + expect_doppelganger("basic", ggplot(dat, aes(x = x, y = y)) + geom_violin()) + expect_doppelganger( + "scale area to sample size (C is smaller)", ggplot(dat, aes(x = x, y = y)) + geom_violin(scale = "count"), ) - expect_doppelganger("narrower (width=.5)", + expect_doppelganger( + "narrower (width=.5)", ggplot(dat, aes(x = x, y = y)) + geom_violin(width = 0.5) ) - expect_doppelganger("with tails and points", - ggplot(dat, aes(x = x, y = y)) + geom_violin(trim = FALSE) + geom_point(shape = 21) + expect_doppelganger( + "with tails and points", + ggplot(dat, aes(x = x, y = y)) + + geom_violin(trim = FALSE) + + geom_point(shape = 21) ) - expect_doppelganger("with smaller bandwidth and points", - ggplot(dat, aes(x = x, y = y)) + geom_violin(adjust = 0.3) + geom_point(shape = 21) + expect_doppelganger( + "with smaller bandwidth and points", + ggplot(dat, aes(x = x, y = y)) + + geom_violin(adjust = 0.3) + + geom_point(shape = 21) ) - expect_doppelganger("dodging", + expect_doppelganger( + "dodging", ggplot(dat, aes(x = "foo", y = y, fill = x)) + geom_violin() ) - expect_doppelganger("coord_polar", + expect_doppelganger( + "coord_polar", ggplot(dat, aes(x = x, y = y)) + geom_violin() + coord_polar() ) - expect_doppelganger("coord_flip", + expect_doppelganger( + "coord_flip", ggplot(dat, aes(x = x, y = y)) + geom_violin() + coord_flip() ) - expect_doppelganger("dodging and coord_flip", + expect_doppelganger( + "dodging and coord_flip", ggplot(dat, aes(x = "foo", y = y, fill = x)) + geom_violin() + coord_flip() ) - expect_doppelganger("continuous x axis, many groups (center should be at 2.0)", + expect_doppelganger( + "continuous x axis, many groups (center should be at 2.0)", ggplot(dat, aes(x = as.numeric(x), y = y)) + geom_violin() ) - expect_doppelganger("continuous x axis, single group (center should be at 1.0)", + expect_doppelganger( + "continuous x axis, single group (center should be at 1.0)", ggplot(dat, aes(x = as.numeric(1), y = y)) + geom_violin() ) - expect_doppelganger("styled quantiles", - ggplot(dat, aes(x=x, y=y)) + + expect_doppelganger( + "styled quantiles", + ggplot(dat, aes(x = x, y = y)) + geom_violin( quantile.colour = "red", quantile.linetype = "dotted", @@ -126,11 +147,17 @@ test_that("geom_violin draws correctly", { ) ) - dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(letters[5:6]), 45)) - expect_doppelganger("grouping on x and fill", + dat2 <- data_frame( + x = rep(factor(LETTERS[1:3]), 30), + y = rnorm(90), + g = rep(factor(letters[5:6]), 45) + ) + expect_doppelganger( + "grouping on x and fill", ggplot(dat2, aes(x = x, y = y, fill = g)) + geom_violin() ) - expect_doppelganger("grouping on x and fill, dodge width = 0.5", + expect_doppelganger( + "grouping on x and fill, dodge width = 0.5", ggplot(dat2, aes(x = x, y = y, fill = g)) + geom_violin(position = position_dodge(width = 0.5)) ) diff --git a/tests/testthat/test-ggproto.R b/tests/testthat/test-ggproto.R index baad887619..b27d27b259 100644 --- a/tests/testthat/test-ggproto.R +++ b/tests/testthat/test-ggproto.R @@ -12,7 +12,6 @@ test_that("construction checks input", { }) test_that("all ggproto methods start with `{` (#6459)", { - ggprotos <- Filter( function(x) inherits(x, "ggproto"), mget(ls("package:ggplot2"), asNamespace("ggplot2"), ifnotfound = list(NULL)) @@ -45,7 +44,9 @@ test_that("all ggproto methods start with `{` (#6459)", { # Test to make sure we're testing correctly ctrl <- list( foo = ggproto("Dummy", dummy = function(x) x + 10), - bar = ggproto("Dummy", dummy = function(x) {x + 10}) + bar = ggproto("Dummy", dummy = function(x) { + x + 10 + }) ) ctrl <- lapply(ctrl, report_no_bracket) expect_equal(ctrl, list(foo = "dummy", bar = character())) diff --git a/tests/testthat/test-ggsave.R b/tests/testthat/test-ggsave.R index af254f9f84..a1b0d6dddf 100644 --- a/tests/testthat/test-ggsave.R +++ b/tests/testthat/test-ggsave.R @@ -17,7 +17,8 @@ test_that("ggsave can create directories", { p <- ggplot(mpg, aes(displ, hwy)) + geom_point() expect_snapshot( - ggsave(path, p), error = TRUE, + ggsave(path, p), + error = TRUE, transform = function(x) gsub("directory '.*'\\.$", "directory 'PATH'", x) ) expect_false(dir.exists(dirname(path))) @@ -98,7 +99,8 @@ test_that("ggsave warns about empty or multiple filenames", { test_that("ggsave fails informatively for no-extension filenames", { plot <- ggplot(mtcars, aes(disp, mpg)) + geom_point() expect_snapshot( - ggsave(tempfile(), plot), error = TRUE, + ggsave(tempfile(), plot), + error = TRUE, transform = function(x) gsub("to .*\\.$", "to PATH", x) ) }) @@ -139,7 +141,7 @@ test_that("unknown device triggers error", { test_that("text converted to function", { expect_identical(body(validate_device("png"))[[1]], quote(png_dev)) - expect_identical(body(validate_device("pdf"))[[1]], quote(grDevices::pdf)) + expect_identical(body(validate_device("pdf"))[[2]][[1]], quote(grDevices::pdf)) }) test_that("if device is NULL, guess from extension", { diff --git a/tests/testthat/test-guide-.R b/tests/testthat/test-guide-.R index e5f9c34bc6..914377fea3 100644 --- a/tests/testthat/test-guide-.R +++ b/tests/testthat/test-guide-.R @@ -1,16 +1,17 @@ skip_on_cran() test_that("plotting does not induce state changes in guides", { - guides <- guides( - x = guide_axis(title = "X-axis"), + x = guide_axis(title = "X-axis"), colour = guide_colourbar(title = "Colourbar"), - shape = guide_legend(title = "Legend"), - size = guide_bins(title = "Bins") + shape = guide_legend(title = "Legend"), + size = guide_bins(title = "Bins") ) - p <- ggplot(mpg, aes(displ, hwy, colour = cty, shape = factor(cyl), - size = cyl)) + + p <- ggplot( + mpg, + aes(displ, hwy, colour = cty, shape = factor(cyl), size = cyl) + ) + geom_point() + guides @@ -22,7 +23,6 @@ test_that("plotting does not induce state changes in guides", { }) test_that("adding guides doesn't change plot state", { - p1 <- ggplot(mtcars, aes(disp, mpg)) expect_length(p1@guides$guides, 0) diff --git a/tests/testthat/test-guide-axis.R b/tests/testthat/test-guide-axis.R index 836df8bb2d..1995bbab2e 100644 --- a/tests/testthat/test-guide-axis.R +++ b/tests/testthat/test-guide-axis.R @@ -53,7 +53,6 @@ test_that("Using non-position guides for position scales results in an informati }) test_that("guide_axis_logticks calculates appropriate ticks", { - test_scale <- function(transform = transform_identity(), limits = c(NA, NA)) { scale <- scale_x_continuous(transform = transform) scale$train(scale$transform(limits)) @@ -67,32 +66,35 @@ test_that("guide_axis_logticks calculates appropriate ticks", { } guide <- guide_axis_logticks(negative.small = 10) - outcome <- c((1:10)*10, (2:10)*100) + outcome <- c((1:10) * 10, (2:10) * 100) # Test the classic log10 transformation scale <- test_scale(transform_log10(), c(10, 1000)) key <- train_guide(guide, scale)$logkey expect_equal(sort(key$x), log10(outcome)) - expect_equal(key$.type, rep(c(1,2,3), c(3, 2, 14))) + expect_equal(key$.type, rep(c(1, 2, 3), c(3, 2, 14))) # Test compound transformation - scale <- test_scale(transform_compose(transform_log10(), transform_reverse()), c(10, 1000)) - key <- train_guide(guide, scale)$logkey + scale <- test_scale( + transform_compose(transform_log10(), transform_reverse()), + c(10, 1000) + ) + key <- train_guide(guide, scale)$logkey expect_equal(sort(key$x), -log10(rev(outcome))) # Test transformation with negatives scale <- test_scale(transform_pseudo_log(), c(-1000, 1000)) - key <- train_guide(guide, scale)$logkey + key <- train_guide(guide, scale)$logkey unlog <- sort(transform_pseudo_log()$inverse(key$x)) expect_equal(unlog, c(-rev(outcome), 0, outcome)) - expect_equal(key$.type, rep(c(1,2,3), c(7, 4, 28))) + expect_equal(key$.type, rep(c(1, 2, 3), c(7, 4, 28))) # Test very small pseudo_log (#6121) scale <- test_scale(transform_pseudo_log(sigma = 1e-5), c(0, 1e-10)) - key <- train_guide(guide_axis_logticks(), scale)$logkey + key <- train_guide(guide_axis_logticks(), scale)$logkey expect_gte(nrow(key), 1) # Test expanded argument @@ -100,12 +102,12 @@ test_that("guide_axis_logticks calculates appropriate ticks", { scale$continuous_range <- c(1, 3) guide <- guide_axis_logticks(expanded = TRUE) - key <- train_guide(guide, scale)$logkey + key <- train_guide(guide, scale)$logkey expect_equal(sort(key$x), log10(outcome)) guide <- guide_axis_logticks(expanded = FALSE) - key <- train_guide(guide, scale)$logkey + key <- train_guide(guide, scale)$logkey expect_equal(sort(key$x), log10(outcome[-c(1, length(outcome))])) @@ -124,19 +126,27 @@ test_that("guide_axis_logticks calculates appropriate ticks", { # Visual tests ------------------------------------------------------------ test_that("axis guides are drawn correctly", { - theme_test_axis <- theme_test() + theme(axis.line = element_line(linewidth = 0.5)) - test_draw_axis <- function(n_breaks = 3, - break_positions = seq_len(n_breaks) / (n_breaks + 1), - labels = as.character, - positions = c("top", "right", "bottom", "left"), - theme = theme_test_axis, - ...) { - + theme_test_axis <- theme_test() + + theme(axis.line = element_line(linewidth = 0.5)) + test_draw_axis <- function( + n_breaks = 3, + break_positions = seq_len(n_breaks) / (n_breaks + 1), + labels = as.character, + positions = c("top", "right", "bottom", "left"), + theme = theme_test_axis, + ... + ) { break_labels <- labels(seq_along(break_positions)) # create the axes axes <- lapply(positions, function(position) { - draw_axis(break_positions, break_labels, axis_position = position, theme = theme, ...) + draw_axis( + break_positions, + break_labels, + axis_position = position, + theme = theme, + ... + ) }) axes_grob <- gTree(children = do.call(gList, axes)) @@ -151,67 +161,90 @@ test_that("axis guides are drawn correctly", { # basic expect_doppelganger("axis guides basic", function() test_draw_axis()) - expect_doppelganger("axis guides, zero breaks", function() test_draw_axis(n_breaks = 0)) + expect_doppelganger("axis guides, zero breaks", function() { + test_draw_axis(n_breaks = 0) + }) # overlapping text expect_doppelganger( "axis guides, check overlap", - function() test_draw_axis(20, labels = function(b) comma(b * 1e9), check.overlap = TRUE) + function() { + test_draw_axis( + 20, + labels = function(b) comma(b * 1e9), + check.overlap = TRUE + ) + } ) # rotated text expect_doppelganger( "axis guides, zero rotation", - function() test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 0) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 0) + } ) expect_doppelganger( "axis guides, positive rotation", - function() test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 45) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 45) + } ) expect_doppelganger( "axis guides, negative rotation", - function() test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = -45) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = -45) + } ) expect_doppelganger( "axis guides, vertical rotation", - function() test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 90) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = 90) + } ) expect_doppelganger( "axis guides, vertical negative rotation", - function() test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = -90) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e3), angle = -90) + } ) # dodged text expect_doppelganger( "axis guides, text dodged into rows/cols", - function() test_draw_axis(10, labels = function(b) comma(b * 1e9), n.dodge = 2) + function() { + test_draw_axis(10, labels = function(b) comma(b * 1e9), n.dodge = 2) + } ) }) test_that("axis guides are drawn correctly in plots", { - expect_doppelganger("align facet labels, facets horizontal", - ggplot(mpg, aes(hwy, reorder(model, hwy))) + - geom_point() + - facet_grid(manufacturer ~ ., scales = "free", space = "free") + - theme_test() + - theme(strip.text.y = element_text(angle = 0)) + expect_doppelganger( + "align facet labels, facets horizontal", + ggplot(mpg, aes(hwy, reorder(model, hwy))) + + geom_point() + + facet_grid(manufacturer ~ ., scales = "free", space = "free") + + theme_test() + + theme(strip.text.y = element_text(angle = 0)) ) - expect_doppelganger("align facet labels, facets vertical", - ggplot(mpg, aes(reorder(model, hwy), hwy)) + - geom_point() + - facet_grid(. ~ manufacturer, scales = "free", space = "free") + - theme_test() + - theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) + expect_doppelganger( + "align facet labels, facets vertical", + ggplot(mpg, aes(reorder(model, hwy), hwy)) + + geom_point() + + facet_grid(. ~ manufacturer, scales = "free", space = "free") + + theme_test() + + theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) ) - expect_doppelganger("thick axis lines", - ggplot(mtcars, aes(wt, mpg)) + - geom_point() + - theme_test() + - theme(axis.line = element_line(linewidth = 5, lineend = "square")) + expect_doppelganger( + "thick axis lines", + ggplot(mtcars, aes(wt, mpg)) + + geom_point() + + theme_test() + + theme(axis.line = element_line(linewidth = 5, lineend = "square")) ) }) @@ -265,7 +298,10 @@ test_that("Axis titles won't be blown away by coord_*()", { y.sec = guide_axis(title = "y (secondary)") ) - expect_doppelganger("guide titles with coord_transform()", plot + coord_transform()) + expect_doppelganger( + "guide titles with coord_transform()", + plot + coord_transform() + ) # TODO # expect_doppelganger("guide titles with coord_polar()", plot + coord_polar()) # TODO @@ -275,14 +311,16 @@ test_that("Axis titles won't be blown away by coord_*()", { test_that("guide_axis() draws minor ticks correctly", { p <- ggplot(mtcars, aes(wt, disp)) + geom_point() + - theme(axis.ticks.length = unit(1, "cm"), - axis.ticks.x.bottom = element_line(linetype = 2), - axis.ticks.length.x.top = unit(-0.5, "cm"), - axis.minor.ticks.x.bottom = element_line(colour = "red"), - axis.minor.ticks.length.y.left = unit(-0.5, "cm"), - axis.minor.ticks.length.x.top = unit(-0.5, "cm"), - axis.minor.ticks.length.x.bottom = unit(0.75, "cm"), - axis.minor.ticks.length.y.right = unit(5, "cm")) + + theme( + axis.ticks.length = unit(1, "cm"), + axis.ticks.x.bottom = element_line(linetype = 2), + axis.ticks.length.x.top = unit(-0.5, "cm"), + axis.minor.ticks.x.bottom = element_line(colour = "red"), + axis.minor.ticks.length.y.left = unit(-0.5, "cm"), + axis.minor.ticks.length.x.top = unit(-0.5, "cm"), + axis.minor.ticks.length.x.bottom = unit(0.75, "cm"), + axis.minor.ticks.length.y.right = unit(5, "cm") + ) + scale_x_continuous(labels = label_math()) + guides( # Test for styling and style inheritance @@ -311,11 +349,10 @@ test_that("axis guides can be capped", { }) test_that("guide_axis_stack stacks axes", { - - left <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "left") - right <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "right") + left <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "left") + right <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "right") bottom <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "bottom") - top <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "top") + top <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "top") p <- ggplot(mtcars, aes(hp, disp)) + geom_point() + @@ -324,7 +361,7 @@ test_that("guide_axis_stack stacks axes", { expect_doppelganger("stacked axes", p) bottom <- guide_axis_stack("axis_theta", guide_axis_theta(cap = "both")) - top <- guide_axis_stack("axis_theta", guide_axis_theta(cap = "both")) + top <- guide_axis_stack("axis_theta", guide_axis_theta(cap = "both")) p <- ggplot(mtcars, aes(hp, disp)) + geom_point() + @@ -332,11 +369,9 @@ test_that("guide_axis_stack stacks axes", { coord_radial(start = 0.25 * pi, end = 1.75 * pi, inner.radius = 0.5) + guides(theta = top, theta.sec = bottom, r = left, r.sec = right) expect_doppelganger("stacked radial axes", p) - }) test_that("logticks look as they should", { - p <- ggplot(data.frame(x = c(-100, 100), y = c(10, 1000)), aes(x, y)) + geom_point() + scale_y_continuous( @@ -348,9 +383,11 @@ test_that("logticks look as they should", { ) + coord_transform(x = transform_pseudo_log()) + theme_test() + - theme(axis.line = element_line(colour = "black"), - panel.border = element_blank(), - axis.ticks.length.x.top = unit(-2.75, "pt")) + + theme( + axis.line = element_line(colour = "black"), + panel.border = element_blank(), + axis.ticks.length.x.top = unit(-2.75, "pt") + ) + guides( x = guide_axis_logticks( title = "Pseudo-logticks with 1 as smallest tick", @@ -358,14 +395,16 @@ test_that("logticks look as they should", { ), y = guide_axis_logticks( title = "Inverted logticks with swapped tick lengths", - long = 0.75, short = 2.25 + long = 0.75, + short = 2.25 ), x.sec = guide_axis_logticks( negative.small = 0.1, title = "Negative length pseudo-logticks with 0.1 as smallest tick" ), y.sec = guide_axis_logticks( - expanded = FALSE, cap = "both", + expanded = FALSE, + cap = "both", title = "Capped and not-expanded inverted logticks" ) ) @@ -373,7 +412,6 @@ test_that("logticks look as they should", { }) test_that("guide_axis_theta sets relative angle", { - p <- ggplot(mtcars, aes(disp, mpg)) + geom_point() + scale_x_continuous(breaks = breaks_width(25)) + @@ -395,16 +433,19 @@ test_that("guide_axis_theta with only one axis key", { }) test_that("guide_axis_theta can be used in cartesian coordinates", { - p <- ggplot(mtcars, aes(disp, mpg)) + geom_point() + - guides(x = "axis_theta", y = "axis_theta", - x.sec = "axis_theta", y.sec = "axis_theta") + + guides( + x = "axis_theta", + y = "axis_theta", + x.sec = "axis_theta", + y.sec = "axis_theta" + ) + theme( axis.line.x.bottom = element_line(colour = "tomato"), - axis.line.x.top = element_line(colour = "limegreen"), - axis.line.y.left = element_line(colour = "dodgerblue"), - axis.line.y.right = element_line(colour = "orchid") + axis.line.x.top = element_line(colour = "limegreen"), + axis.line.y.left = element_line(colour = "dodgerblue"), + axis.line.y.right = element_line(colour = "orchid") ) expect_doppelganger("guide_axis_theta in cartesian coordinates", p) diff --git a/tests/testthat/test-guide-colorbar.R b/tests/testthat/test-guide-colorbar.R index e9602a4c73..5a42c3668c 100644 --- a/tests/testthat/test-guide-colorbar.R +++ b/tests/testthat/test-guide-colorbar.R @@ -51,14 +51,12 @@ test_that("guide_colourbar merging preserves both aesthetics", { test_that("guide_colourbar warns about discrete scales", { - g <- guide_colourbar() s <- scale_colour_discrete() s$train(LETTERS[1:3]) expect_snapshot_warning(g <- g$train(g$params, s, "colour")) expect_null(g) - }) test_that("colorbar can be styled", { @@ -72,28 +70,37 @@ test_that("colorbar can be styled", { expect_doppelganger( "customized colorbar", - p + scale_color_gradient( - low = 'white', high = 'red', - guide = guide_colorbar( - theme = theme( - legend.frame = element_rect(colour = "green", linewidth = 1.5 / .pt), - legend.ticks = element_line("black", linewidth = 2.5 / .pt), - legend.ticks.length = unit(0.4, "npc") - ), alpha = 0.75 + p + + scale_color_gradient( + low = 'white', + high = 'red', + guide = guide_colorbar( + theme = theme( + legend.frame = element_rect( + colour = "green", + linewidth = 1.5 / .pt + ), + legend.ticks = element_line("black", linewidth = 2.5 / .pt), + legend.ticks.length = unit(0.4, "npc") + ), + alpha = 0.75 + ) + ) + + labs( + subtitle = "white-to-red semitransparent colorbar, long thick black ticks, green frame" ) - ) + labs(subtitle = "white-to-red semitransparent colorbar, long thick black ticks, green frame") ) }) test_that("guides can handle multiple aesthetics for one scale", { - df <- data_frame(x = c(1, 2, 3), - y = c(6, 5, 7)) + df <- data_frame(x = c(1, 2, 3), y = c(6, 5, 7)) p <- ggplot(df, aes(x, y, color = x, fill = y)) + geom_point(shape = 21, size = 3, stroke = 2) + scale_colour_viridis_c( name = "value", - option = "B", aesthetics = c("colour", "fill") + option = "B", + aesthetics = c("colour", "fill") ) expect_doppelganger("combined colour and fill aesthetics", p) diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index 2dd68fe01b..de003bcefb 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -4,10 +4,16 @@ test_that("show.legend handles named vectors", { n_legends <- function(p) { g <- ggplotGrob(p) gb <- grep("guide-box", g$layout$name) - n <- vapply(g$grobs[gb], function(x) { - if (is_zero(x)) return(0) - length(x$grobs) - 1 - }, numeric(1)) + n <- vapply( + g$grobs[gb], + function(x) { + if (is_zero(x)) { + return(0) + } + length(x$grobs) - 1 + }, + numeric(1) + ) sum(n) } @@ -31,7 +37,6 @@ test_that("show.legend handles named vectors", { }) test_that("guide merging for guide_legend() works as expected", { - merge_test_guides <- function(scale1, scale2) { scale1$guide <- guide_legend(direction = "vertical") scale2$guide <- guide_legend(direction = "vertical") @@ -67,30 +72,46 @@ test_that("guide merging for guide_legend() works as expected", { same_labels_different_limits <- merge_test_guides( scale_colour_hue(limits = c("a", "b", "c")), - scale_linetype_discrete(limits = c("one", "two", "three"), labels = c("a", "b", "c")) + scale_linetype_discrete( + limits = c("one", "two", "three"), + labels = c("a", "b", "c") + ) ) expect_length(same_labels_different_limits, 1) expect_equal(same_labels_different_limits[[1]]$key$.label, c("a", "b", "c")) same_labels_different_scale <- merge_test_guides( - scale_colour_gradient(limits = c(0, 4), breaks = 1:3, labels = c("a", "b", "c")), + scale_colour_gradient( + limits = c(0, 4), + breaks = 1:3, + labels = c("a", "b", "c") + ), scale_linetype_discrete(limits = c("a", "b", "c")) ) expect_length(same_labels_different_scale, 1) expect_equal(same_labels_different_scale[[1]]$key$.label, c("a", "b", "c")) repeated_identical_labels <- merge_test_guides( - scale_colour_hue(limits = c("one", "two", "three"), labels = c("label1", "label1", "label2")), - scale_linetype_discrete(limits = c("1", "2", "3"), labels = c("label1", "label1", "label2")) + scale_colour_hue( + limits = c("one", "two", "three"), + labels = c("label1", "label1", "label2") + ), + scale_linetype_discrete( + limits = c("1", "2", "3"), + labels = c("label1", "label1", "label2") + ) ) expect_length(repeated_identical_labels, 1) - expect_equal(repeated_identical_labels[[1]]$key$.label, c("label1", "label1", "label2")) + expect_equal( + repeated_identical_labels[[1]]$key$.label, + c("label1", "label1", "label2") + ) }) test_that("size = NA doesn't throw rendering errors", { df <- data.frame( x = c(1, 2), - group = c("a","b") + group = c("a", "b") ) p <- ggplot(df, aes(x = x, y = 0, colour = group)) + geom_point(size = NA, na.rm = TRUE) @@ -99,7 +120,6 @@ test_that("size = NA doesn't throw rendering errors", { }) test_that("legend reverse argument reverses the key", { - scale <- scale_colour_hue() scale$train(LETTERS[1:4]) @@ -118,7 +138,6 @@ test_that("legend reverse argument reverses the key", { }) test_that("legends can be forced to display unrelated geoms", { - df <- data.frame(x = 1:2) p <- ggplot(df, aes(x, x)) + @@ -149,7 +168,6 @@ test_that("unresolved, modified expressions throw a warning (#6264)", { # Visual tests ------------------------------------------------------------ test_that("legend directions are set correctly", { - p <- ggplot(mtcars, aes(disp, mpg, shape = factor(cyl), colour = drat)) + geom_point() + theme_test() @@ -179,7 +197,6 @@ test_that("guide_legend uses key.spacing correctly", { }) test_that("absent titles don't take up space", { - p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + geom_point() + theme( @@ -196,7 +213,7 @@ test_that("absent titles don't take up space", { test_that("size and linewidth affect key size", { df <- data_frame(x = c(0, 1, 2)) - p <- ggplot(df, aes(x, x)) + + p <- ggplot(df, aes(x, x)) + geom_point(aes(size = x)) + geom_line(aes(linewidth = 2 - x)) + scale_size_continuous(range = c(1, 12)) + @@ -206,7 +223,6 @@ test_that("size and linewidth affect key size", { }) test_that("legend.byrow works in `guide_legend()`", { - df <- data.frame(x = 1:6, f = LETTERS[1:6]) p <- ggplot(df, aes(x, x, colour = f)) + @@ -222,18 +238,21 @@ test_that("legend.byrow works in `guide_legend()`", { }) test_that("legend.key.justification works as intended", { - p <- ggplot(mtcars, aes(mpg, disp, colour = factor(cyl), size = drat)) + geom_point() + scale_size_continuous( - range = c(0, 20), breaks = c(3, 4, 5), limits = c(2.5, 5) + range = c(0, 20), + breaks = c(3, 4, 5), + limits = c(2.5, 5) ) + scale_colour_discrete( - labels = c("one line", "up\nto\nfour\nlines", "up\nto\nfive\nwhole\nlines") + labels = c( + "one line", + "up\nto\nfour\nlines", + "up\nto\nfive\nwhole\nlines" + ) ) + theme(legend.key.justification = c(1, 0)) expect_doppelganger("legend key justification", p) - }) - diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index ae1bfe85bd..bad5effcbd 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -27,18 +27,28 @@ test_that("guide specifications are properly checked", { expect_snapshot_warning(ggplotGrob(p)) - p <- p + guides(shape = guide_legend(theme = theme(legend.title.position = "leftish"))) + p <- p + + guides( + shape = guide_legend(theme = theme(legend.title.position = "leftish")) + ) expect_snapshot_error(ggplotGrob(p)) expect_snapshot_error(guide_colourbar()$transform()) p <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = gear)) + - guides(colour = guide_colourbar(theme = theme(legend.text.position = "top"))) + guides( + colour = guide_colourbar(theme = theme(legend.text.position = "top")) + ) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = gear)) + - guides(colour = guide_colourbar(direction = "horizontal", theme = theme(legend.text.position = "left"))) + guides( + colour = guide_colourbar( + direction = "horizontal", + theme = theme(legend.text.position = "left") + ) + ) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + @@ -66,7 +76,10 @@ test_that("guide_coloursteps and guide_bins return ordered breaks", { expect_true(all(diff(key$.value) > 0)) # Out of bound breaks are removed - scale <- scale_colour_viridis_c(breaks = c(10, 20, 30, 40, 50), na.value = "grey50") + scale <- scale_colour_viridis_c( + breaks = c(10, 20, 30, 40, 50), + na.value = "grey50" + ) scale$train(c(15, 45)) g <- guide_colorsteps() @@ -75,14 +88,13 @@ test_that("guide_coloursteps and guide_bins return ordered breaks", { }) test_that("guide_coloursteps can parse (un)even steps from discrete scales", { - val <- cut(1:10, breaks = c(0, 3, 5, 10), include.lowest = TRUE) scale <- scale_colour_viridis_d() scale$train(val) g <- guide_coloursteps(even.steps = TRUE) decor <- g$train(scale = scale, aesthetics = "colour")$decor - expect_equal(decor$max - decor$min, rep(1/3, 3)) + expect_equal(decor$max - decor$min, rep(1 / 3, 3)) g <- guide_coloursteps(even.steps = FALSE) decor <- g$train(scale = scale, aesthetics = "colour")$decor @@ -90,7 +102,6 @@ test_that("guide_coloursteps can parse (un)even steps from discrete scales", { }) test_that("get_guide_data retrieves keys appropriately", { - p <- ggplot(mtcars, aes(mpg, disp, colour = drat, size = drat, fill = wt)) + geom_point(shape = 21) + facet_wrap(vars(cyl), scales = "free_x") + @@ -120,7 +131,6 @@ test_that("get_guide_data retrieves keys appropriately", { }) test_that("get_guide_data retrieves keys from exotic coords", { - p <- ggplot(mtcars, aes(mpg, disp)) + geom_point() # Sanity check @@ -139,7 +149,6 @@ test_that("get_guide_data retrieves keys from exotic coords", { }) test_that("empty guides are dropped", { - df <- data.frame(x = 1:2) # Making a guide where all breaks are out-of-bounds p <- ggplot(df, aes(x, x, colour = x)) + @@ -147,7 +156,7 @@ test_that("empty guides are dropped", { scale_colour_continuous( limits = c(0.25, 0.75), breaks = c(1, 2), - guide = "legend" + guide = "legend" ) p <- ggplot_build(p) @@ -163,7 +172,6 @@ test_that("empty guides are dropped", { }) test_that("bins can be parsed by guides for all scale types", { - breaks <- c(90, 100, 200, 300) limits <- c(0, 1000) @@ -191,7 +199,6 @@ test_that("bins can be parsed by guides for all scale types", { }) test_that("binned breaks can have hardcoded labels when oob", { - sc <- scale_colour_steps(breaks = 1:3, labels = as.character(1:3)) sc$train(c(1, 2)) @@ -221,41 +228,44 @@ test_that("guides are positioned correctly", { scale_x_continuous(breaks = 1, labels = "very long axis label") + scale_y_continuous(breaks = 1, labels = "very long axis label") - expect_doppelganger("legend on left", - p1 + theme(legend.position = "left") - ) - expect_doppelganger("legend on bottom", + expect_doppelganger("legend on left", p1 + theme(legend.position = "left")) + expect_doppelganger( + "legend on bottom", p1 + theme(legend.position = "bottom") ) - expect_doppelganger("legend on right", - p1 + theme(legend.position = "right") - ) - expect_doppelganger("legend on top", - p1 + theme(legend.position = "top") - ) - expect_doppelganger("facet_grid, legend on left", - p1 + facet_grid(x~y) + theme(legend.position = "left") + expect_doppelganger("legend on right", p1 + theme(legend.position = "right")) + expect_doppelganger("legend on top", p1 + theme(legend.position = "top")) + expect_doppelganger( + "facet_grid, legend on left", + p1 + facet_grid(x ~ y) + theme(legend.position = "left") ) - expect_doppelganger("facet_grid, legend on bottom", - p1 + facet_grid(x~y) + theme(legend.position = "bottom") + expect_doppelganger( + "facet_grid, legend on bottom", + p1 + facet_grid(x ~ y) + theme(legend.position = "bottom") ) - expect_doppelganger("facet_grid, legend on right", - p1 + facet_grid(x~y) + theme(legend.position = "right") + expect_doppelganger( + "facet_grid, legend on right", + p1 + facet_grid(x ~ y) + theme(legend.position = "right") ) - expect_doppelganger("facet_grid, legend on top", - p1 + facet_grid(x~y) + theme(legend.position = "top") + expect_doppelganger( + "facet_grid, legend on top", + p1 + facet_grid(x ~ y) + theme(legend.position = "top") ) - expect_doppelganger("facet_wrap, legend on left", - p1 + facet_wrap(~ x) + theme(legend.position = "left") + expect_doppelganger( + "facet_wrap, legend on left", + p1 + facet_wrap(~x) + theme(legend.position = "left") ) - expect_doppelganger("facet_wrap, legend on bottom", - p1 + facet_wrap(~ x) + theme(legend.position = "bottom") + expect_doppelganger( + "facet_wrap, legend on bottom", + p1 + facet_wrap(~x) + theme(legend.position = "bottom") ) - expect_doppelganger("facet_wrap, legend on right", - p1 + facet_wrap(~ x) + theme(legend.position = "right") + expect_doppelganger( + "facet_wrap, legend on right", + p1 + facet_wrap(~x) + theme(legend.position = "right") ) - expect_doppelganger("facet_wrap, legend on top", - p1 + facet_wrap(~ x) + theme(legend.position = "top") + expect_doppelganger( + "facet_wrap, legend on top", + p1 + facet_wrap(~x) + theme(legend.position = "top") ) # padding @@ -270,35 +280,44 @@ test_that("guides are positioned correctly", { p2 <- p2 + theme(legend.position = "inside") # Placement of legend inside - expect_doppelganger("legend inside plot, centered", + expect_doppelganger( + "legend inside plot, centered", p2 + theme(legend.position.inside = c(0.5, 0.5)) ) - expect_doppelganger("legend inside plot, bottom left", - p2 + theme(legend.justification = c(0,0), legend.position.inside = c(0,0)) + expect_doppelganger( + "legend inside plot, bottom left", + p2 + theme(legend.justification = c(0, 0), legend.position.inside = c(0, 0)) ) - expect_doppelganger("legend inside plot, top right", - p2 + theme(legend.justification = c(1,1), legend.position.inside = c(1,1)) + expect_doppelganger( + "legend inside plot, top right", + p2 + theme(legend.justification = c(1, 1), legend.position.inside = c(1, 1)) ) - expect_doppelganger("legend inside plot, bottom left of legend at center", - p2 + theme(legend.justification = c(0,0), legend.position.inside = c(0.5,0.5)) + expect_doppelganger( + "legend inside plot, bottom left of legend at center", + p2 + + theme( + legend.justification = c(0, 0), + legend.position.inside = c(0.5, 0.5) + ) ) - expect_doppelganger("legend inside plot, multiple positions", + expect_doppelganger( + "legend inside plot, multiple positions", p2 + guides( - colour = guide_colourbar( - position = "inside", - theme = theme( - legend.position.inside = c(0, 1), - legend.justification.inside = c(0, 1) - ) - ), - fill = guide_legend( - position = "inside", - theme = theme( - legend.position.inside = c(1, 0), - legend.justification.inside = c(1, 0) - ) + colour = guide_colourbar( + position = "inside", + theme = theme( + legend.position.inside = c(0, 1), + legend.justification.inside = c(0, 1) + ) + ), + fill = guide_legend( + position = "inside", + theme = theme( + legend.position.inside = c(1, 0), + legend.justification.inside = c(1, 0) ) + ) ) ) }) @@ -309,19 +328,21 @@ test_that("guides title and text are positioned correctly", { geom_point(shape = 21) + # setting the order explicitly removes the risk for failed doppelgangers # due to legends switching order - guides(color = guide_legend(order = 2), - fill = guide_colorbar(order = 1)) + + guides(color = guide_legend(order = 2), fill = guide_colorbar(order = 1)) + theme_test() - expect_doppelganger("multi-line guide title works", + expect_doppelganger( + "multi-line guide title works", p + scale_color_discrete(name = "the\ndiscrete\ncolorscale") + scale_fill_continuous(name = "the\ncontinuous\ncolorscale") ) - expect_doppelganger("vertical gap of 1cm between guide title and guide", + expect_doppelganger( + "vertical gap of 1cm between guide title and guide", p + theme(legend.title = element_text(margin = margin(b = 1, unit = "cm"))) ) - expect_doppelganger("horizontal gap of 1cm between guide and guide text", + expect_doppelganger( + "horizontal gap of 1cm between guide and guide text", p + theme(legend.text = element_text(margin = margin(l = 1, unit = "cm"))) ) @@ -331,15 +352,22 @@ test_that("guides title and text are positioned correctly", { geom_point() + # setting the order explicitly removes the risk for failed doppelgangers # due to legends switching order - guides(shape = guide_legend(order = 1), - color = guide_colorbar(order = 2)) + + guides(shape = guide_legend(order = 1), color = guide_colorbar(order = 2)) + theme_test() - expect_doppelganger("guide title and text positioning and alignment via themes", - p + theme( - legend.title = element_text(hjust = 0.5, margin = margin(t = 30, b = 5.5)), - legend.text = element_text(hjust = 1, margin = margin(l = 10.5, t = 10, b = 10)) - ) + expect_doppelganger( + "guide title and text positioning and alignment via themes", + p + + theme( + legend.title = element_text( + hjust = 0.5, + margin = margin(t = 30, b = 5.5) + ), + legend.text = element_text( + hjust = 1, + margin = margin(l = 10.5, t = 10, b = 10) + ) + ) ) # title and label rotation @@ -350,8 +378,18 @@ test_that("guides title and text are positioned correctly", { name = "value", guide = guide_colorbar( theme = theme( - legend.title = element_text(size = 11, angle = 0, hjust = 0.5, vjust = 1), - legend.text = element_text(size = 0.8 * 11, angle = 270, hjust = 0.5, vjust = 1) + legend.title = element_text( + size = 11, + angle = 0, + hjust = 0.5, + vjust = 1 + ), + legend.text = element_text( + size = 0.8 * 11, + angle = 270, + hjust = 0.5, + vjust = 1 + ) ), order = 2 # set guide order to keep visual test stable ) @@ -366,42 +404,63 @@ test_that("guides title and text are positioned correctly", { theme = theme( legend.title.position = "top", legend.text.position = "bottom", - legend.title = element_text(size = 11, angle = 180, hjust = 0, vjust = 1), - legend.text = element_text(size = 0.8 * 11, angle = 90, hjust = 1, vjust = 0.5) + legend.title = element_text( + size = 11, + angle = 180, + hjust = 0, + vjust = 1 + ), + legend.text = element_text( + size = 0.8 * 11, + angle = 90, + hjust = 1, + vjust = 0.5 + ) ), order = 1 ) ) - expect_doppelganger("rotated guide titles and labels", p ) + expect_doppelganger("rotated guide titles and labels", p) # title justification p <- ggplot(data.frame(x = 1:2)) + - aes(x, x, colour = factor(x), fill = factor(x), shape = factor(x), alpha = x) + + aes( + x, + x, + colour = factor(x), + fill = factor(x), + shape = factor(x), + alpha = x + ) + geom_point() + scale_alpha(breaks = 1:2) + guides( colour = guide_legend( - "colour title with hjust = 0", order = 1, + "colour title with hjust = 0", + order = 1, theme = theme(legend.title = element_text(hjust = 0)) ), - fill = guide_legend( - "fill title with hjust = 1", order = 2, + fill = guide_legend( + "fill title with hjust = 1", + order = 2, theme = theme( legend.title = element_text(hjust = 1), legend.title.position = "bottom" ), override.aes = list(shape = 21) ), - alpha = guide_legend( - "Title\nfor\nalpha\nwith\nvjust=0", order = 3, + alpha = guide_legend( + "Title\nfor\nalpha\nwith\nvjust=0", + order = 3, theme = theme( legend.title = element_text(vjust = 0), legend.title.position = "left" ) ), shape = guide_legend( - "Title\nfor\nshape\nwith\nvjust=1", order = 4, + "Title\nfor\nshape\nwith\nvjust=1", + order = 4, theme = theme( legend.title = element_text(vjust = 1), legend.title.position = "right" @@ -412,35 +471,37 @@ test_that("guides title and text are positioned correctly", { }) test_that("bin guide can be reversed", { - p <- ggplot(data.frame(x = c(0, 100)), aes(x, x, colour = x, fill = x)) + geom_point() + guides( - colour = guide_bins(reverse = TRUE, show.limits = TRUE, order = 1), - fill = guide_bins( - reverse = TRUE, show.limits = FALSE, order = 2, + colour = guide_bins(reverse = TRUE, show.limits = TRUE, order = 1), + fill = guide_bins( + reverse = TRUE, + show.limits = FALSE, + order = 2, override.aes = list(shape = 21) ) ) expect_doppelganger("reversed guide_bins", p) - }) test_that("bin guide can be styled correctly", { - df <- data_frame(x = c(1, 2, 3), - y = c(6, 5, 7)) + df <- data_frame(x = c(1, 2, 3), y = c(6, 5, 7)) p <- ggplot(df, aes(x, y, size = x)) + geom_point() + scale_size_binned() expect_doppelganger("guide_bins looks as it should", p) - expect_doppelganger("guide_bins can show limits", + expect_doppelganger( + "guide_bins can show limits", p + guides(size = guide_bins(show.limits = TRUE)) ) - expect_doppelganger("guide_bins can show arrows", - p + guides(size = guide_bins()) + + expect_doppelganger( + "guide_bins can show arrows", + p + + guides(size = guide_bins()) + theme_test() + theme( legend.axis.line = element_line( @@ -449,38 +510,48 @@ test_that("bin guide can be styled correctly", { ) ) ) - expect_doppelganger("guide_bins can remove axis", - p + guides(size = guide_bins()) + + expect_doppelganger( + "guide_bins can remove axis", + p + + guides(size = guide_bins()) + theme_test() + theme( legend.axis.line = element_blank() ) ) - expect_doppelganger("guide_bins work horizontally", + expect_doppelganger( + "guide_bins work horizontally", p + guides(size = guide_bins(direction = "horizontal")) ) }) test_that("coloursteps guide can be styled correctly", { - df <- data_frame(x = c(1, 2, 4), - y = c(6, 5, 7)) + df <- data_frame(x = c(1, 2, 4), y = c(6, 5, 7)) p <- ggplot(df, aes(x, y, colour = x)) + geom_point() + scale_colour_binned(breaks = c(1.5, 2, 3)) expect_doppelganger("guide_coloursteps looks as it should", p) - expect_doppelganger("guide_coloursteps can show limits", + expect_doppelganger( + "guide_coloursteps can show limits", p + guides(colour = guide_coloursteps(show.limits = TRUE)) ) - expect_doppelganger("guide_coloursteps can have bins relative to binsize", + expect_doppelganger( + "guide_coloursteps can have bins relative to binsize", p + guides(colour = guide_coloursteps(even.steps = FALSE)) ) - expect_doppelganger("guide_bins can show ticks and transparancy", - p + guides(colour = guide_coloursteps( - alpha = 0.75, - theme = theme(legend.ticks = element_line(linewidth = 0.5 / .pt, colour = "white")) - )) + expect_doppelganger( + "guide_bins can show ticks and transparancy", + p + + guides( + colour = guide_coloursteps( + alpha = 0.75, + theme = theme( + legend.ticks = element_line(linewidth = 0.5 / .pt, colour = "white") + ) + ) + ) ) }) @@ -488,59 +559,97 @@ test_that("binning scales understand the different combinations of limits, break p <- ggplot(mpg, aes(cty, hwy, color = year)) + geom_point() - expect_doppelganger("guide_bins understands coinciding limits and bins", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins') + expect_doppelganger( + "guide_bins understands coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins' + ) ) - expect_doppelganger("guide_bins understands coinciding limits and bins 2", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(2000, 2002, 2004, 2006, 2008), - guide = 'bins') + expect_doppelganger( + "guide_bins understands coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008), + guide = 'bins' + ) ) - expect_doppelganger("guide_bins understands coinciding limits and bins 3", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins', show.limits = TRUE) + expect_doppelganger( + "guide_bins understands coinciding limits and bins 3", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins', + show.limits = TRUE + ) ) - expect_doppelganger("guide_bins sets labels when limits is in breaks", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - labels = 1:5, guide = 'bins') + expect_doppelganger( + "guide_bins sets labels when limits is in breaks", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + labels = 1:5, + guide = 'bins' + ) ) - expect_snapshot_warning(ggplotGrob(p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins"))) + expect_snapshot_warning(ggplotGrob( + p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins") + )) - expect_doppelganger("guide_colorsteps understands coinciding limits and bins", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006)) + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006) + ) ) - expect_doppelganger("guide_colorsteps understands coinciding limits and bins 2", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(2000, 2002, 2004, 2006, 2008)) + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008) + ) ) - expect_doppelganger("guide_colorsteps understands coinciding limits and bins 3", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - show.limits = TRUE) + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins 3", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + show.limits = TRUE + ) ) - expect_doppelganger("guide_colorsteps sets labels when limits is in breaks", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - labels = 1:5) + expect_doppelganger( + "guide_colorsteps sets labels when limits is in breaks", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + labels = 1:5 + ) ) - expect_snapshot_warning(ggplotGrob(p + scale_color_binned(labels = 1:4, show.limits = TRUE))) + expect_snapshot_warning(ggplotGrob( + p + scale_color_binned(labels = 1:4, show.limits = TRUE) + )) }) test_that("a warning is generated when guides( = FALSE) is specified", { - df <- data_frame(x = c(1, 2, 4), - y = c(6, 5, 7)) + df <- data_frame(x = c(1, 2, 4), y = c(6, 5, 7)) # warn on guide( = FALSE) lifecycle::expect_deprecated(g <- guides(colour = FALSE)) expect_equal(g$guides[["colour"]], "none") # warn on scale_*(guide = FALSE) - p <- ggplot(df, aes(x, y, colour = x)) + scale_colour_continuous(guide = FALSE) + p <- ggplot(df, aes(x, y, colour = x)) + + scale_colour_continuous(guide = FALSE) lifecycle::expect_deprecated(ggplot_build(p)) }) @@ -551,7 +660,6 @@ test_that("guides() warns if unnamed guides are provided", { }) test_that("old S3 guides can be implemented", { - my_env <- env() my_env$guide_circle <- function() { structure( @@ -561,31 +669,37 @@ test_that("old S3 guides can be implemented", { } registerS3method( - "guide_train", "circle", + "guide_train", + "circle", function(guide, ...) guide, envir = my_env ) registerS3method( - "guide_transform", "circle", + "guide_transform", + "circle", function(guide, ...) guide, envir = my_env ) registerS3method( - "guide_merge", "circle", + "guide_merge", + "circle", function(guide, ...) guide, envir = my_env ) registerS3method( - "guide_geom", "circle", + "guide_geom", + "circle", function(guide, ...) guide, envir = my_env ) registerS3method( - "guide_gengrob", "circle", + "guide_gengrob", + "circle", function(guide, ...) { absoluteGrob( gList(circleGrob()), - height = unit(1, "cm"), width = unit(1, "cm") + height = unit(1, "cm"), + width = unit(1, "cm") ) }, envir = my_env @@ -608,17 +722,22 @@ test_that("old S3 guides can be implemented", { }) test_that("guide_custom can be drawn and styled", { - - p <- ggplot() + guides(custom = guide_custom( - circleGrob(r = unit(1, "cm")), - title = "custom guide" - )) + p <- ggplot() + + guides( + custom = guide_custom( + circleGrob(r = unit(1, "cm")), + title = "custom guide" + ) + ) expect_doppelganger( "stylised guide_custom", - p + theme(legend.background = element_rect(fill = "grey50"), - legend.title.position = "left", - legend.title = element_text(angle = 90, hjust = 0.5)) + p + + theme( + legend.background = element_rect(fill = "grey50"), + legend.title.position = "left", + legend.title = element_text(angle = 90, hjust = 0.5) + ) ) expect_doppelganger( diff --git a/tests/testthat/test-labellers.R b/tests/testthat/test-labellers.R index 7cc6ad0df3..3ec6763252 100644 --- a/tests/testthat/test-labellers.R +++ b/tests/testthat/test-labellers.R @@ -16,7 +16,11 @@ test_that("label_bquote has access to functions in the calling environment", { test_that("resolve_labeller() provide meaningful errors", { expect_snapshot_error(resolve_labeller(NULL, NULL)) - expect_snapshot_error(resolve_labeller(prod, sum, structure(1:4, facet = "wrap"))) + expect_snapshot_error(resolve_labeller( + prod, + sum, + structure(1:4, facet = "wrap") + )) }) test_that("labeller function catches overlap in names", { diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index d7eb22ba40..e7e5f997b5 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -1,52 +1,54 @@ test_that("setting guide labels works", { + expect_identical(xlab("my label")$x, "my label") + expect_identical(labs(x = "my label")$x, "my label") - expect_identical(xlab("my label")$x, "my label") - expect_identical(labs(x = "my label")$x, "my label") - - expect_identical(ylab("my label")$y, "my label") - expect_identical(labs(y = "my label")$y, "my label") - - # Plot titles - expect_identical(labs(title = "my title")$title, "my title") - expect_identical(labs(title = "my title", - subtitle = "my subtitle")$subtitle, "my subtitle") - - # whole plot annotations - expect_identical(labs(caption = "my notice")$caption, "my notice") - expect_identical(labs(title = "my title", - caption = "my notice")$caption, "my notice") - expect_identical(labs(tag = "A)")$tag, "A)") - expect_identical(labs(title = "my title", - tag = "A)")$tag, "A)") - - # Colour - expect_identical(labs(colour = "my label")$colour, "my label") - # American spelling - expect_identical(labs(color = "my label")$colour, "my label") - - # No extra elements exists - expect_length(labs(title = "my title"), 1) # formal argument - expect_length(labs(colour = "my label"), 1) # dot - expect_length(labs(foo = "bar"), 1) # non-existent param - - # labs() has list-splicing semantics - params <- list(title = "my title", tag = "A)") - expect_identical(labs(!!!params)$tag, "A)") - - # NULL is preserved - expect_length(labs(title = NULL), 1) - - # ggtitle works in the same way as labs() - expect_identical(ggtitle("my title")$title, "my title") - expect_identical( - ggtitle("my title", subtitle = "my subtitle")$subtitle, - "my subtitle" - ) - expect_equal( - unclass(ggtitle("my title", subtitle = NULL)), - list(title = "my title", subtitle = NULL), - ignore_attr = TRUE - ) + expect_identical(ylab("my label")$y, "my label") + expect_identical(labs(y = "my label")$y, "my label") + + # Plot titles + expect_identical(labs(title = "my title")$title, "my title") + expect_identical( + labs(title = "my title", subtitle = "my subtitle")$subtitle, + "my subtitle" + ) + + # whole plot annotations + expect_identical(labs(caption = "my notice")$caption, "my notice") + expect_identical( + labs(title = "my title", caption = "my notice")$caption, + "my notice" + ) + expect_identical(labs(tag = "A)")$tag, "A)") + expect_identical(labs(title = "my title", tag = "A)")$tag, "A)") + + # Colour + expect_identical(labs(colour = "my label")$colour, "my label") + # American spelling + expect_identical(labs(color = "my label")$colour, "my label") + + # No extra elements exists + expect_length(labs(title = "my title"), 1) # formal argument + expect_length(labs(colour = "my label"), 1) # dot + expect_length(labs(foo = "bar"), 1) # non-existent param + + # labs() has list-splicing semantics + params <- list(title = "my title", tag = "A)") + expect_identical(labs(!!!params)$tag, "A)") + + # NULL is preserved + expect_length(labs(title = NULL), 1) + + # ggtitle works in the same way as labs() + expect_identical(ggtitle("my title")$title, "my title") + expect_identical( + ggtitle("my title", subtitle = "my subtitle")$subtitle, + "my subtitle" + ) + expect_equal( + unclass(ggtitle("my title", subtitle = NULL)), + list(title = "my title", subtitle = NULL), + ignore_attr = TRUE + ) }) test_that("Labels from default stat mapping are overwritten by default labels", { @@ -73,7 +75,6 @@ test_that("Labels can be extracted from attributes", { }) test_that("Labels from static aesthetics are ignored (#6003)", { - df <- data.frame(x = 1, y = 1, f = 1) p <- ggplot(df, aes(x, y, colour = f)) + geom_point() @@ -134,10 +135,11 @@ test_that("plot.tag.position rejects invalid input", { error = TRUE ) expect_snapshot( - ggplotGrob(p + theme(plot.tag.position = c(0, 0), plot.tag.location = "margin")), + ggplotGrob( + p + theme(plot.tag.position = c(0, 0), plot.tag.location = "margin") + ), error = TRUE ) - }) test_that("position axis label hierarchy works as intended", { @@ -197,8 +199,12 @@ test_that("position axis label hierarchy works as intended", { # Secondary guide titles override secondary axis names p@layout$setup_panel_guides( - guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"), - x.sec = guide_axis("waldo"), y.sec = guide_axis("fred"))), + guides_list(list( + x = guide_axis("quuX"), + y = guide_axis("corgE"), + x.sec = guide_axis("waldo"), + y.sec = guide_axis("fred") + )), p@plot@layers ) expect_identical( @@ -213,7 +219,6 @@ test_that("position axis label hierarchy works as intended", { }) test_that("labels can be derived using functions", { - p <- ggplot(mtcars, aes(disp, mpg, colour = drat, shape = factor(cyl))) + geom_point() + labs( @@ -228,11 +233,10 @@ test_that("labels can be derived using functions", { guides(colour = guide_colourbar(title = to_upper_ascii)) labs <- get_labs(p) - expect_equal(labs$shape, "FOO(CYL)!!!") + expect_equal(labs$shape, "FOO(CYL)!!!") expect_equal(labs$colour, "DRAT") - expect_equal(labs$x, "DISP") - expect_equal(labs$y, "MPG") - + expect_equal(labs$x, "DISP") + expect_equal(labs$y, "MPG") }) test_that("moving guide positions lets titles follow", { @@ -246,8 +250,10 @@ test_that("moving guide positions lets titles follow", { # Default guide positions p@layout$setup_panel_guides( guides_list( - list(x = guide_axis("baz", position = "bottom"), - y = guide_axis("qux", position = "left")) + list( + x = guide_axis("baz", position = "bottom"), + y = guide_axis("qux", position = "left") + ) ), p@plot@layers ) @@ -258,8 +264,10 @@ test_that("moving guide positions lets titles follow", { # Guides at secondary positions p@layout$setup_panel_guides( guides_list( - list(x = guide_axis("baz", position = "top"), - y = guide_axis("qux", position = "right")) + list( + x = guide_axis("baz", position = "top"), + y = guide_axis("qux", position = "right") + ) ), p@plot@layers ) @@ -270,10 +278,12 @@ test_that("moving guide positions lets titles follow", { # secondary guides at primary positions p@layout$setup_panel_guides( guides_list( - list(x = guide_axis("baz", position = "top"), - y = guide_axis("qux", position = "right"), - x.sec = guide_axis("quux"), - y.sec = guide_axis("corge")) + list( + x = guide_axis("baz", position = "top"), + y = guide_axis("qux", position = "right"), + x.sec = guide_axis("quux"), + y.sec = guide_axis("corge") + ) ), p@plot@layers ) @@ -283,15 +293,16 @@ test_that("moving guide positions lets titles follow", { }) test_that("label dictionaries work", { - p <- ggplot(mtcars, aes(disp, mpg, shape = factor(cyl), size = drat)) + geom_point() + - labs(dictionary = c( - disp = "Displacement", - mpg = "Miles per gallon", - `factor(cyl)` = "Number of cylinders", - drat = "Rear axle ratio" - )) + labs( + dictionary = c( + disp = "Displacement", + mpg = "Miles per gallon", + `factor(cyl)` = "Number of cylinders", + drat = "Rear axle ratio" + ) + ) p <- ggplot_build(p) x <- p@layout$resolve_label(p@layout$panel_scales_x[[1]], p@plot@labels) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index efa1265b3f..a867480253 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -5,8 +5,18 @@ test_that("layer() checks its input", { expect_snapshot_error(layer(geom = "point", position = "identity")) expect_snapshot_error(layer(geom = "point", stat = "identity")) - expect_snapshot_error(layer("point", "identity", mapping = 1:4, position = "identity")) - expect_snapshot_error(layer("point", "identity", mapping = ggplot(), position = "identity")) + expect_snapshot_error(layer( + "point", + "identity", + mapping = 1:4, + position = "identity" + )) + expect_snapshot_error(layer( + "point", + "identity", + mapping = ggplot(), + position = "identity" + )) expect_snapshot_error(validate_subclass("test", "geom")) expect_snapshot_error(validate_subclass(environment(), "geom")) @@ -79,7 +89,13 @@ test_that("function aesthetics are wrapped with after_stat()", { test_that("computed stats are in appropriate layer", { df <- data_frame(x = 1:10) expect_snapshot_error( - ggplot_build(ggplot(df, aes(colour = after_stat(density), fill = after_stat(density))) + geom_point()) + ggplot_build( + ggplot( + df, + aes(colour = after_stat(density), fill = after_stat(density)) + ) + + geom_point() + ) ) }) @@ -95,9 +111,15 @@ test_that("layers are stateless except for the computed params", { p <- ggplot(df) + geom_col(aes(x = x, y = y), width = 0.8, fill = "red") col_layer <- as.list(p@layers[[1]]) - stateless_names <- setdiff(names(col_layer), c("computed_geom_params", "computed_stat_params", "computed_mapping")) + stateless_names <- setdiff( + names(col_layer), + c("computed_geom_params", "computed_stat_params", "computed_mapping") + ) invisible(ggplotGrob(p)) - expect_identical(as.list(p@layers[[1]])[stateless_names], col_layer[stateless_names]) + expect_identical( + as.list(p@layers[[1]])[stateless_names], + col_layer[stateless_names] + ) }) test_that("inherit.aes works", { @@ -108,11 +130,14 @@ test_that("inherit.aes works", { geom_col(aes(x = x, y = y), inherit.aes = FALSE) invisible(ggplotGrob(p1)) invisible(ggplotGrob(p2)) - expect_identical(p1@layers[[1]]$computed_mapping, p2@layers[[1]]$computed_mapping) + expect_identical( + p1@layers[[1]]$computed_mapping, + p2@layers[[1]]$computed_mapping + ) }) test_that("retransform works on computed aesthetics in `map_statistic`", { - df <- data.frame(x = rep(c(1,2), c(9, 25))) + df <- data.frame(x = rep(c(1, 2), c(9, 25))) p <- ggplot(df, aes(x)) + geom_bar() + scale_y_sqrt() expect_equal(get_layer_data(p)$y, c(3, 5)) @@ -146,7 +171,6 @@ test_that("layer warns for constant aesthetics", { }) test_that("layer names can be resolved", { - p <- ggplot() + geom_point() + geom_point() expect_named(p@layers, c("geom_point", "geom_point...2")) @@ -158,7 +182,6 @@ test_that("layer names can be resolved", { }) test_that("validate_subclass can resolve classes via constructors", { - env <- new_environment(list( geom_foobar = geom_point, stat_foobar = stat_boxplot, @@ -168,9 +191,14 @@ test_that("validate_subclass can resolve classes via constructors", { expect_s3_class(validate_subclass("foobar", "Geom", env = env), "GeomPoint") expect_s3_class(validate_subclass("foobar", "Stat", env = env), "StatBoxplot") - expect_s3_class(validate_subclass("foobar", "Position", env = env), "PositionNudge") - expect_s3_class(validate_subclass("foobar", "Guide", env = env), "GuideAxisTheta") - + expect_s3_class( + validate_subclass("foobar", "Position", env = env), + "PositionNudge" + ) + expect_s3_class( + validate_subclass("foobar", "Guide", env = env), + "GuideAxisTheta" + ) }) test_that("attributes on layer data are preserved", { @@ -181,7 +209,9 @@ test_that("attributes on layer data are preserved", { # * It has an `after_stat()` so it enters the map_statistic method old <- stat_summary( aes(fill = after_stat(y)), - fun = mean, geom = "col", position = "dodge" + fun = mean, + geom = "col", + position = "dodge" ) # We modify the compute aesthetics method to append a test attribute new <- ggproto(NULL, old, compute_aesthetics = function(self, data, plot) { @@ -191,7 +221,9 @@ test_that("attributes on layer data are preserved", { }) # At the end of plot building, we want to retrieve that metric ld <- layer_data( - ggplot(mpg, aes(drv, hwy, colour = factor(year))) + new + facet_grid(~year) + + ggplot(mpg, aes(drv, hwy, colour = factor(year))) + + new + + facet_grid(~year) + scale_y_sqrt() ) expect_equal(attr(ld, "test"), "preserve me") @@ -239,5 +271,5 @@ test_that("data.frames and matrix aesthetics survive the build stage", { scale_shape_identity() ) expect_vector(p$colour, matrix(NA_integer_, nrow = 0, ncol = 2), size = 2) - expect_vector(p$shape, data_frame0(a = integer(), b = character()), size = 2) + expect_vector(p$shape, data_frame0(a = integer(), b = character()), size = 2) }) diff --git a/tests/testthat/test-legend-draw.R b/tests/testthat/test-legend-draw.R index b0c0505b2a..9751faff2d 100644 --- a/tests/testthat/test-legend-draw.R +++ b/tests/testthat/test-legend-draw.R @@ -1,8 +1,10 @@ - test_that("all keys can be drawn without 'params'", { - params <- list() - size <- convertUnit(calc_element("legend.key.size", theme_gray()), "cm", valueOnly = TRUE) + size <- convertUnit( + calc_element("legend.key.size", theme_gray()), + "cm", + valueOnly = TRUE + ) size <- size * 10 # cm to mm # Render every key @@ -10,23 +12,31 @@ test_that("all keys can be drawn without 'params'", { # for new keys and layout should adjust automatically. # This is also an implicit test whether the key can be constructed without errors keys <- list( - point = draw_key_point(GeomPoint$use_defaults(NULL), params, size), - abline = draw_key_abline(GeomAbline$use_defaults(NULL), params, size), - rect = draw_key_rect(GeomRect$use_defaults(NULL), params, size), - polygon = draw_key_polygon(GeomPolygon$use_defaults(NULL), params, size), - blank = draw_key_blank(GeomBlank$use_defaults(NULL), params, size), - boxplot = draw_key_boxplot(GeomBoxplot$use_defaults(NULL), params, size), - crossbar = draw_key_crossbar(GeomCrossbar$use_defaults(NULL), params, size), - path = draw_key_path(GeomPath$use_defaults(NULL), params, size), - vpath = draw_key_vpath(GeomPath$use_defaults(NULL), params, size), - dotplot = draw_key_dotplot(GeomDotplot$use_defaults(NULL), params, size), - linerange = draw_key_linerange(GeomLinerange$use_defaults(NULL), params, size), - pointrange = draw_key_pointrange(GeomPointrange$use_defaults(NULL), params, size), - smooth = draw_key_smooth(GeomSmooth$use_defaults(NULL), params, size), - text = draw_key_text(GeomText$use_defaults(NULL), params, size), - label = draw_key_label(GeomLabel$use_defaults(NULL), params, size), - vline = draw_key_vline(GeomVline$use_defaults(NULL), params, size), - timeseries = draw_key_timeseries(GeomPath$use_defaults(NULL), params, size) + point = draw_key_point(GeomPoint$use_defaults(NULL), params, size), + abline = draw_key_abline(GeomAbline$use_defaults(NULL), params, size), + rect = draw_key_rect(GeomRect$use_defaults(NULL), params, size), + polygon = draw_key_polygon(GeomPolygon$use_defaults(NULL), params, size), + blank = draw_key_blank(GeomBlank$use_defaults(NULL), params, size), + boxplot = draw_key_boxplot(GeomBoxplot$use_defaults(NULL), params, size), + crossbar = draw_key_crossbar(GeomCrossbar$use_defaults(NULL), params, size), + path = draw_key_path(GeomPath$use_defaults(NULL), params, size), + vpath = draw_key_vpath(GeomPath$use_defaults(NULL), params, size), + dotplot = draw_key_dotplot(GeomDotplot$use_defaults(NULL), params, size), + linerange = draw_key_linerange( + GeomLinerange$use_defaults(NULL), + params, + size + ), + pointrange = draw_key_pointrange( + GeomPointrange$use_defaults(NULL), + params, + size + ), + smooth = draw_key_smooth(GeomSmooth$use_defaults(NULL), params, size), + text = draw_key_text(GeomText$use_defaults(NULL), params, size), + label = draw_key_label(GeomLabel$use_defaults(NULL), params, size), + vline = draw_key_vline(GeomVline$use_defaults(NULL), params, size), + timeseries = draw_key_timeseries(GeomPath$use_defaults(NULL), params, size) ) # Test that we've covered all exported keys above @@ -36,13 +46,17 @@ test_that("all keys can be drawn without 'params'", { expect_in(nse, names(keys)) # Add title to every key - template <- gtable(widths = unit(size, "mm"), heights = unit(c(1, size), c("lines", "mm"))) + template <- gtable( + widths = unit(size, "mm"), + heights = unit(c(1, size), c("lines", "mm")) + ) keys <- Map( function(key, name) { text <- textGrob(name, gp = gpar(fontsize = 8)) gtable_add_grob(template, list(text, key), t = 1:2, l = 1, clip = "off") }, - key = keys, name = names(keys) + key = keys, + name = names(keys) ) # Set layout @@ -54,8 +68,9 @@ test_that("all keys can be drawn without 'params'", { # Render as gtable gt <- gtable_matrix( - name = "layout", grobs = mtx, - widths = unit(rep(size, ncol(mtx)), "mm"), + name = "layout", + grobs = mtx, + widths = unit(rep(size, ncol(mtx)), "mm"), heights = unit(rep(size, nrow(mtx)), "mm") + unit(1, "lines"), clip = "off" ) diff --git a/tests/testthat/test-munch.R b/tests/testthat/test-munch.R index 5c26cab9a6..2fe307169b 100644 --- a/tests/testthat/test-munch.R +++ b/tests/testthat/test-munch.R @@ -1,49 +1,55 @@ test_that("interp works", { - single_interp_test <- function(start, end, n) { - i <- interp(start, end, n) - info <- paste0("start: ", start, "; end: ", end, "; n: ", n) - expect_equal(length(i), n, info = info) - expect_true(start %in% i, info = info) - expect_false(end %in% i, info = info) - expect_true(all(i >= start), info = info) - expect_true(all(i <= end), info = info) - } - single_interp_test(0, 1, 1) - single_interp_test(0, 1, 2) - single_interp_test(0, 1, 7) - single_interp_test(-23, 56, 1) - single_interp_test(-23, 56, 4) - single_interp_test(31.276, 34.443, 1) - single_interp_test(31.276, 34.443, 100) + single_interp_test <- function(start, end, n) { + i <- interp(start, end, n) + info <- paste0("start: ", start, "; end: ", end, "; n: ", n) + expect_equal(length(i), n, info = info) + expect_true(start %in% i, info = info) + expect_false(end %in% i, info = info) + expect_true(all(i >= start), info = info) + expect_true(all(i <= end), info = info) + } + single_interp_test(0, 1, 1) + single_interp_test(0, 1, 2) + single_interp_test(0, 1, 7) + single_interp_test(-23, 56, 1) + single_interp_test(-23, 56, 4) + single_interp_test(31.276, 34.443, 1) + single_interp_test(31.276, 34.443, 100) }) test_that("munch_data works", { - single_munch_test <- function(data, dist=NULL, segment_length = 0.01) { - md <- munch_data(data, dist, segment_length) - # all rows of dat are in md - expect_equal(nrow(merge(md, dat)), nrow(dat)) - expect_true(nrow(md) >= nrow(dat)) - } - dat <- data_frame(x = c(0, 60, 30, 20, 40, 45), - y = c(1, 1, 2, 2, 2, 2), - group = c(1L, 1L, 1L, 2L, 2L, 2L)) - dist <- dist_euclidean(dat$x, dat$y) - dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA - single_munch_test(dat, dist) - single_munch_test(dat, dist, segment_length = 10) - single_munch_test(dat, dist, segment_length = 100) - dist <- coord_polar(theta = "x")$distance(dat$x, dat$y, - list(r.range = range(c(0,dat$y)), - theta.range = range(dat$x))) - dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA - single_munch_test(dat, dist) - single_munch_test(dat, dist, segment_length = 10) - single_munch_test(dat, dist, segment_length = 100) - dist <- coord_polar(theta = "y")$distance(dat$x, dat$y, - list(r.range = range(c(0,dat$x)), - theta.range = range(dat$y))) - dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA - single_munch_test(dat, dist) - single_munch_test(dat, dist, segment_length = 10) - single_munch_test(dat, dist, segment_length = 100) + single_munch_test <- function(data, dist = NULL, segment_length = 0.01) { + md <- munch_data(data, dist, segment_length) + # all rows of dat are in md + expect_equal(nrow(merge(md, dat)), nrow(dat)) + expect_true(nrow(md) >= nrow(dat)) + } + dat <- data_frame( + x = c(0, 60, 30, 20, 40, 45), + y = c(1, 1, 2, 2, 2, 2), + group = c(1L, 1L, 1L, 2L, 2L, 2L) + ) + dist <- dist_euclidean(dat$x, dat$y) + dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA + single_munch_test(dat, dist) + single_munch_test(dat, dist, segment_length = 10) + single_munch_test(dat, dist, segment_length = 100) + dist <- coord_polar(theta = "x")$distance( + dat$x, + dat$y, + list(r.range = range(c(0, dat$y)), theta.range = range(dat$x)) + ) + dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA + single_munch_test(dat, dist) + single_munch_test(dat, dist, segment_length = 10) + single_munch_test(dat, dist, segment_length = 100) + dist <- coord_polar(theta = "y")$distance( + dat$x, + dat$y, + list(r.range = range(c(0, dat$x)), theta.range = range(dat$y)) + ) + dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA + single_munch_test(dat, dist) + single_munch_test(dat, dist, segment_length = 10) + single_munch_test(dat, dist, segment_length = 100) }) diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R index 4939c393b0..013bc0e30e 100644 --- a/tests/testthat/test-patterns.R +++ b/tests/testthat/test-patterns.R @@ -1,5 +1,4 @@ test_that("fill_alpha works as expected", { - expect_snapshot_error( fill_alpha(data.frame(x = 1:10, y = LETTERS[1:10]), 0.5) ) @@ -36,9 +35,15 @@ test_that("fill_alpha works as expected", { # Tiled pattern pat <- pattern( - rectGrob(c(0.25, 0.75), c(0.25, 0.75), width = 0.5, height = 0.5, - gp = gpar(fill = "black", col = NA)), - width = unit(1, "cm"), height = unit(1, "cm"), + rectGrob( + c(0.25, 0.75), + c(0.25, 0.75), + width = 0.5, + height = 0.5, + gp = gpar(fill = "black", col = NA) + ), + width = unit(1, "cm"), + height = unit(1, "cm"), extend = "repeat" ) # Constructed with empty viewport @@ -59,7 +64,6 @@ test_that("fill_alpha works as expected", { }) test_that("geoms can use pattern fills", { - skip_if_not_installed("grid", "4.2.0") skip_if_not_installed("svglite", "2.1.2") # TODO: ideally we should test this on all platforms, but currently they @@ -80,9 +84,15 @@ test_that("geoms can use pattern fills", { linearGradient(group = FALSE), radialGradient(group = FALSE), pattern( - rectGrob(c(0.25, 0.75), c(0.25, 0.75), width = 0.5, height = 0.5, - gp = gpar(fill = "black", col = NA)), - width = unit(1, "cm"), height = unit(1, "cm"), + rectGrob( + c(0.25, 0.75), + c(0.25, 0.75), + width = 0.5, + height = 0.5, + gp = gpar(fill = "black", col = NA) + ), + width = unit(1, "cm"), + height = unit(1, "cm"), extend = "repeat" ), "black" diff --git a/tests/testthat/test-plot-summary-api.R b/tests/testthat/test-plot-summary-api.R index 6d90f9f3ae..a4515dc709 100644 --- a/tests/testthat/test-plot-summary-api.R +++ b/tests/testthat/test-plot-summary-api.R @@ -3,13 +3,13 @@ # Some basic plots that we build on for the tests p <- ggplot(mpg, aes(displ, hwy)) + geom_point() -pw <- p + facet_wrap(~ drv) +pw <- p + facet_wrap(~drv) pg <- p + facet_grid(drv ~ cyl) test_that("layout summary - basic plot", { l <- summarise_layout(ggplot_build(p)) - empty_named_list <- list(a=1)[0] + empty_named_list <- list(a = 1)[0] expect_equal(l$panel, factor(1)) expect_equal(l$row, 1) @@ -63,7 +63,7 @@ test_that("layout summary - facet_grid", { }) test_that("layout summary - free scales", { - pwf <- p + facet_wrap(~ drv, scales = "free") + pwf <- p + facet_wrap(~drv, scales = "free") lwf <- summarise_layout(ggplot_build(pwf)) expect_equal(lwf$xmin, c(1.565, 1.415, 3.640)) expect_equal(lwf$xmax, c(6.735, 5.485, 7.160)) @@ -113,12 +113,20 @@ test_that("coord summary - coord_flip", { test_that("summarise_layers", { l <- summarise_layers(ggplot_build(p)) - expect_equal(l$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) + expect_equal( + l$mapping[[1]], + list(x = quo(displ), y = quo(hwy)), + ignore_attr = TRUE + ) - p2 <- p + geom_point(aes(x = displ/2, y = hwy/2)) + p2 <- p + geom_point(aes(x = displ / 2, y = hwy / 2)) l2 <- summarise_layers(ggplot_build(p2)) - expect_equal(l2$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) + expect_equal( + l2$mapping[[1]], + list(x = quo(displ), y = quo(hwy)), + ignore_attr = TRUE + ) # Here use _identical because the quosures are supposed to be local - expect_identical(l2$mapping[[2]], list(x = quo(displ/2), y = quo(hwy/2))) + expect_identical(l2$mapping[[2]], list(x = quo(displ / 2), y = quo(hwy / 2))) }) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 45a3e1cede..21eed4783b 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -6,7 +6,7 @@ test_that("ggplot() throws informative errors", { test_that("construction have user friendly errors", { skip_if(getRversion() < "4.3.0") - expect_snapshot_error(+ geom_point()) + expect_snapshot_error(+geom_point()) expect_snapshot_error(geom_point() + geom_bar()) expect_snapshot_error(ggplot() + 1) expect_snapshot_error(ggplot() + geom_point) diff --git a/tests/testthat/test-position-dodge2.R b/tests/testthat/test-position-dodge2.R index 5377f14b2d..bf32584db2 100644 --- a/tests/testthat/test-position-dodge2.R +++ b/tests/testthat/test-position-dodge2.R @@ -1,5 +1,4 @@ test_that("find_x_overlaps identifies overlapping groups", { - df1 <- data_frame( xmin = c(1, 3, 6, 11, 13), xmax = c(5, 7, 9, 15, 16) @@ -78,7 +77,7 @@ test_that("boxes in facetted plots keep the correct width", { ) p <- ggplot(df, aes(subgroup, value)) + - facet_wrap( ~ group) + + facet_wrap(~group) + geom_boxplot() d <- get_layer_data(p) @@ -111,7 +110,7 @@ test_that("NA values are given their own group", { expect_equal(find_x_overlaps(df), seq_len(4)) }) -test_that("groups are different when two blocks have externall touching point",{ +test_that("groups are different when two blocks have externall touching point", { df1 <- data.frame( xmin = c(0.5, 1.5), xmax = c(1.5, 2.5) diff --git a/tests/testthat/test-position-jitter.R b/tests/testthat/test-position-jitter.R index 7442c7877c..bc9589e520 100644 --- a/tests/testthat/test-position-jitter.R +++ b/tests/testthat/test-position-jitter.R @@ -1,14 +1,13 @@ test_that("automatic jitter width considers panels", { - df <- data.frame(x = c(1, 2, 100, 200), f = c("A", "A", "B", "B")) - auto <- position_jitter(seed = 0) + auto <- position_jitter(seed = 0) fixed <- position_jitter(seed = 0, width = 0.5) p <- ggplot(df, aes(x, 1)) + facet_wrap(vars(f)) fixed <- layer_data(p + geom_point(position = fixed))$x - df$x - auto <- layer_data(p + geom_point(position = auto))$x - df$x + auto <- layer_data(p + geom_point(position = auto))$x - df$x # Magic number 0.4 comes from default resolution multiplier expect_equal(fixed / 0.5, auto / c(0.4, 0.4, 40, 40)) diff --git a/tests/testthat/test-position-nudge.R b/tests/testthat/test-position-nudge.R index 564595b36e..05d2d837e4 100644 --- a/tests/testthat/test-position-nudge.R +++ b/tests/testthat/test-position-nudge.R @@ -28,7 +28,6 @@ test_that("nudging works in both dimensions simultaneously", { expect_equal(data$y, c(1, 3, 3)) expect_equal(data$ymin, c(1, 3, 3)) expect_equal(data$ymax, c(1, 3, 3)) - }) test_that("nudging works in individual dimensions", { @@ -47,7 +46,11 @@ test_that("nudging works in individual dimensions", { # multiple nudge values, including zero p <- ggplot(df, aes(x = x, xmax = x, xmin = x)) + - layer(geom = Geom, stat = StatIdentity, position = position_nudge(x = c(0, -1, -2))) + layer( + geom = Geom, + stat = StatIdentity, + position = position_nudge(x = c(0, -1, -2)) + ) data <- get_layer_data(p) @@ -55,7 +58,6 @@ test_that("nudging works in individual dimensions", { expect_equal(data$xmin, c(1, 1, 1)) expect_equal(data$xmax, c(1, 1, 1)) - # nudging in y # use an empty layer so can test individual aesthetics p <- ggplot(df, aes(y = x, ymax = x, ymin = x)) + @@ -69,12 +71,15 @@ test_that("nudging works in individual dimensions", { # multiple nudge values, including zero p <- ggplot(df, aes(y = x, ymax = x, ymin = x)) + - layer(geom = Geom, stat = StatIdentity, position = position_nudge(y = c(0, -1, -2))) + layer( + geom = Geom, + stat = StatIdentity, + position = position_nudge(y = c(0, -1, -2)) + ) data <- get_layer_data(p) expect_equal(data$y, c(1, 1, 1)) expect_equal(data$ymin, c(1, 1, 1)) expect_equal(data$ymax, c(1, 1, 1)) - }) diff --git a/tests/testthat/test-position-stack.R b/tests/testthat/test-position-stack.R index fd04c2326d..926f954eaf 100644 --- a/tests/testthat/test-position-stack.R +++ b/tests/testthat/test-position-stack.R @@ -13,9 +13,9 @@ test_that("data keeps its order after stacking", { test_that("negative and positive values are handled separately", { df <- data_frame( - x = c(1,1,1,2,2), - g = c(1,2,3,1,2), - y = c(1,-1,1,2,-3) + x = c(1, 1, 1, 2, 2), + g = c(1, 2, 3, 1, 2), + y = c(1, -1, 1, 2, -3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col() dat <- get_layer_data(p) @@ -75,7 +75,7 @@ test_that("position_fill() handles one group per position case", { test_that("Stacking produces the expected output", { data <- data_frame( x = rep(1:4, each = 2), - category = rep(c("A","B"), 4), + category = rep(c("A", "B"), 4), value = c(0, 0, 2, 1, 3, 6, -4, 3) ) p <- ggplot(data, aes(x = x, y = value, fill = category)) + diff --git a/tests/testthat/test-position_dodge.R b/tests/testthat/test-position_dodge.R index 878ee6d155..a723dc00a5 100644 --- a/tests/testthat/test-position_dodge.R +++ b/tests/testthat/test-position_dodge.R @@ -7,11 +7,13 @@ test_that("can control whether to preserve total or individual width", { geom_bar(position = position_dodge(preserve = "single"), width = 1) expect_equal(get_layer_data(p_total)$x, new_mapped_discrete(c(1, 1.75, 2.25))) - expect_equal(get_layer_data(p_single)$x, new_mapped_discrete(c(0.75, 1.75, 2.25))) + expect_equal( + get_layer_data(p_single)$x, + new_mapped_discrete(c(0.75, 1.75, 2.25)) + ) }) test_that("position_dodge() can dodge points vertically", { - df <- data.frame(x = c(1, 2, 3, 4), y = c("a", "a", "b", "b")) horizontal <- ggplot(df, aes(y, x, group = seq_along(x))) + @@ -19,13 +21,19 @@ test_that("position_dodge() can dodge points vertically", { vertical <- ggplot(df, aes(x, y, group = seq_along(x))) + geom_point(position = position_dodge(width = 1, orientation = "y")) - expect_equal(layer_data(horizontal)$x, c(0.75, 1.25, 1.75, 2.25), ignore_attr = "class") - expect_equal(layer_data(vertical)$y, c(0.75, 1.25, 1.75, 2.25), ignore_attr = "class") - + expect_equal( + layer_data(horizontal)$x, + c(0.75, 1.25, 1.75, 2.25), + ignore_attr = "class" + ) + expect_equal( + layer_data(vertical)$y, + c(0.75, 1.25, 1.75, 2.25), + ignore_attr = "class" + ) }) test_that("position_dodge() can reverse the dodge order", { - df <- data.frame(x = c(1, 2, 2, 3, 3), group = c("A", "A", "B", "B", "C")) # Use label as easy to track identifier @@ -39,8 +47,7 @@ test_that("position_dodge() can reverse the dodge order", { }) test_that("position_dodge() can use the order aesthetic", { - - major <- c(1,1,1,2,2,3,3,4,4,5,6,7) + major <- c(1, 1, 1, 2, 2, 3, 3, 4, 4, 5, 6, 7) minor <- c(1:3, 1:2, 1, 3, 2:3, 1:3) df <- data_frame0( x = LETTERS[major], @@ -54,7 +61,6 @@ test_that("position_dodge() can use the order aesthetic", { }) test_that("position_dodge warns about missing required aesthetics", { - # Bit of a contrived geom to not have a required 'x' aesthetic GeomDummy <- ggproto(NULL, GeomPoint, required_aes = NULL, optional_aes = "x") diff --git a/tests/testthat/test-prohibited-functions.R b/tests/testthat/test-prohibited-functions.R index 278dfbd8fc..f1ee1d0d63 100644 --- a/tests/testthat/test-prohibited-functions.R +++ b/tests/testthat/test-prohibited-functions.R @@ -29,19 +29,22 @@ get_n_data.frame <- function(f) { idx_base <- d$token == "SYMBOL_PACKAGE" & d$text == "base" idx_colons <- d$token == "NS_GET" & d$text == "::" # exclude the case when the `data.frame` is prefixed with `base::` - idx_base_prefixed <- c(FALSE, FALSE, idx_base[1:(nrow(d) - 2)]) & c(FALSE, idx_colons[1:(nrow(d) - 1)]) + idx_base_prefixed <- c(FALSE, FALSE, idx_base[1:(nrow(d) - 2)]) & + c(FALSE, idx_colons[1:(nrow(d) - 1)]) idx_data.frame <- d$token == "SYMBOL_FUNCTION_CALL" & d$text == "data.frame" sum(idx_data.frame & !idx_base_prefixed) } test_that("`get_n_*() detects number of calls properly", { - tmp <- withr::local_tempfile(lines = c( - 'stop("foo!")', - 'warning("bar!")', - "data.frame(x = 1)", - "base::data.frame(x = 1)" # this is not counted - )) + tmp <- withr::local_tempfile( + lines = c( + 'stop("foo!")', + 'warning("bar!")', + "data.frame(x = 1)", + "base::data.frame(x = 1)" # this is not counted + ) + ) expect_equal(get_n_stop(tmp), 1) expect_equal(get_n_warning(tmp), 1) @@ -50,8 +53,8 @@ test_that("`get_n_*() detects number of calls properly", { # Pattern is needed filter out files such as ggplot2.rdb, which is created when running covr::package_coverage() R_paths <- c( - "../../R", # in the case of devtools::test() - "../../00_pkg_src/ggplot2/R" # in the case of R CMD check + "../../R", # in the case of devtools::test() + "../../00_pkg_src/ggplot2/R" # in the case of R CMD check ) R_files <- list.files(R_paths, pattern = ".*\\.(R|r)$", full.names = TRUE) @@ -94,7 +97,6 @@ test_that("do not use data.frame(), use `data_frame()` or `new_data_frame()`, or }) test_that("No new argument names use underscores", { - # For context: # We decided to use dot.case for argument names in exported functions, # not snake_case. diff --git a/tests/testthat/test-qplot.R b/tests/testthat/test-qplot.R index 59527d1989..94daf0bc81 100644 --- a/tests/testthat/test-qplot.R +++ b/tests/testthat/test-qplot.R @@ -3,7 +3,6 @@ test_that("qplot works with variables in data frame and parent env", { y <- 1:10 b <- 1:10 - lifecycle::expect_deprecated( p <- qplot(x, y, data = df) ) diff --git a/tests/testthat/test-scale-binned.R b/tests/testthat/test-scale-binned.R index 22ce6ef12a..282954192a 100644 --- a/tests/testthat/test-scale-binned.R +++ b/tests/testthat/test-scale-binned.R @@ -1,7 +1,9 @@ test_that("binned scales only support continuous data", { p <- ggplot(mtcars) + geom_bar(aes(as.character(gear))) + scale_x_binned() expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg, colour = as.character(gear))) + scale_color_binned() + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg, colour = as.character(gear))) + + scale_color_binned() expect_snapshot_error(ggplot_build(p)) }) @@ -16,15 +18,14 @@ test_that("binned scales limits can expand to fit breaks", { new_limits <- scale$get_limits() # Positive control - expect_equal(limits, c(14, 29)) + expect_equal(limits, c(14, 29)) # Test case, should have been updated in break calculation expect_equal(new_limits, c(14, 30)) # Negative control # Now, new limits should not be updated because limits were given instead # of computed - scale <- scale_x_binned(right = FALSE, show.limits = TRUE, - limits = c(14, 29)) + scale <- scale_x_binned(right = FALSE, show.limits = TRUE, limits = c(14, 29)) limits <- scale$get_limits() breaks <- scale$get_breaks() new_limits <- scale$get_limits() @@ -70,7 +71,6 @@ test_that("binned scales can calculate breaks with reverse transformation", { }) test_that('binned scales can calculate breaks on dates', { - data <- seq(as.Date("2000-01-01"), as.Date("2020-01-01"), length.out = 100) scale <- scale_x_binned(transform = "date") diff --git a/tests/testthat/test-scale-colour.R b/tests/testthat/test-scale-colour.R index bcdbc90892..327f1a69a5 100644 --- a/tests/testthat/test-scale-colour.R +++ b/tests/testthat/test-scale-colour.R @@ -6,7 +6,9 @@ test_that("type argument is checked for proper input", { suppressWarnings(scale_fill_continuous(type = geom_point)) ) expect_snapshot_error( - scale_colour_binned(type = function(...) scale_colour_binned(aesthetics = c("fill", "point_colour"))) + scale_colour_binned(type = function(...) { + scale_colour_binned(aesthetics = c("fill", "point_colour")) + }) ) expect_snapshot_error( scale_fill_binned(type = scale_fill_brewer) @@ -20,9 +22,8 @@ test_that("type argument is checked for proper input", { }) test_that("palette arguments can take alternative input", { - cols <- c("red", "gold", "green", "cyan", "blue", "magenta") - hex <- alpha(cols, 1) + hex <- alpha(cols, 1) sc <- scale_colour_continuous(palette = cols) test <- sc$palette(seq(0, 1, length.out = length(cols))) @@ -47,5 +48,4 @@ test_that("palette arguments can take alternative input", { sc <- scale_fill_discrete(palette = cols) test <- sc$palette(length(cols)) expect_equal(alpha(test, 1), hex) - }) diff --git a/tests/testthat/test-scale-date.R b/tests/testthat/test-scale-date.R index 48259e3261..b7e73061d1 100644 --- a/tests/testthat/test-scale-date.R +++ b/tests/testthat/test-scale-date.R @@ -10,8 +10,9 @@ df <- data_frame( ) test_that("inherits timezone from data", { - if (!is.null(attr(df$time1, "tzone"))) - skip("Local time zone not available") + if (!is.null(attr(df$time1, "tzone"))) { + skip("Local time zone not available") + } # Local time p <- ggplot(df, aes(y = y)) + geom_point(aes(time1)) diff --git a/tests/testthat/test-scale-discrete.R b/tests/testthat/test-scale-discrete.R index 46e5c83d16..2bec16af4c 100644 --- a/tests/testthat/test-scale-discrete.R +++ b/tests/testthat/test-scale-discrete.R @@ -56,7 +56,10 @@ test_that("discrete ranges also encompass continuous values", { expect_equal(x_range(base + geom_point(aes(x1))), c(1, 3)) expect_equal(x_range(base + geom_point(aes(x2))), c(0, 4)) - expect_equal(x_range(base + geom_point(aes(x1)) + geom_point(aes(x2))), c(0, 4)) + expect_equal( + x_range(base + geom_point(aes(x1)) + geom_point(aes(x2))), + c(0, 4) + ) }) test_that("discrete ranges have limits even when all values are continuous", { @@ -67,7 +70,8 @@ test_that("discrete ranges have limits even when all values are continuous", { test_that("discrete scale shrinks to range when setting limits", { df <- data_frame(x = letters[1:10], y = 1:10) - p <- ggplot(df, aes(x, y)) + geom_point() + + p <- ggplot(df, aes(x, y)) + + geom_point() + scale_x_discrete(limits = c("a", "b")) expect_equal(get_panel_scales(p)$x$dimension(c(0, 1)), c(0, 3)) @@ -87,14 +91,18 @@ test_that("discrete non-position scales can accept functional limits", { test_that("discrete scale defaults can be set globally", { df <- data_frame( - x = 1:4, y = 1:4, + x = 1:4, + y = 1:4, two = c("a", "b", "a", "b"), four = c("a", "b", "c", "d") ) withr::with_options( - list(ggplot2.discrete.fill = c("#FFFFFF", "#000000"), - ggplot2.discrete.colour = c("#FFFFFF", "#000000")), { + list( + ggplot2.discrete.fill = c("#FFFFFF", "#000000"), + ggplot2.discrete.colour = c("#FFFFFF", "#000000") + ), + { # nlevels == ncodes two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point() expect_equal(get_layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) @@ -104,7 +112,10 @@ test_that("discrete scale defaults can be set globally", { four_default <- ggplot(df, aes(x, y, colour = four, fill = four)) + geom_point() four_hue <- four_default + scale_fill_hue() - expect_equal(get_layer_data(four_default)$colour, get_layer_data(four_hue)$colour) + expect_equal( + get_layer_data(four_default)$colour, + get_layer_data(four_hue)$colour + ) } ) @@ -118,7 +129,8 @@ test_that("discrete scale defaults can be set globally", { c("#FFFFFF", "#000000"), c("#FF0000", "#00FF00", "#0000FF", "#FF00FF") ) - ), { + ), + { # nlevels == 2 two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point() expect_equal(get_layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) @@ -126,15 +138,24 @@ test_that("discrete scale defaults can be set globally", { # nlevels == 4 four <- ggplot(df, aes(x, y, colour = four, fill = four)) + geom_point() - expect_equal(get_layer_data(four)$colour, c("#FF0000", "#00FF00", "#0000FF", "#FF00FF")) - expect_equal(get_layer_data(four)$fill, c("#FF0000", "#00FF00", "#0000FF", "#FF00FF")) + expect_equal( + get_layer_data(four)$colour, + c("#FF0000", "#00FF00", "#0000FF", "#FF00FF") + ) + expect_equal( + get_layer_data(four)$fill, + c("#FF0000", "#00FF00", "#0000FF", "#FF00FF") + ) } ) }) test_that("Scale is checked in default colour scale", { # Check scale type - expect_snapshot(scale_colour_discrete(type = scale_colour_gradient), error = TRUE) + expect_snapshot( + scale_colour_discrete(type = scale_colour_gradient), + error = TRUE + ) expect_snapshot(scale_fill_discrete(type = scale_fill_gradient), error = TRUE) # Check aesthetic @@ -165,7 +186,6 @@ test_that("mapped_discrete vectors behaves as predicted", { # Palettes ---------------------------------------------------------------- test_that("palettes work for discrete scales", { - df <- data.frame(x = c("A", "B", "C"), y = 1:3) values <- c(1, 10, 100) @@ -186,7 +206,6 @@ test_that("palettes work for discrete scales", { }) test_that("invalid palettes trigger errors", { - df <- data.frame(x = c("A", "B", "C"), y = 1:3) p <- ggplot(df, aes(x, y)) + @@ -202,4 +221,3 @@ test_that("invalid palettes trigger errors", { error = TRUE ) }) - diff --git a/tests/testthat/test-scale-expansion.R b/tests/testthat/test-scale-expansion.R index 331c6a651d..07ac9378ed 100644 --- a/tests/testthat/test-scale-expansion.R +++ b/tests/testthat/test-scale-expansion.R @@ -1,4 +1,3 @@ - test_that("expand_scale() produces a deprecation warning", { lifecycle::expect_deprecated(expand_scale()) }) @@ -11,18 +10,34 @@ test_that("expansion() checks input", { # Expanding continuous scales ----------------------------------------- test_that("expand_limits_continuous() can override limits", { - expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(NA, NA)), c(1, 2)) - expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(NA, 3)), c(1, 3)) - expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(0, NA)), c(0, 2)) + expect_identical( + expand_limits_continuous(c(1, 2), coord_limits = c(NA, NA)), + c(1, 2) + ) + expect_identical( + expand_limits_continuous(c(1, 2), coord_limits = c(NA, 3)), + c(1, 3) + ) + expect_identical( + expand_limits_continuous(c(1, 2), coord_limits = c(0, NA)), + c(0, 2) + ) }) test_that("expand_limits_continuous() expands limits", { - expect_identical(expand_limits_continuous(c(1, 2), expand = expansion(add = 1)), c(0, 3)) + expect_identical( + expand_limits_continuous(c(1, 2), expand = expansion(add = 1)), + c(0, 3) + ) }) test_that("expand_limits_continuous() expands coord-supplied limits", { expect_identical( - expand_limits_continuous(c(1, 2), coord_limits = c(0, 4), expand = expansion(add = 1)), + expand_limits_continuous( + c(1, 2), + coord_limits = c(0, 4), + expand = expansion(add = 1) + ), c(-1, 5) ) }) @@ -59,62 +74,117 @@ test_that("introduced non-finite values fall back on scale limits", { # Expanding discrete scales ----------------------------------------- test_that("expand_limits_discrete() can override limits with an empty range", { - expect_identical(expand_limits_discrete(NULL, coord_limits = c(-1, 8)), c(-1, 8)) + expect_identical( + expand_limits_discrete(NULL, coord_limits = c(-1, 8)), + c(-1, 8) + ) }) test_that("expand_limits_discrete() can override limits with a discrete range", { - expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(NA, NA)), c(1, 2)) - expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(NA, 3)), c(1, 3)) - expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(3, NA)), c(2, 3)) + expect_identical( + expand_limits_discrete(c("one", "two"), coord_limits = c(NA, NA)), + c(1, 2) + ) + expect_identical( + expand_limits_discrete(c("one", "two"), coord_limits = c(NA, 3)), + c(1, 3) + ) + expect_identical( + expand_limits_discrete(c("one", "two"), coord_limits = c(3, NA)), + c(2, 3) + ) }) test_that("expand_limits_discrete() can override limits with a continuous range", { expect_identical( - expand_limits_discrete(NULL, coord_limits = c(NA, NA), range_continuous = c(1, 2)), + expand_limits_discrete( + NULL, + coord_limits = c(NA, NA), + range_continuous = c(1, 2) + ), c(1, 2) ) expect_identical( - expand_limits_discrete(NULL, coord_limits = c(NA, 3), range_continuous = c(1, 2)), + expand_limits_discrete( + NULL, + coord_limits = c(NA, 3), + range_continuous = c(1, 2) + ), c(1, 3) ) expect_identical( - expand_limits_discrete(NULL, coord_limits = c(0, NA), range_continuous = c(1, 2)), + expand_limits_discrete( + NULL, + coord_limits = c(0, NA), + range_continuous = c(1, 2) + ), c(0, 2) ) }) test_that("expand_limits_discrete() can override limits with a both discrete and continuous ranges", { expect_identical( - expand_limits_discrete(c("one", "two"), coord_limits = c(NA, NA), range_continuous = c(1, 2)), + expand_limits_discrete( + c("one", "two"), + coord_limits = c(NA, NA), + range_continuous = c(1, 2) + ), c(1, 2) ) expect_identical( - expand_limits_discrete(c("one", "two"), coord_limits = c(NA, 3), range_continuous = c(1, 2)), + expand_limits_discrete( + c("one", "two"), + coord_limits = c(NA, 3), + range_continuous = c(1, 2) + ), c(1, 3) ) expect_identical( - expand_limits_discrete(c("one", "two"), coord_limits = c(0, NA), range_continuous = c(1, 2)), + expand_limits_discrete( + c("one", "two"), + coord_limits = c(0, NA), + range_continuous = c(1, 2) + ), c(0, 2) ) expect_identical( - expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(0, 3)), + expand_limits_discrete( + 1:2, + range_continuous = c(1, 2), + continuous_limits = c(0, 3) + ), c(0, 3) ) expect_identical( - expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(NA, 4)), + expand_limits_discrete( + 1:2, + range_continuous = c(1, 2), + continuous_limits = c(NA, 4) + ), c(1, 4) ) expect_identical( - expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(0, NA)), + expand_limits_discrete( + 1:2, + range_continuous = c(1, 2), + continuous_limits = c(0, NA) + ), c(0, 2) ) expect_identical( - expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(NA_real_, NA_real_)), + expand_limits_discrete( + 1:2, + range_continuous = c(1, 2), + continuous_limits = c(NA_real_, NA_real_) + ), c(1, 2) ) expect_identical( - expand_limits_discrete(1:2, range_continuous = 1:2, - continuous_limits = function(x) x + c(-1, 1)), + expand_limits_discrete( + 1:2, + range_continuous = 1:2, + continuous_limits = function(x) x + c(-1, 1) + ), c(0, 3) ) }) diff --git a/tests/testthat/test-scale-gradient.R b/tests/testthat/test-scale-gradient.R index 771490f945..c1ccc7ac9e 100644 --- a/tests/testthat/test-scale-gradient.R +++ b/tests/testthat/test-scale-gradient.R @@ -11,7 +11,6 @@ test_that("points outside the limits are plotted as NA", { }) test_that("midpoints are transformed", { - scale <- scale_colour_gradient2(midpoint = 1, transform = "identity") scale$train(c(0, 3)) expect_equal(scale$rescale(c(0, 3)), c(0.25, 1)) diff --git a/tests/testthat/test-scale-manual.R b/tests/testthat/test-scale-manual.R index 75f4879607..89d2c6b55d 100644 --- a/tests/testthat/test-scale-manual.R +++ b/tests/testthat/test-scale-manual.R @@ -1,36 +1,43 @@ test_that("names of values used in manual scales", { - s1 <- scale_colour_manual(values = c("8" = "c", "4" = "a", "6" = "b")) - s1$train(c("4", "6", "8")) - expect_equal(s1$map(c("4", "6", "8")), c("a", "b", "c")) - - s2 <- scale_colour_manual(values = c("8" = "c", "4" = "a", "6" = "b"), na.value = NA) - s2$train(c("4", "8")) - expect_equal(s2$map(c("4", "6", "8")), c("a", NA, "c")) - expect_equal(s2$get_limits(), c("4", "8")) - - s3 <- scale_colour_manual(values = c("8" = "c", "4" = "a", "6" = "b"), na.value = "x") - s3$train(c("4", "8", NA)) - expect_equal(s3$map(c("4", "6", "8")), c("a", "x", "c")) - expect_equal(s3$get_limits(), c("4", "8", NA)) - - # Names do not match data - s <- scale_colour_manual(values = c("foo" = "x", "bar" = "y")) - s$train(c("A", "B")) - expect_snapshot_warning( - expect_equal(s$get_limits(), character()) - ) + s1 <- scale_colour_manual(values = c("8" = "c", "4" = "a", "6" = "b")) + s1$train(c("4", "6", "8")) + expect_equal(s1$map(c("4", "6", "8")), c("a", "b", "c")) + + s2 <- scale_colour_manual( + values = c("8" = "c", "4" = "a", "6" = "b"), + na.value = NA + ) + s2$train(c("4", "8")) + expect_equal(s2$map(c("4", "6", "8")), c("a", NA, "c")) + expect_equal(s2$get_limits(), c("4", "8")) + + s3 <- scale_colour_manual( + values = c("8" = "c", "4" = "a", "6" = "b"), + na.value = "x" + ) + s3$train(c("4", "8", NA)) + expect_equal(s3$map(c("4", "6", "8")), c("a", "x", "c")) + expect_equal(s3$get_limits(), c("4", "8", NA)) + + # Names do not match data + s <- scale_colour_manual(values = c("foo" = "x", "bar" = "y")) + s$train(c("A", "B")) + expect_snapshot_warning( + expect_equal(s$get_limits(), character()) + ) }) -dat <- data_frame(g = c("B","A","A")) +dat <- data_frame(g = c("B", "A", "A")) p <- ggplot(dat, aes(g, fill = g)) + geom_bar() col <- c("A" = "red", "B" = "green", "C" = "blue") cols <- function(x) ggplot_build(x)@data[[1]][, "fill"] test_that("named values work regardless of order", { - fill_scale <- function(order) scale_fill_manual(values = col[order], - na.value = "black") + fill_scale <- function(order) { + scale_fill_manual(values = col[order], na.value = "black") + } # Order of value vector shouldn't matter expect_equal(cols(p + fill_scale(1:3)), c("red", "green")) @@ -54,15 +61,19 @@ test_that("insufficient values raise an error", { df <- data_frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL)) p <- ggplot(df, aes(x, y, colour = z)) + geom_point() - expect_snapshot(ggplot_build(p + scale_colour_manual(values = "black")), error = TRUE) + expect_snapshot( + ggplot_build(p + scale_colour_manual(values = "black")), + error = TRUE + ) # Should be sufficient ggplot_build(p + scale_colour_manual(values = c("black", "black"))) }) test_that("values are matched when scale contains more unique values than are in the data", { - s <- scale_colour_manual(values = c("8" = "c", "4" = "a", - "22" = "d", "6" = "b")) + s <- scale_colour_manual( + values = c("8" = "c", "4" = "a", "22" = "d", "6" = "b") + ) s$train(c("4", "6", "8")) expect_equal(s$map(c("4", "6", "8")), c("a", "b", "c")) }) @@ -76,7 +87,10 @@ test_that("generic scale can be used in place of aesthetic-specific scales", { p2 <- ggplot(df, aes(z, z, shape = x, color = y, alpha = z)) + scale_discrete_manual(aesthetics = "shape", values = 1:3) + - scale_discrete_manual(aesthetics = "colour", values = c("red", "green", "blue")) + + scale_discrete_manual( + aesthetics = "colour", + values = c("red", "green", "blue") + ) + scale_discrete_manual(aesthetics = "alpha", values = c(0.2, 0.4, 0.6)) expect_equal(get_layer_data(p1), get_layer_data(p2)) @@ -102,12 +116,20 @@ test_that("unnamed values match breaks in manual scales", { test_that("limits works (#3262)", { # named character vector - s1 <- scale_colour_manual(values = c("8" = "c", "4" = "a", "6" = "b"), limits = c("4", "8"), na.value = NA) + s1 <- scale_colour_manual( + values = c("8" = "c", "4" = "a", "6" = "b"), + limits = c("4", "8"), + na.value = NA + ) s1$train(c("4", "6", "8")) expect_equal(s1$map(c("4", "6", "8")), c("a", NA, "c")) # unnamed character vector - s2 <- scale_colour_manual(values = c("c", "a", "b"), limits = c("4", "8"), na.value = NA) + s2 <- scale_colour_manual( + values = c("c", "a", "b"), + limits = c("4", "8"), + na.value = NA + ) s2$train(c("4", "6", "8")) expect_equal(s2$map(c("4", "6", "8")), c("c", NA, "a")) }) @@ -153,31 +175,33 @@ test_that("limits and breaks (#4619)", { }) test_that("NAs from palette are not translated (#5929)", { - s1 <- scale_colour_manual( values = c("4" = "a", "6" = NA, "8" = "c"), - na.translate = TRUE, na.value = "x" + na.translate = TRUE, + na.value = "x" ) s1$train(c("8", "6", "4")) expect_equal(s1$map(c("4", "6", "8", "10")), c("a", NA, "c", "x")) s2 <- scale_colour_manual( values = c("4" = "a", "6" = NA, "8" = "c"), - na.translate = TRUE, na.value = NA + na.translate = TRUE, + na.value = NA ) s2$train(c("8", "6", "4")) expect_equal(s2$map(c("4", "6", "8", "10")), c("a", NA, "c", NA)) s3 <- scale_colour_manual( values = c("4" = "a", "6" = NA, "8" = "c"), - na.translate = FALSE, na.value = "x" + na.translate = FALSE, + na.value = "x" ) s3$train(c("8", "6", "4")) expect_equal(s3$map(c("4", "6", "8", "10")), c("a", NA, "c", NA)) }) test_that("numeric linetype palettes are mapped correctly (#6096)", { - x <- c(LETTERS[1:3], NA) + x <- c(LETTERS[1:3], NA) sc <- scale_linetype_manual(values = 1:5) sc$train(x) expect_equal(sc$map(x), c(1L, 2L, 3L, NA)) diff --git a/tests/testthat/test-scale_date.R b/tests/testthat/test-scale_date.R index b9a788bb70..882d3f7b5d 100644 --- a/tests/testthat/test-scale_date.R +++ b/tests/testthat/test-scale_date.R @@ -1,7 +1,5 @@ - test_that("date(time) scales coerce data types", { - - date <- as.Date("2024-11-11") + date <- as.Date("2024-11-11") datetime <- as.POSIXct(date) sc <- scale_x_datetime() @@ -11,7 +9,6 @@ test_that("date(time) scales coerce data types", { sc <- scale_x_date() df <- sc$transform_df(data_frame0(x = datetime)) expect_equal(df$x, as.numeric(date)) - }) # Visual tests ------------------------------------------------------------ @@ -22,34 +19,41 @@ test_that("date scale draws correctly", { set.seed(321) df <- data_frame( - dx = seq(as.Date("2012-02-29"), length.out = 100, by = "1 day")[sample(100, 50)], + dx = seq(as.Date("2012-02-29"), length.out = 100, by = "1 day")[sample( + 100, + 50 + )], price = runif(50) ) df <- df[order(df$dx), ] dt <- ggplot(df, aes(dx, price)) + geom_line() - expect_doppelganger("dates along x, default breaks", - dt - ) - expect_doppelganger("scale_x_date(breaks = breaks_width(\"2 weeks\"))", + expect_doppelganger("dates along x, default breaks", dt) + expect_doppelganger( + "scale_x_date(breaks = breaks_width(\"2 weeks\"))", dt + scale_x_date(breaks = breaks_width("2 weeks")) ) - expect_doppelganger("scale_x_date(breaks = \"3 weeks\")", + expect_doppelganger( + "scale_x_date(breaks = \"3 weeks\")", dt + scale_x_date(date_breaks = "3 weeks") ) - expect_doppelganger("scale_x_date(labels = label_date(\"%m/%d\"))", + expect_doppelganger( + "scale_x_date(labels = label_date(\"%m/%d\"))", dt + scale_x_date(labels = label_date("%m/%d")) ) - expect_doppelganger("scale_x_date(labels = label_date(\"%W\"), \"week\")", + expect_doppelganger( + "scale_x_date(labels = label_date(\"%W\"), \"week\")", dt + scale_x_date(labels = label_date("%W"), "week") ) dt <- ggplot(df, aes(price, dx)) + geom_line() expect_doppelganger("dates along y, default breaks", dt) - expect_doppelganger("scale_y_date(breaks = breaks_width(\"2 weeks\"))", + expect_doppelganger( + "scale_y_date(breaks = breaks_width(\"2 weeks\"))", dt + scale_y_date(breaks = breaks_width("2 weeks")) ) - expect_doppelganger("scale_y_date(breaks = \"3 weeks\")", + expect_doppelganger( + "scale_y_date(breaks = \"3 weeks\")", dt + scale_y_date(date_breaks = "3 weeks") ) }) diff --git a/tests/testthat/test-scales-breaks-labels.R b/tests/testthat/test-scales-breaks-labels.R index 1aaf798e52..ab1f126857 100644 --- a/tests/testthat/test-scales-breaks-labels.R +++ b/tests/testthat/test-scales-breaks-labels.R @@ -27,7 +27,6 @@ test_that("labels don't have extra spaces", { }) test_that("out-of-range breaks are dropped", { - # Limits are explicitly specified, automatic labels sc <- scale_x_continuous(breaks = 1:5, limits = c(2, 4)) bi <- sc$break_info() @@ -36,14 +35,22 @@ test_that("out-of-range breaks are dropped", { expect_equal(bi$major_source, 2:4) # Limits and labels are explicitly specified - sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5], limits = c(2, 4)) + sc <- scale_x_continuous( + breaks = 1:5, + labels = letters[1:5], + limits = c(2, 4) + ) bi <- sc$break_info() expect_equal(bi$labels, letters[2:4]) expect_equal(bi$major, c(0, 0.5, 1)) expect_equal(bi$major_source, 2:4) # Limits are specified, and all breaks are out of range - sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)], limits = c(2, 4)) + sc <- scale_x_continuous( + breaks = c(1, 5), + labels = letters[c(1, 5)], + limits = c(2, 4) + ) bi <- sc$break_info() expect_length(bi$labels, 0) expect_length(bi$major, 0) @@ -67,7 +74,7 @@ test_that("out-of-range breaks are dropped", { expect_equal(bi$major, c(0, 0.5, 1)) # Limits aren't specified, and all breaks are out of range of data - sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)]) + sc <- scale_x_continuous(breaks = c(1, 5), labels = letters[c(1, 5)]) sc$train_df(data_frame(x = 2:4)) bi <- sc$break_info() expect_length(bi$labels, 0) @@ -91,7 +98,6 @@ init_scale <- function(...) { } test_that("discrete labels match breaks", { - sc <- init_scale(breaks = 0:5 * 10) expect_length(sc$get_breaks(), 5) expect_length(sc$get_labels(), 5) @@ -102,8 +108,9 @@ test_that("discrete labels match breaks", { expect_length(sc$get_labels(), 5) expect_equal(sc$get_labels(), letters[2:6]) - sc <- init_scale(breaks = 0:5 * 10, labels = - function(x) paste(x, "-", sep = "")) + sc <- init_scale(breaks = 0:5 * 10, labels = function(x) { + paste(x, "-", sep = "") + }) expect_equal(sc$get_labels(), c("10-", "20-", "30-", "40-", "50-")) pick_5 <- function(x) sample(x, 5) @@ -140,11 +147,20 @@ test_that("passing continuous limits to a discrete scale generates a warning", { test_that("suppressing breaks, minor_breask, and labels works", { expect_null(scale_x_continuous(breaks = NULL, limits = c(1, 3))$get_breaks()) - expect_null(scale_x_discrete(breaks = NULL, limits = c("one", "three"))$get_breaks()) - expect_null(scale_x_continuous(minor_breaks = NULL, limits = c(1, 3))$get_breaks_minor()) + expect_null(scale_x_discrete( + breaks = NULL, + limits = c("one", "three") + )$get_breaks()) + expect_null(scale_x_continuous( + minor_breaks = NULL, + limits = c(1, 3) + )$get_breaks_minor()) expect_null(scale_x_continuous(labels = NULL, limits = c(1, 3))$get_labels()) - expect_null(scale_x_discrete(labels = NULL, limits = c("one", "three"))$get_labels()) + expect_null(scale_x_discrete( + labels = NULL, + limits = c("one", "three") + )$get_labels()) # date, datetime lims <- as.Date(c("2000/1/1", "2000/2/1")) @@ -159,7 +175,10 @@ test_that("suppressing breaks, minor_breask, and labels works", { scale_x_date(labels = NA, limits = lims)$get_labels(), error = TRUE ) - expect_null(scale_x_date(minor_breaks = NULL, limits = lims)$get_breaks_minor()) + expect_null(scale_x_date( + minor_breaks = NULL, + limits = lims + )$get_breaks_minor()) expect_snapshot( scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor(), error = TRUE @@ -177,7 +196,10 @@ test_that("suppressing breaks, minor_breask, and labels works", { scale_x_datetime(labels = NA, limits = lims)$get_labels(), error = TRUE ) - expect_null(scale_x_datetime(minor_breaks = NULL, limits = lims)$get_breaks_minor()) + expect_null(scale_x_datetime( + minor_breaks = NULL, + limits = lims + )$get_breaks_minor()) expect_snapshot( scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor(), error = TRUE @@ -219,15 +241,21 @@ test_that("breaks can be specified by names of labels", { }) test_that("only finite or NA values for breaks for transformed scales (#871)", { - sc <- scale_y_continuous(limits = c(0.01, 0.99), transform = "probit", - breaks = seq(0, 1, 0.2)) + sc <- scale_y_continuous( + limits = c(0.01, 0.99), + transform = "probit", + breaks = seq(0, 1, 0.2) + ) breaks <- sc$break_info()$major_source expect_true(all(is.finite(breaks) | is.na(breaks))) }) test_that("minor breaks are transformed by scales", { - sc <- scale_y_continuous(limits = c(1, 100), transform = "log10", - minor_breaks = c(1, 10, 100)) + sc <- scale_y_continuous( + limits = c(1, 100), + transform = "log10", + minor_breaks = c(1, 10, 100) + ) expect_equal(sc$get_breaks_minor(), c(0, 1, 2)) }) @@ -243,7 +271,6 @@ test_that("continuous limits accepts functions", { }) test_that("equal length breaks and labels can be passed to ViewScales with limits", { - test_scale <- scale_x_continuous( breaks = c(0, 20, 40), labels = c("0", "20", "40"), @@ -258,13 +285,15 @@ test_that("equal length breaks and labels can be passed to ViewScales with limit expect_identical(test_view_scale$get_labels(), c(c("0", "20", "40"))) # ViewScale accepts the limits in the opposite order (#3952) - test_view_scale_rev <- view_scale_primary(test_scale, limits = rev(test_scale$get_limits())) + test_view_scale_rev <- view_scale_primary( + test_scale, + limits = rev(test_scale$get_limits()) + ) expect_identical(test_view_scale_rev$get_breaks(), c(NA, 20, NA)) expect_identical(test_view_scale_rev$get_labels(), c(c("0", "20", "40"))) }) test_that("break names are returned as labels", { - sc <- scale_x_continuous(breaks = c(A = 10, B = 20, C = 30)) sc$train(c(10, 30)) expect_equal(sc$get_labels(), c("A", "B", "C")) @@ -299,14 +328,16 @@ test_that("minor breaks draw correctly", { expect_doppelganger("numeric", p) expect_doppelganger("numeric-polar", p + coord_polar()) - expect_doppelganger("numeric-log", + expect_doppelganger( + "numeric-log", ggplot(df, aes(x_log, x_log)) + scale_x_continuous(transform = transform_log2()) + scale_y_log10() + labs(x = NULL, y = NULL) + theme ) - expect_doppelganger("numeric-exp", + expect_doppelganger( + "numeric-exp", ggplot(df, aes(x_num, x_num)) + scale_x_continuous(transform = transform_exp(2)) + scale_y_continuous(transform = transform_exp(2)) + @@ -314,14 +345,16 @@ test_that("minor breaks draw correctly", { theme ) - expect_doppelganger("character", + expect_doppelganger( + "character", ggplot(df, aes(x_chr, y)) + geom_blank() + labs(x = NULL, y = NULL) + theme ) - expect_doppelganger("date", + expect_doppelganger( + "date", ggplot(df, aes(x_date, y)) + geom_blank() + scale_x_date( @@ -337,23 +370,41 @@ test_that("minor breaks draw correctly", { test_that("scale breaks can be removed", { dat <- data_frame(x = 1:3, y = 1:3) - expect_doppelganger("no x breaks", - ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_x_continuous(breaks = NULL) + expect_doppelganger( + "no x breaks", + ggplot(dat, aes(x = x, y = y)) + + geom_point() + + scale_x_continuous(breaks = NULL) ) - expect_doppelganger("no y breaks", - ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_y_continuous(breaks = NULL) + expect_doppelganger( + "no y breaks", + ggplot(dat, aes(x = x, y = y)) + + geom_point() + + scale_y_continuous(breaks = NULL) ) - expect_doppelganger("no alpha breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, alpha = x)) + geom_point() + scale_alpha_continuous(breaks = NULL) + expect_doppelganger( + "no alpha breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, alpha = x)) + + geom_point() + + scale_alpha_continuous(breaks = NULL) ) - expect_doppelganger("no size breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, size = x)) + geom_point() + scale_size_continuous(breaks = NULL) + expect_doppelganger( + "no size breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, size = x)) + + geom_point() + + scale_size_continuous(breaks = NULL) ) - expect_doppelganger("no fill breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, fill = x)) + geom_point(shape = 21) + scale_fill_continuous(breaks = NULL) + expect_doppelganger( + "no fill breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, fill = x)) + + geom_point(shape = 21) + + scale_fill_continuous(breaks = NULL) ) - expect_doppelganger("no colour breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, colour = x)) + geom_point() + scale_colour_continuous(breaks = NULL) + expect_doppelganger( + "no colour breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, colour = x)) + + geom_point() + + scale_colour_continuous(breaks = NULL) ) }) @@ -368,7 +419,9 @@ test_that("functional limits work for continuous scales", { expect_doppelganger( "functional limits", - ggplot(mpg, aes(class)) + geom_bar(aes(fill = drv)) + scale_y_continuous(limits = limiter(50)) + ggplot(mpg, aes(class)) + + geom_bar(aes(fill = drv)) + + scale_y_continuous(limits = limiter(50)) ) }) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 4be77ae371..d05e925b81 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -37,15 +37,18 @@ test_that("mapping works", { expect_equal( sc$map_df(data_frame(alpha = c(-10, 11)))[[1]], - c(0, 0)) + c(0, 0) + ) }) test_that("identity scale preserves input values", { df <- data_frame(x = 1:3, z = factor(letters[1:3])) # aesthetic-specific scales - p1 <- ggplot(df, - aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + + p1 <- ggplot( + df, + aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x) + ) + geom_point() + scale_colour_identity() + scale_fill_identity() + @@ -61,8 +64,10 @@ test_that("identity scale preserves input values", { expect_equal(d1$alpha, as.numeric(df$z)) # generic scales - p2 <- ggplot(df, - aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + + p2 <- ggplot( + df, + aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x) + ) + geom_point() + scale_discrete_identity(aesthetics = c("colour", "fill", "shape")) + scale_continuous_identity(aesthetics = c("size", "alpha")) @@ -109,7 +114,7 @@ test_that("oob affects position values", { y_scale <- function(limits, oob = censor) { scale_y_continuous(limits = limits, oob = oob, expand = c(0, 0)) } - base + scale_y_continuous(limits = c(-0,5)) + base + scale_y_continuous(limits = c(-0, 5)) low_censor <- cdata(base + y_scale(c(0, 5), censor)) mid_censor <- cdata(base + y_scale(c(3, 7), censor)) @@ -142,7 +147,14 @@ test_that("all-Inf layers are not used for determining the type of scale", { d1 <- data_frame(x = c("a", "b")) p1 <- ggplot(d1, aes(x, x)) + # Inf is numeric, but means discrete values in this case - annotate("rect", xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf, fill = "black") + + annotate( + "rect", + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = Inf, + fill = "black" + ) + geom_point() b1 <- ggplot_build(p1) @@ -150,7 +162,14 @@ test_that("all-Inf layers are not used for determining the type of scale", { p2 <- ggplot() + # If the layer non-Inf value, it's considered - annotate("rect", xmin = -Inf, xmax = 0, ymin = -Inf, ymax = Inf, fill = "black") + annotate( + "rect", + xmin = -Inf, + xmax = 0, + ymin = -Inf, + ymax = Inf, + fill = "black" + ) b2 <- ggplot_build(p2) expect_s3_class(b2@layout$panel_scales_x[[1]], "ScaleContinuousPosition") @@ -181,8 +200,10 @@ test_that("find_global searches in the right places", { testenv <- new.env(parent = globalenv()) # This should find the scale object in the package environment - expect_identical(find_global("scale_colour_hue", testenv), - ggplot2::scale_colour_hue) + expect_identical( + find_global("scale_colour_hue", testenv), + ggplot2::scale_colour_hue + ) # Set an object with the same name in the environment testenv$scale_colour_hue <- "foo" @@ -192,8 +213,10 @@ test_that("find_global searches in the right places", { # If we search in the empty env, we should end up with the object # from the ggplot2 namespace - expect_identical(find_global("scale_colour_hue", emptyenv()), - ggplot2::scale_colour_hue) + expect_identical( + find_global("scale_colour_hue", emptyenv()), + ggplot2::scale_colour_hue + ) }) test_that("scales warn when transforms introduces non-finite values", { @@ -338,17 +361,30 @@ test_that("scale_apply preserves class and attributes", { plot <- ggplot(df, aes(x, y)) + scale_x_continuous() + # Facetting such that 2 x-scales will exist, i.e. `x` will be subsetted - facet_grid(~ z, scales = "free_x") + facet_grid(~z, scales = "free_x") plot <- ggplot_build(plot) # Perform identity transformation via `scale_apply` - out <- with_bindings(scale_apply( - df, "x", "transform", 1:2, plot@layout$panel_scales_x - )[[1]], `c.baz` = `c.baz`, `[.baz` = `[.baz`, .env = global_env()) + out <- with_bindings( + scale_apply( + df, + "x", + "transform", + 1:2, + plot@layout$panel_scales_x + )[[1]], + `c.baz` = `c.baz`, + `[.baz` = `[.baz`, + .env = global_env() + ) # Check that it errors on bad scale ids expect_snapshot_error(scale_apply( - df, "x", "transform", c(NA, 1), plot@layout$panel_scales_x + df, + "x", + "transform", + c(NA, 1), + plot@layout$panel_scales_x )) # Check class preservation @@ -361,9 +397,18 @@ test_that("scale_apply preserves class and attributes", { # Negative control: non-type stable classes don't preserve attributes class(df$x) <- "foobar" - out <- with_bindings(scale_apply( - df, "x", "transform", 1:2, plot@layout$panel_scales_x - )[[1]], `c.baz` = `c.baz`, `[.baz` = `[.baz`, .env = global_env()) + out <- with_bindings( + scale_apply( + df, + "x", + "transform", + 1:2, + plot@layout$panel_scales_x + )[[1]], + `c.baz` = `c.baz`, + `[.baz` = `[.baz`, + .env = global_env() + ) expect_false(inherits(out, "foobar")) expect_null(attributes(out)) @@ -373,8 +418,16 @@ test_that("All scale_colour_*() have their American versions", { # In testthat, the package env contains non-exported functions as well so we # need to parse NAMESPACE file by ourselves exports <- readLines(system.file("NAMESPACE", package = "ggplot2")) - colour_scale_exports <- grep("export\\(scale_colour_.*\\)", exports, value = TRUE) - color_scale_exports <- grep("export\\(scale_color_.*\\)", exports, value = TRUE) + colour_scale_exports <- grep( + "export\\(scale_colour_.*\\)", + exports, + value = TRUE + ) + color_scale_exports <- grep( + "export\\(scale_color_.*\\)", + exports, + value = TRUE + ) expect_equal( colour_scale_exports, sub("color", "colour", color_scale_exports) @@ -383,10 +436,14 @@ test_that("All scale_colour_*() have their American versions", { test_that("scales accept lambda notation for function input", { check_lambda <- function(items, ggproto) { - vapply(items, function(x) { - f <- environment(ggproto[[x]])$f - is_lambda(f) - }, logical(1)) + vapply( + items, + function(x) { + f <- environment(ggproto[[x]])$f + is_lambda(f) + }, + logical(1) + ) } # Test continuous scale @@ -431,20 +488,30 @@ test_that("scales accept lambda notation for function input", { test_that("breaks and labels are correctly checked", { expect_snapshot_error(check_breaks_labels(1:10, letters)) expect_snapshot_error(scale_x_continuous(breaks = NA)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(minor_breaks = NA) + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + scale_x_continuous(minor_breaks = NA) expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = NA) + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + scale_x_continuous(labels = NA) expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = function(x) 1:2) + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + scale_x_continuous(labels = function(x) 1:2) expect_snapshot_error(ggplotGrob(p)) expect_snapshot_error(scale_x_discrete(breaks = NA)) - p <- ggplot(mtcars) + geom_bar(aes(factor(gear))) + scale_x_discrete(labels = NA) + p <- ggplot(mtcars) + + geom_bar(aes(factor(gear))) + + scale_x_discrete(labels = NA) expect_snapshot_error(ggplotGrob(p)) expect_snapshot_error(scale_x_binned(breaks = NA)) p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = NA) expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = function(x) 1:2) + p <- ggplot(mtcars) + + geom_bar(aes(mpg)) + + scale_x_binned(labels = function(x) 1:2) expect_snapshot_error(ggplotGrob(p)) }) @@ -458,7 +525,6 @@ test_that("staged aesthetics are backtransformed properly (#4155)", { }) test_that("numeric scale transforms can produce breaks", { - test_breaks <- function(transform, limits) { scale <- scale_x_continuous(transform = transform) scale$train(scale$transform(limits)) @@ -487,7 +553,6 @@ test_that("numeric scale transforms can produce breaks", { }) test_that("scale functions accurately report their calls", { - construct <- exprs( scale_alpha(), scale_alpha_binned(), @@ -613,7 +678,6 @@ test_that("scale functions accurately report their calls", { }) test_that("scale call is found accurately", { - call_template <- quote(scale_x_continuous(transform = "log10")) sc <- do.call("scale_x_continuous", list(transform = "log10")) @@ -643,7 +707,6 @@ test_that("scale call is found accurately", { }) test_that("training incorrectly appropriately communicates the offenders", { - sc <- scale_colour_viridis_d() expect_snapshot_error( sc$train(1:5) @@ -656,7 +719,6 @@ test_that("training incorrectly appropriately communicates the offenders", { }) test_that("find_scale appends appropriate calls", { - expect_equal( find_scale("x", 1)$call, quote(scale_x_continuous()) @@ -666,20 +728,16 @@ test_that("find_scale appends appropriate calls", { find_scale("colour", "A")$call, quote(scale_colour_discrete()) ) - }) test_that("Using `scale_name` prompts deprecation message", { - expect_snapshot_warning(continuous_scale("x", "foobar", pal_identity())) - expect_snapshot_warning(discrete_scale("x", "foobar", pal_identity())) - expect_snapshot_warning(binned_scale("x", "foobar", pal_identity())) - + expect_snapshot_warning(discrete_scale("x", "foobar", pal_identity())) + expect_snapshot_warning(binned_scale("x", "foobar", pal_identity())) }) # From #5623 test_that("Discrete scales with only NAs return `na.value`", { - x <- c(NA, NA) sc <- scale_colour_discrete(na.value = "red") @@ -697,7 +755,6 @@ test_that("continuous scales warn about faulty `limits`", { }) test_that("populating palettes works", { - scl <- scales_list() scl$add(scale_colour_discrete(aesthetics = c("colour", "fill"))) @@ -717,7 +774,6 @@ test_that("populating palettes works", { scl$set_palettes(my_theme) expect_equal(scl$scales[[1]]$palette(2), c("red", "blue")) - }) test_that("discrete scales work with NAs in arbitrary positions", { @@ -731,7 +787,7 @@ test_that("discrete scales work with NAs in arbitrary positions", { } # All inputs should yield output regardless of where NA is - input <- c("A", "B", "C", NA) + input <- c("A", "B", "C", NA) output <- c("red", "green", "blue", "gray") test <- map(input, limits = c("A", "B", "C", NA)) @@ -742,11 +798,9 @@ test_that("discrete scales work with NAs in arbitrary positions", { test <- map(input, limits = c(NA, "A", "B", "C")) expect_equal(test, output) - }) test_that("ViewScales can make fixed copies", { - p1 <- ggplot(mpg, aes(drv, displ)) + geom_boxplot() + annotate("point", x = 5, y = 10) + @@ -772,7 +826,6 @@ test_that("ViewScales can make fixed copies", { }) test_that("discrete scales can map to 2D structures", { - p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + geom_point() diff --git a/tests/testthat/test-sec-axis.R b/tests/testthat/test-sec-axis.R index 7530c4a70c..011d9dc8cc 100644 --- a/tests/testthat/test-sec-axis.R +++ b/tests/testthat/test-sec-axis.R @@ -11,10 +11,14 @@ test_that("sec_axis checks the user input", { secondary <- ggproto(NULL, AxisSecondary, trans = 1:10) expect_snapshot_error(secondary$init(scale)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + scale_y_continuous(sec.axis = ~sin(.)) + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg)) + + scale_y_continuous(sec.axis = ~ sin(.)) expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + scale_y_continuous(sec.axis = ~sin(./100)) + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg)) + + scale_y_continuous(sec.axis = ~ sin(. / 100)) expect_silent(ggplot_build(p)) }) @@ -33,8 +37,12 @@ test_that("dup_axis() works", { # these aren't exactly equal because the sec_axis trans is based on a # (default) 1000-point approximation - expect_true(all(abs(breaks$major_source - round(breaks$sec.major_source) <= 1))) - expect_true(all(abs(breaks$minor_source - round(breaks$sec.minor_source) <= 1))) + expect_true(all(abs( + breaks$major_source - round(breaks$sec.major_source) <= 1 + ))) + expect_true(all(abs( + breaks$minor_source - round(breaks$sec.minor_source) <= 1 + ))) expect_equal(round(breaks$major, 3), round(breaks$major, 3)) expect_equal(round(breaks$minor, 3), round(breaks$minor, 3)) }) @@ -43,7 +51,7 @@ test_that("sec_axis() works with subtraction", { p <- ggplot(foo, aes(x, y)) + geom_point() + scale_y_continuous( - sec.axis = sec_axis(~1-.) + sec.axis = sec_axis(~ 1 - .) ) scale <- get_panel_scales(p)$y expect_equal(scale$sec_name(), scale$name) @@ -53,8 +61,12 @@ test_that("sec_axis() works with subtraction", { # these aren't exactly equal because the sec_axis trans is based on a # (default) 1000-point approximation - expect_true(all(abs(breaks$major_source - round(breaks$sec.major_source) <= 1))) - expect_true(all(abs(breaks$minor_source - round(breaks$sec.minor_source) <= 1))) + expect_true(all(abs( + breaks$major_source - round(breaks$sec.major_source) <= 1 + ))) + expect_true(all(abs( + breaks$minor_source - round(breaks$sec.minor_source) <= 1 + ))) expect_equal(round(breaks$major, 3), round(breaks$major, 3)) expect_equal(round(breaks$minor, 3), round(breaks$minor, 3)) }) @@ -106,7 +118,6 @@ test_that("sec_axis() breaks work for log-transformed scales", { # test position expect_equal(breaks$major, round(breaks$sec.major, 1)) - # sec_axis() with transform and breaks custom_breaks <- c(10, 20, 40, 200, 400, 800) p <- ggplot(data = df, aes(x, y)) + @@ -142,14 +153,17 @@ test_that("sec axis works with skewed transform", { ggplot(foo, aes(x, y)) + geom_point() + scale_x_continuous( - name = "Unit A", transform = "log", + name = "Unit A", + transform = "log", breaks = c(0.001, 0.01, 0.1, 1, 10, 100, 1000), - sec.axis = sec_axis(~ . * 100, + sec.axis = sec_axis( + ~ . * 100, name = "Unit B", labels = derive(), breaks = derive() ) - ) + theme_linedraw() + ) + + theme_linedraw() ) }) @@ -197,7 +211,10 @@ test_that("sec_axis() handles secondary power transformations", { scale <- get_panel_scales(p)$y breaks <- scale$break_info() - expect_equal(round(breaks$major[4:6], 2), round(breaks$sec.major[c(1, 2, 4)], 2)) + expect_equal( + round(breaks$major[4:6], 2), + round(breaks$sec.major[c(1, 2, 4)], 2) + ) expect_doppelganger( "sec_axis, sec power transform", @@ -210,8 +227,19 @@ test_that("sec_axis() handles secondary power transformations", { test_that("sec_axis() respects custom transformations", { # Custom transform code submitted by DInfanger, Issue #2798 - magnify_trans_log <- function(interval_low = 0.05, interval_high = 1, reducer = 0.05, reducer2 = 8) { - trans <- Vectorize(function(x, i_low = interval_low, i_high = interval_high, r = reducer, r2 = reducer2) { + magnify_trans_log <- function( + interval_low = 0.05, + interval_high = 1, + reducer = 0.05, + reducer2 = 8 + ) { + trans <- Vectorize(function( + x, + i_low = interval_low, + i_high = interval_high, + r = reducer, + r2 = reducer2 + ) { if (is.na(x) || (x >= i_low & x <= i_high)) { x } else if (x < i_low & !is.na(x)) { @@ -221,7 +249,13 @@ test_that("sec_axis() respects custom transformations", { } }) - inv <- Vectorize(function(x, i_low = interval_low, i_high = interval_high, r = reducer, r2 = reducer2) { + inv <- Vectorize(function( + x, + i_low = interval_low, + i_high = interval_high, + r = reducer, + r2 = reducer2 + ) { if (is.na(x) || (x >= i_low & x <= i_high)) { x } else if (x < i_low & !is.na(x)) { @@ -231,7 +265,12 @@ test_that("sec_axis() respects custom transformations", { } }) - new_transform(name = "customlog", transform = trans, inverse = inv, domain = c(1e-16, Inf)) + new_transform( + name = "customlog", + transform = trans, + inverse = inv, + domain = c(1e-16, Inf) + ) } # Create data @@ -244,14 +283,20 @@ test_that("sec_axis() respects custom transformations", { ggplot(dat, aes(x = x, y = y)) + geom_line(linewidth = 1, na.rm = TRUE) + scale_y_continuous( - transform = - magnify_trans_log(interval_low = 0.5, interval_high = 1, reducer = 0.5, reducer2 = 8), breaks = - c(0.001, 0.01, 0.1, 0.5, 0.6, 0.7, 0.8, 0.9, 1), limits = - c(0.001, 1), sec.axis = sec_axis( - transform = - ~ . * (1 / 2), breaks = c(0.001, 0.01, 0.1, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5) + transform = magnify_trans_log( + interval_low = 0.5, + interval_high = 1, + reducer = 0.5, + reducer2 = 8 + ), + breaks = c(0.001, 0.01, 0.1, 0.5, 0.6, 0.7, 0.8, 0.9, 1), + limits = c(0.001, 1), + sec.axis = sec_axis( + transform = ~ . * (1 / 2), + breaks = c(0.001, 0.01, 0.1, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5) ) - ) + theme_linedraw() + ) + + theme_linedraw() ) }) @@ -260,11 +305,14 @@ test_that("sec_axis works with date/time/datetime scales", { withr::local_locale(c(LC_TIME = "C")) df <- data_frame( - dx = seq(as.POSIXct("2012-02-29 12:00:00", - tz = "UTC", - format = "%Y-%m-%d %H:%M:%S" - ), - length.out = 10, by = "4 hour" + dx = seq( + as.POSIXct( + "2012-02-29 12:00:00", + tz = "UTC", + format = "%Y-%m-%d %H:%M:%S" + ), + length.out = 10, + by = "4 hour" ), price = seq(20, 200000, length.out = 10) ) @@ -291,9 +339,7 @@ test_that("sec_axis works with date/time/datetime scales", { geom_line() + scale_x_datetime( name = "UTC", - sec.axis = sec_axis(~ . + 12 * 60 * 60, - name = "UTC+12" - ) + sec.axis = sec_axis(~ . + 12 * 60 * 60, name = "UTC+12") ) scale <- get_panel_scales(dt)$x breaks <- scale$break_info() @@ -305,13 +351,16 @@ test_that("sec_axis works with date/time/datetime scales", { # visual test, datetime scales, reprex #1936 df <- data_frame( - x = as.POSIXct(c( - "2016-11-30 00:00:00", - "2016-11-30 06:00:00", - "2016-11-30 12:00:00", - "2016-11-30 18:00:00", - "2016-12-01 00:00:00" - ), tz = "UTC"), + x = as.POSIXct( + c( + "2016-11-30 00:00:00", + "2016-11-30 06:00:00", + "2016-11-30 12:00:00", + "2016-11-30 18:00:00", + "2016-12-01 00:00:00" + ), + tz = "UTC" + ), y = c(0, -1, 0, 1, 0) ) @@ -319,10 +368,13 @@ test_that("sec_axis works with date/time/datetime scales", { "sec_axis, datetime scale", ggplot(df, aes(x = x, y = y)) + geom_line() + - scale_x_datetime("UTC", - date_breaks = "2 hours", date_labels = "%I%p", + scale_x_datetime( + "UTC", + date_breaks = "2 hours", + date_labels = "%I%p", sec.axis = dup_axis(~ . - 8 * 60 * 60, name = "PST") - ) + theme_linedraw() + ) + + theme_linedraw() ) }) @@ -333,11 +385,16 @@ test_that("sec.axis allows independent trans btwn primary and secondary axes", { ) expect_doppelganger( "sec_axis, independent transformations", - ggplot(data = data, aes(Probability, Value)) + geom_point() + + ggplot(data = data, aes(Probability, Value)) + + geom_point() + scale_x_continuous( - transform = scales::transform_probability(distribution = "norm", lower.tail = FALSE), + transform = scales::transform_probability( + distribution = "norm", + lower.tail = FALSE + ), sec.axis = sec_axis(transform = ~ 1 / ., name = "Return Period") - ) + theme_linedraw() + ) + + theme_linedraw() ) }) @@ -382,14 +439,16 @@ test_that("sec_axis() works for power transformations (monotonicity test doesn't }) test_that("discrete scales can have secondary axes", { - data <- data.frame(x = c("A", "B", "C"), y = c("D", "E", "F")) p <- ggplot(data, aes(x, y)) + geom_point() + scale_x_discrete(sec.axis = dup_axis(labels = c("foo", "bar", "baz"))) + - scale_y_discrete(sec.axis = dup_axis( - breaks = c(1.5, 2.5), labels = c("grault", "garply") - )) + scale_y_discrete( + sec.axis = dup_axis( + breaks = c(1.5, 2.5), + labels = c("grault", "garply") + ) + ) b <- ggplot_build(p) x <- get_guide_data(b, "x.sec") @@ -402,20 +461,19 @@ test_that("discrete scales can have secondary axes", { }) test_that("n.breaks is respected by secondary axes (#4483)", { - b <- ggplot_build( ggplot(data.frame(x = c(0, 10)), aes(x, x)) + scale_y_continuous( n.breaks = 11, - sec.axis = sec_axis(~.x*100) + sec.axis = sec_axis(~ .x * 100) ) ) # We get scale breaks via guide data prim <- get_guide_data(b, "y") - sec <- get_guide_data(b, "y.sec") + sec <- get_guide_data(b, "y.sec") expect_equal(prim$.value, sec$.value) # .value is in primary scale expect_equal(prim$.label, as.character(seq(0, 10, length.out = 11))) - expect_equal(sec$.label, as.character(seq(0, 1000, length.out = 11))) + expect_equal(sec$.label, as.character(seq(0, 1000, length.out = 11))) }) diff --git a/tests/testthat/test-stat-align.R b/tests/testthat/test-stat-align.R index 457992e747..772fe9cf00 100644 --- a/tests/testthat/test-stat-align.R +++ b/tests/testthat/test-stat-align.R @@ -42,11 +42,10 @@ test_that("alignment adjusts per panel", { # Here, x-range is large, so adjustment should be larger ld <- get_layer_data(p + geom_area(aes(fill = f))) - expect_equal(diff(ld$x[1:2]), 1/6, tolerance = 1e-4) + expect_equal(diff(ld$x[1:2]), 1 / 6, tolerance = 1e-4) # Here, x-ranges are smaller, so adjustment should be smaller instead of # considering the data as a whole ld <- get_layer_data(p + geom_area() + facet_wrap(vars(f), scales = "free_x")) expect_equal(diff(ld$x[1:2]), 1e-3, tolerance = 1e-4) - }) diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 27de4ef939..392d7196db 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -19,7 +19,7 @@ test_that("stat_bin works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) }) test_that("bins specifies the number of bins", { @@ -34,7 +34,9 @@ test_that("bins specifies the number of bins", { test_that("binwidth computes widths for function input", { df <- data_frame(x = 1:100) - out <- get_layer_data(ggplot(df, aes(x)) + geom_histogram(binwidth = function(x) 5)) + out <- get_layer_data( + ggplot(df, aes(x)) + geom_histogram(binwidth = function(x) 5) + ) expect_equal(nrow(out), 21) }) @@ -55,15 +57,19 @@ test_that("geom_freqpoly defaults to pad = TRUE", { test_that("can use breaks argument", { df <- data_frame(x = 1:3) - out <- get_layer_data(ggplot(df, aes(x)) + geom_histogram(breaks = c(0, 1.5, 5))) + out <- get_layer_data( + ggplot(df, aes(x)) + geom_histogram(breaks = c(0, 1.5, 5)) + ) expect_equal(out$count, c(1, 2)) }) test_that("breaks computes bin boundaries for function input", { df <- data.frame(x = c(0, 0, 0, 1:3)) - out <- layer_data(ggplot(df, aes(x)) + - geom_histogram(breaks = function(x) c(0, 0.5, 2.5, 7.5))) + out <- layer_data( + ggplot(df, aes(x)) + + geom_histogram(breaks = function(x) c(0, 0.5, 2.5, 7.5)) + ) expect_equal(out$count, c(3, 2, 1)) }) @@ -78,13 +84,13 @@ test_that("fuzzy breaks are used when cutting", { }) test_that("breaks are transformed by the scale", { - df <- data_frame(x = rep(1:4, 1:4)) - base <- ggplot(df, aes(x)) + geom_histogram(breaks = c(1, 2.5, 4)) + df <- data_frame(x = rep(1:4, 1:4)) + base <- ggplot(df, aes(x)) + geom_histogram(breaks = c(1, 2.5, 4)) - out1 <- get_layer_data(base) - out2 <- get_layer_data(base + scale_x_sqrt()) - expect_equal(out1$xmin, c(1, 2.5)) - expect_equal(out2$xmin, sqrt(c(1, 2.5))) + out1 <- get_layer_data(base) + out2 <- get_layer_data(base + scale_x_sqrt()) + expect_equal(out1$xmin, c(1, 2.5)) + expect_equal(out2$xmin, sqrt(c(1, 2.5))) }) test_that("geom_histogram() can be drawn over a 0-width range (#3043)", { @@ -142,27 +148,37 @@ test_that("bins() computes fuzz with non-finite breaks", { }) test_that("bins is strictly adhered to", { - nbins <- c(1, 2, 3, 4, 5, 10, 20, 30, 40, 50) # Default case - nbreaks <- vapply(nbins, function(bins) { - length(compute_bins(c(0, 10), bins = bins)$breaks) - }, numeric(1)) + nbreaks <- vapply( + nbins, + function(bins) { + length(compute_bins(c(0, 10), bins = bins)$breaks) + }, + numeric(1) + ) expect_equal(nbreaks, nbins + 1) # Center is provided - nbreaks <- vapply(nbins, function(bins) { - length(compute_bins(c(0, 10), bins = bins, center = 0)$breaks) - }, numeric(1)) + nbreaks <- vapply( + nbins, + function(bins) { + length(compute_bins(c(0, 10), bins = bins, center = 0)$breaks) + }, + numeric(1) + ) expect_equal(nbreaks, nbins + 1) # Boundary is provided - nbreaks <- vapply(nbins, function(bins) { - length(compute_bins(c(0, 10), bins = bins, boundary = 0)$breaks) - }, numeric(1)) + nbreaks <- vapply( + nbins, + function(bins) { + length(compute_bins(c(0, 10), bins = bins, boundary = 0)$breaks) + }, + numeric(1) + ) expect_equal(nbreaks, nbins + 1) - }) comp_bin <- function(df, ...) { @@ -192,9 +208,21 @@ test_that("closed left or right", { res <- comp_bin(dat, binwidth = 10, pad = FALSE, closed = "left") expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 5, pad = FALSE, closed = "left") + res <- comp_bin( + dat, + binwidth = 10, + boundary = 5, + pad = FALSE, + closed = "left" + ) expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 0, pad = FALSE, closed = "left") + res <- comp_bin( + dat, + binwidth = 10, + boundary = 0, + pad = FALSE, + closed = "left" + ) expect_identical(res$count, c(2)) res <- comp_bin(dat, binwidth = 5, boundary = 0, pad = FALSE, closed = "left") expect_identical(res$count, c(1, 1)) @@ -227,7 +255,7 @@ test_that("weights are added", { }) test_that("bin errors at high bin counts", { - expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) + expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) }) # stat_count -------------------------------------------------------------- @@ -241,19 +269,22 @@ test_that("stat_count throws error when both x and y aesthetic present", { test_that("stat_count preserves x order for continuous and discrete", { # x is numeric b <- ggplot_build(ggplot(mtcars, aes(carb)) + geom_bar()) - expect_identical(b@data[[1]]$x, c(1,2,3,4,6,8)) - expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) + expect_identical(b@data[[1]]$x, c(1, 2, 3, 4, 6, 8)) + expect_identical(b@data[[1]]$y, c(7, 10, 3, 10, 1, 1)) # x is factor where levels match numeric order mtcars$carb2 <- factor(mtcars$carb) b <- ggplot_build(ggplot(mtcars, aes(carb2)) + geom_bar()) expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) + expect_identical(b@data[[1]]$y, c(7, 10, 3, 10, 1, 1)) # x is factor levels differ from numeric order - mtcars$carb3 <- factor(mtcars$carb, levels = c(4,1,2,3,6,8)) + mtcars$carb3 <- factor(mtcars$carb, levels = c(4, 1, 2, 3, 6, 8)) b <- ggplot_build(ggplot(mtcars, aes(carb3)) + geom_bar()) expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b@layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8")) - expect_identical(b@data[[1]]$y, c(10,7,10,3,1,1)) + expect_identical( + b@layout$panel_params[[1]]$x$get_labels(), + c("4", "1", "2", "3", "6", "8") + ) + expect_identical(b@data[[1]]$y, c(10, 7, 10, 3, 1, 1)) }) diff --git a/tests/testthat/test-stat-bin2d.R b/tests/testthat/test-stat-bin2d.R index 6d83448956..a3df914a4b 100644 --- a/tests/testthat/test-stat-bin2d.R +++ b/tests/testthat/test-stat-bin2d.R @@ -21,8 +21,8 @@ test_that("binwidth is respected", { test_that("breaks override binwidth", { # Test explicitly setting the breaks for x, overriding # the binwidth. - integer_breaks <- (0:4) - 0.5 # Will use for x - half_breaks <- seq(0, 3.5, 0.5) # Will test against this for y + integer_breaks <- (0:4) - 0.5 # Will use for x + half_breaks <- seq(0, 3.5, 0.5) # Will test against this for y df <- data_frame(x = 0:3, y = 0:3) base <- ggplot(df, aes(x, y)) + @@ -32,15 +32,22 @@ test_that("breaks override binwidth", { ) out <- get_layer_data(base) - expect_equal(out$xbin, cut(df$x, bins(integer_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE)) - expect_equal(out$ybin, cut(df$y, bins(half_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE)) + expect_equal( + out$xbin, + cut(df$x, bins(integer_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE) + ) + expect_equal( + out$ybin, + cut(df$y, bins(half_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE) + ) }) test_that("breaks are transformed by the scale", { df <- data_frame(x = c(1, 10, 100, 1000), y = 0:3) base <- ggplot(df, aes(x, y)) + stat_bin_2d( - breaks = list(x = c(5, 50, 500), y = c(0.5, 1.5, 2.5))) + breaks = list(x = c(5, 50, 500), y = c(0.5, 1.5, 2.5)) + ) out1 <- get_layer_data(base) out2 <- get_layer_data(base + scale_x_log10()) diff --git a/tests/testthat/test-stat-boxplot.R b/tests/testthat/test-stat-boxplot.R index 7878a9eb34..435b0b34ef 100644 --- a/tests/testthat/test-stat-boxplot.R +++ b/tests/testthat/test-stat-boxplot.R @@ -1,5 +1,4 @@ test_that("stat_boxplot drops missing rows with a warning", { - p1 <- ggplot(PlantGrowth, aes(x = group, y = weight)) + geom_boxplot(position = "dodge") + scale_x_discrete(limits = c("trt1", "ctrl")) diff --git a/tests/testthat/test-stat-connect.R b/tests/testthat/test-stat-connect.R index 16c3ed44fd..531a0315bd 100644 --- a/tests/testthat/test-stat-connect.R +++ b/tests/testthat/test-stat-connect.R @@ -1,5 +1,4 @@ test_that("stat_connect closes off ends", { - data <- data.frame(x = 1:3, y = c(1, 2, 0)) ld <- get_layer_data( @@ -11,7 +10,6 @@ test_that("stat_connect closes off ends", { j <- c(1L, nrow(data)) expect_equal(ld$x[i], data$x[j]) expect_equal(ld$y[i], data$y[j]) - }) test_that("stat_connect works with 1-row connections", { @@ -27,10 +25,9 @@ test_that("stat_connect works with 1-row connections", { }) test_that("stat_connect works with ribbons in both orientations", { - data <- data.frame(x = 1:4, ymin = c(1, 2, 0, 1), ymax = c(3, 4, 3, 4)) expected <- data.frame( - x = c(1, 2, 2, 3, 3, 4, 4), + x = c(1, 2, 2, 3, 3, 4, 4), ymin = c(1, 1, 2, 2, 0, 0, 1), ymax = c(3, 3, 4, 4, 3, 3, 4) ) @@ -51,7 +48,6 @@ test_that("stat_connect works with ribbons in both orientations", { }) test_that("stat_connect rejects invalid connections", { - test_setup <- function(...) { StatConnect$setup_params(NULL, list(...)) } @@ -64,7 +60,6 @@ test_that("stat_connect rejects invalid connections", { p <- test_setup(connection = cbind(c(0, 1), c(0, 1))) expect_vector(p$connection, size = 2L, ptype = matrix(NA_real_, 0, 2)) - p <- test_setup(connection = matrix(NA_real_, 0, 2)) expect_null(p$connection) diff --git a/tests/testthat/test-stat-contour.R b/tests/testthat/test-stat-contour.R index df9a27132c..948e977db4 100644 --- a/tests/testthat/test-stat-contour.R +++ b/tests/testthat/test-stat-contour.R @@ -27,14 +27,14 @@ test_that("contouring irregularly spaced data works", { # we're testing for set equality here because contour lines are not # guaranteed to start and end at the same point on all architectures d <- get_layer_data(p) - d4 <- d[d$level == 4,] + d4 <- d[d$level == 4, ] expect_equal(nrow(d4), 7) expect_setequal(d4$x, c(4, 10, 100, 700)) - expect_setequal(d4$y, c(2, 8/3, 4/3)) - d8 <- d[d$level == 8,] + expect_setequal(d4$y, c(2, 8 / 3, 4 / 3)) + d8 <- d[d$level == 8, ] expect_equal(nrow(d8), 7) expect_setequal(d8$x, c(8, 10, 100, 300)) - expect_setequal(d8$y, c(2, 20/9, 16/9)) + expect_setequal(d8$y, c(2, 20 / 9, 16 / 9)) }) test_that("contour breaks can be set manually and by bins and binwidth and a function", { @@ -46,7 +46,10 @@ test_that("contour breaks can be set manually and by bins and binwidth and a fun expect_length(contour_breaks(range + 0.2, bins = 5), 6) expect_equal(resolution(contour_breaks(range, binwidth = 0.3)), 0.3) expect_equal(contour_breaks(range), contour_breaks(range, breaks = fullseq)) - expect_equal(contour_breaks(range), contour_breaks(range, breaks = ~fullseq(.x, .y))) + expect_equal( + contour_breaks(range), + contour_breaks(range, breaks = ~ fullseq(.x, .y)) + ) }) test_that("geom_contour_filled() and stat_contour_filled() result in identical layer data", { @@ -82,7 +85,6 @@ test_that("basic stat_contour_filled() plot builds", { }) test_that("stat_contour() removes duplicated coordinates", { - df <- data_frame0( x = c(1, 1, 2, 2, 1, 1, 2, 2), y = c(1, 2, 1, 2, 1, 2, 1, 2), @@ -96,7 +98,7 @@ test_that("stat_contour() removes duplicated coordinates", { expect_snapshot_warning( new <- layer$stat$setup_data(transform(df, group = 1)) ) - expect_equal(new, df[1:4,], ignore_attr = TRUE) + expect_equal(new, df[1:4, ], ignore_attr = TRUE) }) test_that("stat_contour() can infer rotations", { diff --git a/tests/testthat/test-stat-count.R b/tests/testthat/test-stat-count.R index b014fc672e..e610d6a0da 100644 --- a/tests/testthat/test-stat-count.R +++ b/tests/testthat/test-stat-count.R @@ -8,7 +8,9 @@ test_that("stat_count() checks the aesthetics", { test_that("stat_count() respects uniqueness of `x`", { # For #4609, converting x to factor loses smallest digits, so here we test # if they are retained - df <- data_frame0(x = c(1, 2, 1, 2) + rep(c(0, 1.01 * .Machine$double.eps), each = 2)) + df <- data_frame0( + x = c(1, 2, 1, 2) + rep(c(0, 1.01 * .Machine$double.eps), each = 2) + ) p <- ggplot(df, aes(x)) + stat_count(position = "identity") data <- get_layer_data(p) diff --git a/tests/testthat/test-stat-density.R b/tests/testthat/test-stat-density.R index 3fb8ff00ec..1a8f9c11ba 100644 --- a/tests/testthat/test-stat-density.R +++ b/tests/testthat/test-stat-density.R @@ -20,7 +20,8 @@ test_that("stat_density can make weighted density estimation", { df$weight <- mtcars$cyl dens <- stats::density( - df$mpg, weights = df$weight / sum(df$weight), + df$mpg, + weights = df$weight / sum(df$weight), bw = stats::bw.nrd0(df$mpg) ) expected_density_fun <- stats::approxfun(data.frame(x = dens$x, y = dens$y)) @@ -112,7 +113,7 @@ test_that("stat_density works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) p <- ggplot(mpg) + stat_density() expect_snapshot_error(ggplot_build(p)) @@ -122,7 +123,10 @@ test_that("compute_density returns useful df and throws warning when <2 values", expect_snapshot_warning(dens <- compute_density(1, NULL, from = 0, to = 0)) expect_equal(nrow(dens), 1) - expect_named(dens, c("x", "density", "scaled", "ndensity", "count", "wdensity", "n")) + expect_named( + dens, + c("x", "density", "scaled", "ndensity", "count", "wdensity", "n") + ) expect_type(dens$x, "double") }) diff --git a/tests/testthat/test-stat-ecdf.R b/tests/testthat/test-stat-ecdf.R index 1ea0a69a56..04544cf8df 100644 --- a/tests/testthat/test-stat-ecdf.R +++ b/tests/testthat/test-stat-ecdf.R @@ -9,14 +9,13 @@ test_that("stat_ecdf works in both directions", { x$flipped_aes <- NULL y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) + expect_identical(x, flip_data(y, TRUE)[, names(x)]) p <- ggplot(mpg) + stat_ecdf() expect_snapshot_error(ggplot_build(p)) }) test_that("weighted ecdf computes sensible results", { - set.seed(42) x <- rpois(100, 5) ux <- sort(unique0(x)) @@ -34,7 +33,7 @@ test_that("weighted ecdf computes sensible results", { ) # Tabulated weights should be the same as the original - tab <- as.data.frame(table(x), stringsAsFactors = FALSE) + tab <- as.data.frame(table(x), stringsAsFactors = FALSE) tab$x <- as.numeric(tab$x) expect_equal( ecdf(x)(ux), @@ -43,7 +42,6 @@ test_that("weighted ecdf computes sensible results", { }) test_that("weighted ecdf warns about weird weights", { - # Should warn when provided with illegal weights expect_snapshot_warning(wecdf(1:10, c(NA, rep(1, 9)))) diff --git a/tests/testthat/test-stat-ellipsis.R b/tests/testthat/test-stat-ellipsis.R index 7615091376..adbad011bd 100644 --- a/tests/testthat/test-stat-ellipsis.R +++ b/tests/testthat/test-stat-ellipsis.R @@ -2,7 +2,11 @@ skip_if_not_installed("MASS") test_that("stat_ellipsis returns correct data format", { n_seg <- 40 - d <- data_frame(x = c(1, 1, 4, 4, 4, 3, 3, 1), y = c(1:4, 1:4), id = rep(1:2, each = 4)) + d <- data_frame( + x = c(1, 1, 4, 4, 4, 3, 3, 1), + y = c(1:4, 1:4), + id = rep(1:2, each = 4) + ) p <- ggplot(d, aes(x = x, y = y, group = id)) + geom_point() + stat_ellipse(segments = n_seg) diff --git a/tests/testthat/test-stat-function.R b/tests/testthat/test-stat-function.R index f9073086df..a3c149a59e 100644 --- a/tests/testthat/test-stat-function.R +++ b/tests/testthat/test-stat-function.R @@ -23,25 +23,25 @@ test_that("uses scale limits, not data limits", { }) test_that("works in plots without any data", { - f <- function(x) 2*x + f <- function(x) 2 * x # default limits, 0 to 1 base <- ggplot() + geom_function(fun = f, n = 6) ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) - expect_identical(ret$y, 2*ret$x) + expect_identical(ret$y, 2 * ret$x) # manually set limits with xlim() base <- ggplot() + xlim(0, 2) + geom_function(fun = f, n = 6) ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 2, length.out = 6)) - expect_identical(ret$y, 2*ret$x) + expect_identical(ret$y, 2 * ret$x) # manually set limits with xlim argument base <- ggplot() + geom_function(fun = f, n = 6, xlim = c(0, 2)) ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 2, length.out = 6)) - expect_identical(ret$y, 2*ret$x) + expect_identical(ret$y, 2 * ret$x) # mapping of color via aes() works base <- ggplot() + @@ -49,7 +49,7 @@ test_that("works in plots without any data", { scale_color_manual(values = c(fun = "#D55E00")) ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) - expect_identical(ret$y, 2*ret$x) + expect_identical(ret$y, 2 * ret$x) expect_identical(ret$colour, rep("#D55E00", 6)) }) @@ -92,7 +92,8 @@ test_that("works with transformed scales", { expect_equal(10^ret$y, (10^ret$x)^2) # now with explicit mapping of y - base <- ggplot(dat, aes(x, y)) + geom_point() + + base <- ggplot(dat, aes(x, y)) + + geom_point() + stat_function(fun = ~ .x^2, n = 5) ret <- get_layer_data(base, 2) @@ -133,7 +134,11 @@ test_that("works with formula syntax", { test_that("Warn when drawing multiple copies of the same function", { df <- data_frame(x = 1:3, y = letters[1:3]) p <- ggplot(df, aes(x, color = y)) + stat_function(fun = identity) - f <- function() {pdf(NULL); print(p); dev.off()} + f <- function() { + pdf(NULL) + print(p) + dev.off() + } expect_snapshot_warning(f()) }) @@ -150,7 +155,10 @@ test_that("Line style can be changed via provided data", { base <- ggplot() + geom_function( - data = df, aes(color = fun), fun = identity, n = 6 + data = df, + aes(color = fun), + fun = identity, + n = 6 ) + scale_color_identity() ret <- get_layer_data(base) @@ -160,7 +168,10 @@ test_that("Line style can be changed via provided data", { base <- ggplot() + stat_function( - data = df, aes(color = fun), fun = identity, n = 6 + data = df, + aes(color = fun), + fun = identity, + n = 6 ) + scale_color_identity() ret <- get_layer_data(base) diff --git a/tests/testthat/test-stat-manual.R b/tests/testthat/test-stat-manual.R index 5e2ca54376..58ae4a5480 100644 --- a/tests/testthat/test-stat-manual.R +++ b/tests/testthat/test-stat-manual.R @@ -1,5 +1,4 @@ test_that("stat_manual can take a function", { - centroid <- function(data) data.frame(x = mean(data$x), y = mean(data$y)) layer <- get_layer_data( diff --git a/tests/testthat/test-stat-sf-coordinates.R b/tests/testthat/test-stat-sf-coordinates.R index c6e3a21920..11550c2eca 100644 --- a/tests/testthat/test-stat-sf-coordinates.R +++ b/tests/testthat/test-stat-sf-coordinates.R @@ -8,7 +8,10 @@ test_that("stat_sf_coordinates() retrieves coordinates from sf objects", { # point df_point <- sf::st_sf(geometry = sf::st_sfc(sf::st_point(c(0, 0)))) - expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data_frame(x = 0, y = 0)) + expect_identical( + comp_sf_coord(df_point)[, c("x", "y")], + data_frame(x = 0, y = 0) + ) # line c_line <- rbind(c(-1, -1), c(1, 1)) @@ -23,12 +26,18 @@ test_that("stat_sf_coordinates() retrieves coordinates from sf objects", { # polygon c_polygon <- list(rbind(c(-1, -1), c(-1, 1), c(1, 1), c(1, -1), c(-1, -1))) df_polygon <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(c_polygon))) - expect_identical(comp_sf_coord(df_point)[, c("x", "y")], data_frame(x = 0, y = 0)) + expect_identical( + comp_sf_coord(df_point)[, c("x", "y")], + data_frame(x = 0, y = 0) + ) # computed variables (x and y) df_point <- sf::st_sf(geometry = sf::st_sfc(sf::st_point(c(1, 2)))) expect_identical( - comp_sf_coord(df_point, aes(x = after_stat(x) + 10, y = after_stat(y) * 10))[, c("x", "y")], + comp_sf_coord( + df_point, + aes(x = after_stat(x) + 10, y = after_stat(y) * 10) + )[, c("x", "y")], data_frame(x = 11, y = 20) ) }) @@ -37,9 +46,20 @@ test_that("stat_sf_coordinates() ignores Z and M coordinates", { skip_if_not_installed("sf") # XYM - c_polygon <- list(rbind(c(-1, -1, 0), c(-1, 1, 0), c(1, 1, 0), c(1, -1, 0), c(-1, -1, 0))) - df_xym <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(c_polygon, dim = "XYM"))) + c_polygon <- list(rbind( + c(-1, -1, 0), + c(-1, 1, 0), + c(1, 1, 0), + c(1, -1, 0), + c(-1, -1, 0) + )) + df_xym <- sf::st_sf( + geometry = sf::st_sfc(sf::st_polygon(c_polygon, dim = "XYM")) + ) # Note that st_centroid() and st_point_on_surface() cannot handle M dimension since # GEOS does not support it. The default fun.geometry should drop M. - expect_identical(comp_sf_coord(df_xym)[, c("x", "y")], data_frame(x = 0, y = 0)) + expect_identical( + comp_sf_coord(df_xym)[, c("x", "y")], + data_frame(x = 0, y = 0) + ) }) diff --git a/tests/testthat/test-stat-sum.R b/tests/testthat/test-stat-sum.R index b4fe14b79f..8a3e24c281 100644 --- a/tests/testthat/test-stat-sum.R +++ b/tests/testthat/test-stat-sum.R @@ -44,12 +44,14 @@ test_that("handles grouping correctly", { # Visual tests ------------------------------------------------------------ test_that("summaries are drawn correctly", { - expect_doppelganger("summary with color and lines", + expect_doppelganger( + "summary with color and lines", ggplot(mtcars, aes(x = cyl, y = mpg, colour = factor(vs))) + geom_point() + stat_summary(fun = mean, geom = "line", linewidth = 2) ) - expect_doppelganger("summary with crossbars, no grouping", + expect_doppelganger( + "summary with crossbars, no grouping", ggplot(mtcars, aes(x = cyl, y = mpg)) + geom_point() + stat_summary( @@ -59,7 +61,8 @@ test_that("summaries are drawn correctly", { width = 0.2 ) ) - expect_doppelganger("summary with crossbars, manual grouping", + expect_doppelganger( + "summary with crossbars, manual grouping", ggplot(mtcars, aes(x = cyl, y = mpg, group = cyl)) + geom_point() + stat_summary( diff --git a/tests/testthat/test-stat-summary.R b/tests/testthat/test-stat-summary.R index abc2ffe5dd..1a9647510e 100644 --- a/tests/testthat/test-stat-summary.R +++ b/tests/testthat/test-stat-summary.R @@ -10,21 +10,21 @@ test_that("stat_summary(_bin) work with lambda expressions", { p1 <- ggplot(dat, aes(x, y)) + stat_summary(fun.data = mean_se) - # test fun.data p2 <- ggplot(dat, aes(x, y)) + - stat_summary(fun.data = ~ { - mean <- mean(.x) - se <- sqrt(stats::var(.x) / length(.x)) - data_frame(y = mean, ymin = mean - se, ymax = mean + se) - }) + stat_summary( + fun.data = ~ { + mean <- mean(.x) + se <- sqrt(stats::var(.x) / length(.x)) + data_frame(y = mean, ymin = mean - se, ymax = mean + se) + } + ) expect_equal( get_layer_data(p1), get_layer_data(p2) ) - # fun, fun.min, fun.max p3 <- ggplot(dat, aes(x, y)) + stat_summary( @@ -37,14 +37,15 @@ test_that("stat_summary(_bin) work with lambda expressions", { get_layer_data(p1), get_layer_data(p3) ) - }) test_that("stat_summary_bin takes user's `width` argument (#4647)", { p <- ggplot(mtcars, aes(mpg, disp)) + stat_summary_bin( - fun.data = mean_se, na.rm = TRUE, - binwidth = 1, width = 2 + fun.data = mean_se, + na.rm = TRUE, + binwidth = 1, + width = 2 ) ld <- layer_data(p) @@ -52,14 +53,12 @@ test_that("stat_summary_bin takes user's `width` argument (#4647)", { }) test_that("stat_summary_(2d|hex) work with lambda expressions", { - dat <- data_frame( x = c(0, 0, 0, 0, 1, 1, 1, 1), y = c(0, 0, 1, 1, 0, 0, 1, 1), z = c(1, 1, 2, 2, 2, 2, 3, 3) ) - # stat_summary_2d p1 <- ggplot(dat, aes(x, y, z = z)) + stat_summary_2d(fun = function(x) mean(x)) @@ -72,8 +71,6 @@ test_that("stat_summary_(2d|hex) work with lambda expressions", { get_layer_data(p2) ) - - # stat_summary_hex # this plot is a bit funky, but easy to reason through skip_if_not_installed("hexbin") @@ -87,5 +84,4 @@ test_that("stat_summary_(2d|hex) work with lambda expressions", { get_layer_data(p1), get_layer_data(p2) ) - }) diff --git a/tests/testthat/test-stat-ydensity.R b/tests/testthat/test-stat-ydensity.R index fb5d39c036..3e90e54d88 100644 --- a/tests/testthat/test-stat-ydensity.R +++ b/tests/testthat/test-stat-ydensity.R @@ -5,11 +5,14 @@ test_that("calc_bw() requires at least two values and correct method", { }) test_that("`drop = FALSE` preserves groups with 1 observations", { - df <- head(data_frame0( - x = factor(rep(1:2, each = 4)), - y = rep(1:2, 4), - g = rep(c("A", "A", "B", 'B'), 2) - ), -1) + df <- head( + data_frame0( + x = factor(rep(1:2, each = 4)), + y = rep(1:2, 4), + g = rep(c("A", "A", "B", 'B'), 2) + ), + -1 + ) p <- ggplot(df, mapping = aes(x, y, fill = g)) @@ -25,15 +28,13 @@ test_that("`drop = FALSE` preserves groups with 1 observations", { }) test_that("mapped_discrete class is preserved", { - df <- data_frame0( x = factor(rep(c("A", "C"), each = 3), c("A", "B", "C")), y = 1:6 ) ld <- get_layer_data( - ggplot(df, aes(x, y)) + geom_violin() + - scale_x_discrete(drop = FALSE) + ggplot(df, aes(x, y)) + geom_violin() + scale_x_discrete(drop = FALSE) ) expect_s3_class(ld$x, "mapped_discrete") @@ -41,7 +42,6 @@ test_that("mapped_discrete class is preserved", { }) test_that("quantiles are based on actual data (#4120)", { - df <- data.frame(y = 0:10) q <- seq(0.1, 0.9, by = 0.1) diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 6eeeffa938..690c002528 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -17,14 +17,21 @@ test_that("error message is thrown when aesthetics are missing", { }) test_that("erroneously dropped aesthetics are found and issue a warning", { - # case 1) dropped completely df1 <- data_frame( - x = c( # arbitrary random numbers - 0.42986445, 1.11153170, -1.22318013, 0.90982003, - 0.46454276, -0.42300004, -1.76139834, -0.75060412, - 0.01635474, -0.63202159 + x = c( + # arbitrary random numbers + 0.42986445, + 1.11153170, + -1.22318013, + 0.90982003, + 0.46454276, + -0.42300004, + -1.76139834, + -0.75060412, + 0.01635474, + -0.63202159 ), g = rep(1:2, each = 5) ) @@ -34,9 +41,9 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { # case 2-1) dropped partially df2 <- data_frame( - id = c("a", "a", "b", "b", "c"), - colour = c( 0, 1, 10, 10, 20), # a should be dropped - fill = c( 0, 0, 10, 11, 20) # b should be dropped + id = c("a", "a", "b", "b", "c"), + colour = c(0, 1, 10, 10, 20), # a should be dropped + fill = c(0, 0, 10, 11, 20) # b should be dropped ) p2 <- ggplot(df2, aes(id, colour = colour, fill = fill)) + geom_bar() @@ -52,12 +59,13 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { # case 2-1) dropped partially with NA df3 <- data_frame( - id = c("a", "a", "b", "b", "c"), - colour = c( 0, NA, 10, 10, 20), # a should be dropped - fill = c( NA, NA, 10, 10, 20) # a should not be dropped + id = c("a", "a", "b", "b", "c"), + colour = c(0, NA, 10, 10, 20), # a should be dropped + fill = c(NA, NA, 10, 10, 20) # a should not be dropped ) - p3 <- ggplot(df3, aes(id, colour = colour, fill = fill)) + geom_bar() + + p3 <- ggplot(df3, aes(id, colour = colour, fill = fill)) + + geom_bar() + scale_fill_continuous(na.value = "#123") expect_snapshot_warning(b3 <- ggplot_build(p3)) @@ -71,9 +79,9 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { }) test_that("stats can modify persistent attributes", { - StatTest <- ggproto( - "StatTest", Stat, + "StatTest", + Stat, compute_layer = function(self, data, params, layout) { attr(data, "foo") <- "bar" data @@ -86,5 +94,4 @@ test_that("stats can modify persistent attributes", { ld <- layer_data(p) expect_equal(attr(ld, "foo"), "bar") - }) diff --git a/tests/testthat/test-summarise-plot.R b/tests/testthat/test-summarise-plot.R index 601147f4e0..a13b11cdf8 100644 --- a/tests/testthat/test-summarise-plot.R +++ b/tests/testthat/test-summarise-plot.R @@ -1,7 +1,5 @@ test_that("summarise_*() throws appropriate errors", { - expect_snapshot_error(summarise_layout(10)) expect_snapshot_error(summarise_coord("A")) expect_snapshot_error(summarise_layers(TRUE)) - }) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 6aa9081460..4a254633b6 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -9,15 +9,18 @@ test_that("dollar subsetting the theme does no partial matching", { test_that("theme argument splicing works", { l <- list(a = 10, b = "c", d = c("foo", "bar")) test <- theme(!!!l) - ref <- theme(a = 10, b = "c", d = c("foo", "bar")) + ref <- theme(a = 10, b = "c", d = c("foo", "bar")) expect_equal(test, ref) }) test_that("modifying theme element properties with + operator works", { - # Changing a "leaf node" works - t <- theme_grey() + theme(axis.title.x = element_text(colour = 'red', margin = margin())) - expect_identical(t$axis.title.x, element_text(colour = 'red', margin = margin(), vjust = 1)) + t <- theme_grey() + + theme(axis.title.x = element_text(colour = 'red', margin = margin())) + expect_identical( + t$axis.title.x, + element_text(colour = 'red', margin = margin(), vjust = 1) + ) # Make sure the theme class didn't change or get dropped expect_s7_class(t, class_theme) # Make sure the element class didn't change or get dropped @@ -32,8 +35,8 @@ test_that("modifying theme element properties with + operator works", { t <- theme_grey() + theme(text = element_text(colour = 'red')) expect_identical(t$text@colour, 'red') expect_identical(t$text@family, theme_grey()$text@family) - expect_identical(t$text@face, theme_grey()$text@face) - expect_identical(t$text@size, theme_grey()$text@size) + expect_identical(t$text@face, theme_grey()$text@face) + expect_identical(t$text@size, theme_grey()$text@size) # Descendent is unchanged expect_identical(t$axis.title.x, theme_grey()$axis.title.x) @@ -91,20 +94,25 @@ test_that("adding theme object to ggplot object with + operator works", { ## stepwise addition of partial themes is identical to one-step addition p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() - p1 <- p + theme_light() + + p1 <- p + + theme_light() + theme(axis.line.x = element_line(color = "blue")) + theme(axis.ticks.x = element_line(color = "red")) - p2 <- p + theme_light() + - theme(axis.line.x = element_line(color = "blue"), - axis.ticks.x = element_line(color = "red")) + p2 <- p + + theme_light() + + theme( + axis.line.x = element_line(color = "blue"), + axis.ticks.x = element_line(color = "red") + ) expect_identical(p1@theme, p2@theme) }) test_that("replacing theme elements with %+replace% operator works", { # Changing a "leaf node" works - t <- theme_grey() %+replace% theme(axis.title.x = element_text(colour = 'red')) + t <- theme_grey() %+replace% + theme(axis.title.x = element_text(colour = 'red')) expect_identical(t$axis.title.x, element_text(colour = 'red')) # Make sure the class didn't change or get dropped expect_s7_class(t, class_theme) @@ -132,7 +140,7 @@ test_that("calculating theme element inheritance works", { # Check that rel() works for relative sizing, and is applied at each level t <- theme_grey(base_size = 12) + - theme(axis.title = element_text(size = rel(0.5))) + + theme(axis.title = element_text(size = rel(0.5))) + theme(axis.title.x = element_text(size = rel(0.5))) e <- calc_element('axis.title', t) expect_identical(e@size, 6) @@ -145,14 +153,21 @@ test_that("calculating theme element inheritance works", { # Check that inheritance from derived class works element_dummyrect <- S7::new_class( - "element_dummyrect", parent = element_rect, + "element_dummyrect", + parent = element_rect, properties = list(dummy = S7::class_any) ) e <- calc_element( "panel.background", theme( - rect = element_rect(fill = "white", colour = "black", linewidth = 0.5, linetype = 1, linejoin = "round"), + rect = element_rect( + fill = "white", + colour = "black", + linewidth = 0.5, + linetype = 1, + linejoin = "round" + ), panel.background = element_dummyrect(dummy = 5), complete = TRUE # need to prevent pulling in default theme ) @@ -161,7 +176,12 @@ test_that("calculating theme element inheritance works", { expect_identical( e, element_dummyrect( - fill = "white", colour = "black", dummy = 5, linewidth = 0.5, linetype = 1, linejoin = "round", + fill = "white", + colour = "black", + dummy = 5, + linewidth = 0.5, + linetype = 1, + linejoin = "round", inherit.blank = TRUE # this is true because we're requesting a complete theme ) ) @@ -179,20 +199,31 @@ test_that("calculating theme element inheritance works", { expect_identical(e1, e2) theme <- theme_gray() + - theme(strip.text = element_blank(), strip.text.x = element_text(inherit.blank = TRUE)) + theme( + strip.text = element_blank(), + strip.text.x = element_text(inherit.blank = TRUE) + ) e1 <- ggplot2:::calc_element("strip.text.x", theme) e2 <- ggplot2:::calc_element("strip.text", theme) expect_identical(e1, e2) # Check that rel units are computed appropriately theme <- theme_gray() + - theme(axis.ticks.length = unit(1, "cm"), - axis.ticks.length.x = rel(0.5), - axis.ticks.length.x.bottom = rel(4)) + theme( + axis.ticks.length = unit(1, "cm"), + axis.ticks.length.x = rel(0.5), + axis.ticks.length.x.bottom = rel(4) + ) expect_equal(calc_element("axis.ticks.length.y.left", theme), unit(1, "cm")) - expect_equal(calc_element("axis.ticks.length.x.top", theme), unit(1, "cm") * 0.5) - expect_equal(calc_element("axis.ticks.length.x.bottom", theme), unit(1, "cm") * 0.5 * 4) + expect_equal( + calc_element("axis.ticks.length.x.top", theme), + unit(1, "cm") * 0.5 + ) + expect_equal( + calc_element("axis.ticks.length.x.bottom", theme), + unit(1, "cm") * 0.5 * 4 + ) }) test_that("complete and non-complete themes interact correctly with each other", { @@ -220,7 +251,9 @@ test_that("complete and non-complete themes interact correctly with ggplot objec # Check that adding two theme successive theme objects to a ggplot object # works like adding the two theme object to each other - p <- ggplot_build(base + theme_bw() + theme(text = element_text(colour = 'red'))) + p <- ggplot_build( + base + theme_bw() + theme(text = element_text(colour = 'red')) + ) expect_true(attr(p@plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ @@ -230,7 +263,9 @@ test_that("complete and non-complete themes interact correctly with ggplot objec tt <- tt[order(names(tt))] expect_identical(pt, tt) - p <- ggplot_build(base + theme(text = element_text(colour = 'red')) + theme_bw()) + p <- ggplot_build( + base + theme(text = element_text(colour = 'red')) + theme_bw() + ) expect_true(attr(p@plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ pt <- p@plot@theme @@ -239,13 +274,17 @@ test_that("complete and non-complete themes interact correctly with ggplot objec tt <- tt[order(names(tt))] expect_identical(pt, tt) - p <- ggplot_build(base + theme(text = element_text(colour = 'red', face = 'italic'))) + p <- ggplot_build( + base + theme(text = element_text(colour = 'red', face = 'italic')) + ) expect_equal(p@plot@theme$text@colour, "red") expect_equal(p@plot@theme$text@face, "italic") - p <- ggplot_build(base + - theme(text = element_text(colour = 'red')) + - theme(text = element_text(face = 'italic'))) + p <- ggplot_build( + base + + theme(text = element_text(colour = 'red')) + + theme(text = element_text(face = 'italic')) + ) expect_equal(p@plot@theme$text@colour, "red") expect_equal(p@plot@theme$text@face, "italic") }) @@ -284,7 +323,10 @@ test_that("incorrect theme specifications throw meaningful errors", { expect_snapshot_error(add_theme(theme_grey(), theme(line = element_rect()))) expect_snapshot_error(calc_element("line", theme(line = element_rect()))) register_theme_elements(element_tree = list(test = el_def(element_rect))) - expect_snapshot_error(calc_element("test", theme_gray() + theme(test = element_rect()))) + expect_snapshot_error(calc_element( + "test", + theme_gray() + theme(test = element_rect()) + )) expect_snapshot_error(set_theme("foo")) reset_theme_settings() }) @@ -347,8 +389,10 @@ test_that("element tree can be modified", { test_that("all elements in complete themes have inherit.blank=TRUE", { inherit_blanks <- function(theme) { all(vapply( - theme, try_prop, - name = "inherit.blank", default = TRUE, + theme, + try_prop, + name = "inherit.blank", + default = TRUE, logical(1) )) } @@ -388,10 +432,14 @@ test_that("theme elements that don't inherit from element can be combined", { }) test_that("complete plot themes shouldn't inherit from default", { - default_theme <- theme_gray() + theme(axis.text.x = element_text(colour = "red")) + default_theme <- theme_gray() + + theme(axis.text.x = element_text(colour = "red")) base <- ggplot(data.frame(x = 1), aes(x, x)) + geom_point() - ptheme <- plot_theme(base + theme(axis.text.x = element_text(colour = "blue")), default_theme) + ptheme <- plot_theme( + base + theme(axis.text.x = element_text(colour = "blue")), + default_theme + ) expect_equal(ptheme$axis.text.x@colour, "blue") ptheme <- plot_theme(base + theme_void(), default_theme) @@ -448,10 +496,46 @@ test_that("titleGrob() and margins() work correctly", { expect_equal(height_cm(g1), height_cm(g4)) # margins - g5 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 0, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g6 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 1, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g7 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 1, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g8 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 0, l = 1, unit = "cm"), margin_x = TRUE, margin_y = TRUE) + g5 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 1, r = 0, b = 0, l = 0, unit = "cm"), + margin_x = TRUE, + margin_y = TRUE + ) + g6 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 0, r = 1, b = 0, l = 0, unit = "cm"), + margin_x = TRUE, + margin_y = TRUE + ) + g7 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 0, r = 0, b = 1, l = 0, unit = "cm"), + margin_x = TRUE, + margin_y = TRUE + ) + g8 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 0, r = 0, b = 0, l = 1, unit = "cm"), + margin_x = TRUE, + margin_y = TRUE + ) expect_equal(height_cm(g5), height_cm(g1) + 1) expect_equal(width_cm(g5), width_cm(g1)) @@ -463,8 +547,26 @@ test_that("titleGrob() and margins() work correctly", { expect_equal(width_cm(g8), width_cm(g1) + 1) # no margins when set to false - g9 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = FALSE, margin_y = TRUE) - g10 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = TRUE, margin_y = FALSE) + g9 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), + margin_x = FALSE, + margin_y = TRUE + ) + g10 <- titleGrob( + "aaaa", + 0, + 0, + 0.5, + 0.5, + margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), + margin_x = TRUE, + margin_y = FALSE + ) expect_equal(height_cm(g9), height_cm(g1) + 2) # when one of margin_x or margin_y is set to FALSE and the other to TRUE, then the dimension for FALSE turns into # length 1null. @@ -513,33 +615,50 @@ test_that("provided themes explicitly define all elements", { }) test_that("Theme elements are checked during build", { - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + theme(plot.title.position = "test") + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg)) + + theme(plot.title.position = "test") expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + theme(plot.caption.position = "test") + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg)) + + theme(plot.caption.position = "test") expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + - theme(plot.tag.position = "test") + labs(tag = "test") + p <- ggplot(mtcars) + + geom_point(aes(disp, mpg)) + + theme(plot.tag.position = "test") + + labs(tag = "test") expect_snapshot_error(ggplotGrob(p)) }) test_that("subtheme functions rename arguments as intended", { - line <- element_line(colour = "red") rect <- element_rect(colour = "red") - expect_equal(theme_sub_axis(ticks = line), theme(axis.ticks = line)) - expect_equal(theme_sub_axis_x(ticks = line), theme(axis.ticks.x = line)) - expect_equal(theme_sub_axis_y(ticks = line), theme(axis.ticks.y = line)) - expect_equal(theme_sub_axis_top(ticks = line), theme(axis.ticks.x.top = line)) - expect_equal(theme_sub_axis_bottom(ticks = line), theme(axis.ticks.x.bottom = line)) - expect_equal(theme_sub_axis_left(ticks = line), theme(axis.ticks.y.left = line)) - expect_equal(theme_sub_axis_right(ticks = line), theme(axis.ticks.y.right = line)) - expect_equal(theme_sub_legend(key = rect), theme(legend.key = rect)) - expect_equal(theme_sub_panel(border = rect), theme(panel.border = rect)) - expect_equal(theme_sub_plot(background = rect), theme(plot.background = rect)) - expect_equal(theme_sub_strip(background = rect), theme(strip.background = rect)) + expect_equal(theme_sub_axis(ticks = line), theme(axis.ticks = line)) + expect_equal(theme_sub_axis_x(ticks = line), theme(axis.ticks.x = line)) + expect_equal(theme_sub_axis_y(ticks = line), theme(axis.ticks.y = line)) + expect_equal(theme_sub_axis_top(ticks = line), theme(axis.ticks.x.top = line)) + expect_equal( + theme_sub_axis_bottom(ticks = line), + theme(axis.ticks.x.bottom = line) + ) + expect_equal( + theme_sub_axis_left(ticks = line), + theme(axis.ticks.y.left = line) + ) + expect_equal( + theme_sub_axis_right(ticks = line), + theme(axis.ticks.y.right = line) + ) + expect_equal(theme_sub_legend(key = rect), theme(legend.key = rect)) + expect_equal(theme_sub_panel(border = rect), theme(panel.border = rect)) + expect_equal(theme_sub_plot(background = rect), theme(plot.background = rect)) + expect_equal( + theme_sub_strip(background = rect), + theme(strip.background = rect) + ) # Test rejection of unknown theme elements expect_snapshot_warning( @@ -576,13 +695,12 @@ test_that("element_text throws appropriate conditions", { test_that("Theme validation behaves as expected", { tree <- get_element_tree() - expect_silent(check_element(1, "aspect.ratio", tree)) + expect_silent(check_element(1, "aspect.ratio", tree)) expect_silent(check_element(1L, "aspect.ratio", tree)) expect_snapshot_error(check_element("A", "aspect.ratio", tree)) }) test_that("Element subclasses are inherited", { - # `rich` is subclass of `poor` poor <- element_line(colour = "red", linetype = 3) rich <- element_line(linetype = 2, linewidth = 2) @@ -626,24 +744,26 @@ test_that("Element subclasses are inherited", { }) test_that("Minor tick length supports biparental inheritance", { - my_theme <- theme_gray() + theme( - axis.ticks.length = unit(1, "cm"), - axis.ticks.length.y.left = unit(1, "pt"), - axis.minor.ticks.length.y = unit(1, "inch"), - axis.minor.ticks.length = rel(0.5) - ) - expect_equal( # Inherits rel(0.5) from minor, 1cm from major + my_theme <- theme_gray() + + theme( + axis.ticks.length = unit(1, "cm"), + axis.ticks.length.y.left = unit(1, "pt"), + axis.minor.ticks.length.y = unit(1, "inch"), + axis.minor.ticks.length = rel(0.5) + ) + expect_equal( + # Inherits rel(0.5) from minor, 1cm from major calc_element("axis.minor.ticks.length.x.bottom", my_theme), unit(1, "cm") * 0.5 ) - expect_equal( # Inherits 1inch directly from minor + expect_equal( + # Inherits 1inch directly from minor calc_element("axis.minor.ticks.length.y.left", my_theme), unit(1, "inch") ) }) test_that("header_family is passed on correctly", { - td <- theme_dark(base_family = "x", header_family = "y") test <- calc_element("plot.title", td) @@ -678,14 +798,13 @@ test_that("complete_theme completes a theme", { }) test_that("panel.widths and panel.heights works with free-space panels", { - df <- data.frame(x = c(1, 1, 2, 1, 3), g = c("A", "B", "B", "C", "C")) p <- ggplotGrob( ggplot(df, aes(x, x)) + geom_point() + scale_x_continuous(expand = expansion(add = 1)) + - facet_grid(~ g, scales = "free_x", space = "free_x") + + facet_grid(~g, scales = "free_x", space = "free_x") + theme( panel.widths = unit(11, "cm"), panel.spacing.x = unit(1, "cm") @@ -708,7 +827,6 @@ test_that("panel.widths and panel.heights works with free-space panels", { idx <- range(panel_rows(p)$t) expect_equal(as.numeric(p$heights[seq(idx[1], idx[2])]), c(2, 1, 3, 1, 4)) - }) test_that("panel.widths and panel.heights appropriately warn about aspect override", { @@ -719,7 +837,6 @@ test_that("panel.widths and panel.heights appropriately warn about aspect overri }) test_that("margin_part() mechanics work as expected", { - t <- theme_gray() + theme(plot.margin = margin_part(b = 11)) @@ -744,7 +861,6 @@ test_that("theme() warns about conflicting palette options", { }) test_that("geom elements are inherited correctly", { - GeomFoo <- ggproto("GeomFoo", GeomPoint) GeomBar <- ggproto("GeomBar", GeomFoo) @@ -770,16 +886,25 @@ test_that("theme elements are covered in `theme_sub_*()` functions", { # theme element should be included in one of the `theme_sub_*` functions. fmls <- paste0("axis.", fn_fmls_names(theme_sub_axis)) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_x), ".x")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_y), ".y")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_top), ".x.top")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_bottom), ".x.bottom")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_left), ".y.left")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_right), ".y.right")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_x), ".x")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_y), ".y")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_top), ".x.top")) + fmls <- c( + fmls, + paste0("axis.", fn_fmls_names(theme_sub_axis_bottom), ".x.bottom") + ) + fmls <- c( + fmls, + paste0("axis.", fn_fmls_names(theme_sub_axis_left), ".y.left") + ) + fmls <- c( + fmls, + paste0("axis.", fn_fmls_names(theme_sub_axis_right), ".y.right") + ) fmls <- c(fmls, paste0("legend.", fn_fmls_names(theme_sub_legend))) - fmls <- c(fmls, paste0("plot.", fn_fmls_names(theme_sub_plot))) - fmls <- c(fmls, paste0("panel.", fn_fmls_names(theme_sub_panel))) - fmls <- c(fmls, paste0("strip.", fn_fmls_names(theme_sub_strip))) + fmls <- c(fmls, paste0("plot.", fn_fmls_names(theme_sub_plot))) + fmls <- c(fmls, paste0("panel.", fn_fmls_names(theme_sub_panel))) + fmls <- c(fmls, paste0("strip.", fn_fmls_names(theme_sub_strip))) extra_elements <- setdiff(fn_fmls_names(theme), fmls) expect_snapshot(extra_elements) @@ -788,13 +913,12 @@ test_that("theme elements are covered in `theme_sub_*()` functions", { # Visual tests ------------------------------------------------------------ test_that("element_polygon() can render a grob", { - t <- theme_gray() + theme(polygon = element_polygon(fill = "orchid")) e <- calc_element("polygon", t) g <- element_grob( e, - x = c(0, 0.5, 1, 0.5, 0.15, 0.85, 0.85, 0.15), - y = c(0.5, 0, 0.5, 1, 0.15, 0.15, 0.85, 0.85), + x = c(0, 0.5, 1, 0.5, 0.15, 0.85, 0.85, 0.15), + y = c(0.5, 0, 0.5, 1, 0.15, 0.15, 0.85, 0.85), id = c(1, 1, 1, 1, 2, 2, 2, 2), colour = c("orange", "limegreen") ) @@ -804,12 +928,14 @@ test_that("element_polygon() can render a grob", { expect_doppelganger( "polygon elements", - function() {grid.newpage(); grid.draw(g)} + function() { + grid.newpage() + grid.draw(g) + } ) }) test_that("element_point() can render a grob", { - t <- theme_gray() + theme(point = element_point(shape = 21, size = 5)) e <- calc_element("point", t) g <- element_grob( @@ -824,12 +950,18 @@ test_that("element_point() can render a grob", { expect_doppelganger( "point elements", - function() {grid.newpage(); grid.draw(g)} + function() { + grid.newpage() + grid.draw(g) + } ) }) test_that("aspect ratio is honored", { - df <- cbind(data_frame(x = 1:8, y = 1:8, f = gl(2,4)), expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2)) + df <- cbind( + data_frame(x = 1:8, y = 1:8, f = gl(2, 4)), + expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2) + ) p <- ggplot(df, aes(x, y)) + geom_point() + theme_test() + @@ -838,33 +970,32 @@ test_that("aspect ratio is honored", { p_a <- p + theme(aspect.ratio = 3) p_b <- p + theme(aspect.ratio = 1 / 3) - expect_doppelganger("height is 3 times width", - p_a - ) - expect_doppelganger("width is 3 times height", - p_b - ) + expect_doppelganger("height is 3 times width", p_a) + expect_doppelganger("width is 3 times height", p_b) - expect_doppelganger("height is 3 times width, 2 wrap facets", + expect_doppelganger( + "height is 3 times width, 2 wrap facets", p_a + facet_wrap(~f) ) - expect_doppelganger("height is 3 times width, 2 column facets", - p_a + facet_grid(.~f) + expect_doppelganger( + "height is 3 times width, 2 column facets", + p_a + facet_grid(. ~ f) ) - expect_doppelganger("height is 3 times width, 2 row facets", - p_a + facet_grid(f~.) + expect_doppelganger( + "height is 3 times width, 2 row facets", + p_a + facet_grid(f ~ .) ) - expect_doppelganger("height is 3 times width, 2x2 facets", - p_a + facet_grid(f1~f2) + expect_doppelganger( + "height is 3 times width, 2x2 facets", + p_a + facet_grid(f1 ~ f2) ) - }) test_that("themes don't change without acknowledgement", { df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) plot <- ggplot(df, aes(x, y, colour = z)) + geom_point() + - facet_wrap(~ a) + facet_wrap(~a) expect_doppelganger("theme_bw", plot + theme_bw()) expect_doppelganger("theme_classic", plot + theme_classic()) @@ -880,29 +1011,39 @@ test_that("themes look decent at larger base sizes", { df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) plot <- ggplot(df, aes(x, y, colour = z)) + geom_point() + - facet_wrap(~ a) + facet_wrap(~a) expect_doppelganger("theme_bw_large", plot + theme_bw(base_size = 33)) - expect_doppelganger("theme_classic_large", plot + theme_classic(base_size = 33)) + expect_doppelganger( + "theme_classic_large", + plot + theme_classic(base_size = 33) + ) expect_doppelganger("theme_dark_large", plot + theme_dark(base_size = 33)) - expect_doppelganger("theme_minimal_large", plot + theme_minimal(base_size = 33)) + expect_doppelganger( + "theme_minimal_large", + plot + theme_minimal(base_size = 33) + ) expect_doppelganger("theme_gray_large", plot + theme_gray(base_size = 33)) expect_doppelganger("theme_light_large", plot + theme_light(base_size = 33)) expect_doppelganger("theme_void_large", plot + theme_void(base_size = 33)) - expect_doppelganger("theme_linedraw_large", plot + theme_linedraw(base_size = 33)) + expect_doppelganger( + "theme_linedraw_large", + plot + theme_linedraw(base_size = 33) + ) }) test_that("setting 'spacing' and 'margins' affect the whole plot", { - df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) plot <- ggplot(df, aes(x, y, colour = z)) + geom_point() + - facet_wrap(~ a) + + facet_wrap(~a) + theme_gray() expect_doppelganger("large spacing", plot + theme(spacing = unit(1, "cm"))) - expect_doppelganger("large margins", plot + theme(margins = margin(1, 1, 1, 1, "cm"))) - + expect_doppelganger( + "large margins", + plot + theme(margins = margin(1, 1, 1, 1, "cm")) + ) }) test_that("axes can be styled independently", { @@ -965,7 +1106,8 @@ test_that("rotated axis tick labels work", { label = c("short", "medium size", "very long label") ) - plot <- ggplot(df, aes(label, y)) + geom_point() + + plot <- ggplot(df, aes(label, y)) + + geom_point() + theme(axis.text.x = element_text(angle = 50, hjust = 1)) expect_doppelganger("rotated x axis tick labels", plot) }) @@ -978,7 +1120,8 @@ test_that("plot titles and caption can be aligned to entire plot", { ) plot <- ggplot(df, aes(x, y, color = z)) + - geom_point() + facet_wrap(~z) + + geom_point() + + facet_wrap(~z) + labs( title = "Plot title aligned to entire plot", subtitle = "Subtitle aligned to entire plot", @@ -988,7 +1131,8 @@ test_that("plot titles and caption can be aligned to entire plot", { expect_doppelganger("titles aligned to entire plot", plot) plot <- ggplot(df, aes(x, y, color = z)) + - geom_point() + facet_wrap(~z) + + geom_point() + + facet_wrap(~z) + labs( title = "Plot title aligned to panels", subtitle = "Subtitle aligned to panels", @@ -996,34 +1140,33 @@ test_that("plot titles and caption can be aligned to entire plot", { ) + theme(plot.caption.position = "plot") expect_doppelganger("caption aligned to entire plot", plot) - }) test_that("Legends can on all sides of the plot with custom justification", { - plot <- ggplot(mtcars) + aes( - disp, mpg, + disp, + mpg, colour = hp, - fill = factor(gear), - shape = factor(cyl), - size = drat, + fill = factor(gear), + shape = factor(cyl), + size = drat, alpha = wt ) + geom_point() + guides( - shape = guide_legend(position = "top"), + shape = guide_legend(position = "top"), colour = guide_colourbar(position = "bottom"), - size = guide_legend(position = "left"), - alpha = guide_legend(position = "right"), - fill = guide_legend(position = "inside", override.aes = list(shape = 21)) + size = guide_legend(position = "left"), + alpha = guide_legend(position = "right"), + fill = guide_legend(position = "inside", override.aes = list(shape = 21)) ) + theme_test() + theme( - legend.justification.top = "left", + legend.justification.top = "left", legend.justification.bottom = c(1, 0), - legend.justification.left = c(0, 1), - legend.justification.right = "bottom", + legend.justification.left = c(0, 1), + legend.justification.right = "bottom", legend.justification.inside = c(0.75, 0.75), legend.location = "plot" ) @@ -1047,7 +1190,6 @@ test_that("Strips can render custom elements", { }) test_that("theme ink and paper settings work", { - p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + geom_point() + facet_wrap(~"Strip title") + @@ -1065,7 +1207,6 @@ test_that("theme ink and paper settings work", { }) test_that("legend margins are correct when using relative key sizes", { - df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) p <- ggplot(df, aes(x, y, colour = x, shape = a)) + geom_point() + @@ -1075,30 +1216,41 @@ test_that("legend margins are correct when using relative key sizes", { legend.background = element_rect(colour = "red", fill = NA) ) - vertical <- p + guides( - colour = guide_colourbar(theme = theme(legend.key.height = unit(1, "null"))), - shape = guide_legend(theme = theme(legend.key.height = unit(1/3, "null"))) - ) + theme( - legend.box.margin = margin(t = 5, b = 10, unit = "mm"), - legend.margin = margin(t = 10, b = 5, unit = "mm") - ) + vertical <- p + + guides( + colour = guide_colourbar( + theme = theme(legend.key.height = unit(1, "null")) + ), + shape = guide_legend( + theme = theme(legend.key.height = unit(1 / 3, "null")) + ) + ) + + theme( + legend.box.margin = margin(t = 5, b = 10, unit = "mm"), + legend.margin = margin(t = 10, b = 5, unit = "mm") + ) expect_doppelganger("stretched vertical legends", vertical) - horizontal <- p + guides( - colour = guide_colourbar(theme = theme(legend.key.width = unit(1, "null"))), - shape = guide_legend(theme = theme(legend.key.width = unit(1/3, "null"))) - ) + theme( - legend.position = "top", - legend.box.margin = margin(l = 5, r = 10, unit = "mm"), - legend.margin = margin(l = 10, r = 5, unit = "mm") - ) + horizontal <- p + + guides( + colour = guide_colourbar( + theme = theme(legend.key.width = unit(1, "null")) + ), + shape = guide_legend( + theme = theme(legend.key.width = unit(1 / 3, "null")) + ) + ) + + theme( + legend.position = "top", + legend.box.margin = margin(l = 5, r = 10, unit = "mm"), + legend.margin = margin(l = 10, r = 5, unit = "mm") + ) expect_doppelganger("stretched horizontal legends", horizontal) }) test_that("legends are placed correctly when using stretchy spacing", { - df <- data.frame(x = 1:3, y = 1:3, a = letters[1:3]) p <- ggplot(df, aes(x, y, colour = a, shape = factor(x))) + diff --git a/tests/testthat/test-utilities-checks.R b/tests/testthat/test-utilities-checks.R index b5207cdb90..4649516a08 100644 --- a/tests/testthat/test-utilities-checks.R +++ b/tests/testthat/test-utilities-checks.R @@ -1,6 +1,4 @@ - test_that("check_device checks R versions correctly", { - # Most widely supported device file <- withr::local_tempfile(fileext = ".pdf") withr::local_pdf(file) @@ -65,5 +63,4 @@ test_that("check_device finds device capabilities", { expect_snapshot_warning(check_device(".test_feature")), .package = "grDevices" ) - }) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 4768bbf3da..4655fc6751 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -2,29 +2,41 @@ test_that("finite_cases.data.frame", { finite_cases <- function(x) cases(x, is_finite) # All finite -------------------------------------------------------------- - expect_true(finite_cases(data_frame(x = 4))) # 1x1 - expect_true(finite_cases(data_frame(x = 4, y = 11))) # 1x2 - expect_identical(finite_cases(data_frame(x = 4:5)), c(TRUE, TRUE)) # 2x1 + expect_true(finite_cases(data_frame(x = 4))) # 1x1 + expect_true(finite_cases(data_frame(x = 4, y = 11))) # 1x2 + expect_identical(finite_cases(data_frame(x = 4:5)), c(TRUE, TRUE)) # 2x1 expect_identical(finite_cases(data_frame(x = 4:5, y = 11:12)), c(TRUE, TRUE)) # 2x2 # Has one NA -------------------------------------------------------------- - expect_false(finite_cases(data_frame(x = NA))) # 1x1 - expect_false(finite_cases(data_frame(x = 4, y = NA))) # 1x2 - expect_identical(finite_cases(data_frame(x = c(4, NA))), c(TRUE, FALSE)) # 2x1 - expect_identical(finite_cases(data_frame(x = c(4, NA), y = c(11, NA))), c(TRUE, FALSE)) # 2x2 - expect_identical(finite_cases(data_frame(x = c(4, NA), y = c(NA, 12))), c(FALSE, FALSE)) # 2x2 - expect_identical(finite_cases(data_frame(x = c(4, 5), y = c(NA, 12))), c(FALSE, TRUE)) # 2x2 + expect_false(finite_cases(data_frame(x = NA))) # 1x1 + expect_false(finite_cases(data_frame(x = 4, y = NA))) # 1x2 + expect_identical(finite_cases(data_frame(x = c(4, NA))), c(TRUE, FALSE)) # 2x1 + expect_identical( + finite_cases(data_frame(x = c(4, NA), y = c(11, NA))), + c(TRUE, FALSE) + ) # 2x2 + expect_identical( + finite_cases(data_frame(x = c(4, NA), y = c(NA, 12))), + c(FALSE, FALSE) + ) # 2x2 + expect_identical( + finite_cases(data_frame(x = c(4, 5), y = c(NA, 12))), + c(FALSE, TRUE) + ) # 2x2 # Testing NaN and Inf, using miscellaneous data shapes -------------------- - expect_identical(finite_cases(data_frame(x = c(4, NaN))), c(TRUE, FALSE)) + expect_identical(finite_cases(data_frame(x = c(4, NaN))), c(TRUE, FALSE)) expect_false(finite_cases(data_frame(x = Inf))) - expect_identical(finite_cases(data_frame(x = c(4, 5), y = c(-Inf, 12))), c(FALSE, TRUE)) + expect_identical( + finite_cases(data_frame(x = c(4, 5), y = c(-Inf, 12))), + c(FALSE, TRUE) + ) }) test_that("add_group", { - data <- data_frame(f=letters[7:9], x=1:3, y=4:6, group=c(1, -1, 1)) - expect_true(has_groups(add_group(data[2:4]))) # explicit group column - expect_true(has_groups(add_group(data[1:3]))) # discrete column + data <- data_frame(f = letters[7:9], x = 1:3, y = 4:6, group = c(1, -1, 1)) + expect_true(has_groups(add_group(data[2:4]))) # explicit group column + expect_true(has_groups(add_group(data[1:3]))) # discrete column expect_false(has_groups(add_group(data[2:3]))) # no group or discrete column }) @@ -37,7 +49,9 @@ test_that("find_args behaves correctly", { # Ellipsis is not an element expect_false("..." %in% names(test_fun())) # Args are added - expect_true(all(c("arg1", "arg2", "arg3") %in% names(test_fun(arg1 = 1, arg2 = 1, arg3 = 1)))) + expect_true(all( + c("arg1", "arg2", "arg3") %in% names(test_fun(arg1 = 1, arg2 = 1, arg3 = 1)) + )) # Defaults are overwritten expect_true(test_fun(arg2 = TRUE)$arg2) }) @@ -93,11 +107,27 @@ test_that("x and y aesthetics have the same length", { test_that("check_required_aesthetics() errors on missing", { required_single <- c("x", "y") required_bidirectional <- c("x|y", "fill") - expect_snapshot_error(check_required_aesthetics(required_single, present = "x", name = "test")) - expect_snapshot_error(check_required_aesthetics(required_single, present = "shape", name = "test")) - - expect_snapshot_error(check_required_aesthetics(required_bidirectional, present = "fill", name = "test")) - expect_snapshot_error(check_required_aesthetics(required_bidirectional, present = "shape", name = "test")) + expect_snapshot_error(check_required_aesthetics( + required_single, + present = "x", + name = "test" + )) + expect_snapshot_error(check_required_aesthetics( + required_single, + present = "shape", + name = "test" + )) + + expect_snapshot_error(check_required_aesthetics( + required_bidirectional, + present = "fill", + name = "test" + )) + expect_snapshot_error(check_required_aesthetics( + required_bidirectional, + present = "shape", + name = "test" + )) }) test_that("remove_missing checks input", { @@ -131,7 +161,6 @@ test_that("cut_*() checks its input and output", { }) test_that("vec_rbind0 can combined ordered factors", { - withr::local_options(lifecycle_verbosity = "warning") # Ideally code below throws just 1 warning (the and one) @@ -155,23 +184,21 @@ test_that("vec_rbind0 can combined ordered factors", { expect_s3_class(test$a, "factor", exact = TRUE) # Test levels are combined sensibly expect_equal(levels(test$a), c("A", "B", "C")) - }) test_that("resolution() gives correct answers", { - expect_equal(resolution(c(4, 6)), 2) + expect_equal(resolution(c(4, 6)), 2) expect_equal(resolution(c(4L, 6L)), 1L) expect_equal(resolution(mapped_discrete(c(4, 6)), discrete = TRUE), 1L) expect_equal(resolution(mapped_discrete(c(4, 6))), 2) expect_equal(resolution(c(0, 0)), 1L) - expect_equal(resolution(c(0.5, 1.5), zero = TRUE), 0.5) + expect_equal(resolution(c(0.5, 1.5), zero = TRUE), 0.5) # resolution has a tolerance expect_equal(resolution(c(1, 1 + 1000 * .Machine$double.eps, 2)), 1) }) test_that("expose/ignore_data() can round-trip a data.frame", { - # Plain data.frame df <- data_frame0(a = 1:3, b = 4:6, c = LETTERS[1:3], d = LETTERS[4:6]) expect_equal(list(df), .ignore_data(df)) @@ -185,11 +212,9 @@ test_that("expose/ignore_data() can round-trip a data.frame", { test <- .expose_data(test)[[1]] expect_equal(test, df[, c("a", "c", "b", "d")]) - }) test_that("allow_lambda converts the correct cases", { - f <- allow_lambda(function(x) x + 1) expect_equal(f(1), 2) @@ -202,7 +227,7 @@ test_that("allow_lambda converts the correct cases", { f <- allow_lambda(expression(A)) expect_equal(f, expression(A)) - f <- allow_lambda(bquote("foo"~"bar")) + f <- allow_lambda(bquote("foo" ~ "bar")) expect_equal(f, call("~", "foo", "bar")) })