diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 37117d0a2f..430ac87c5d 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -10,7 +10,9 @@ on: pull_request: branches: [main, master] -name: R-CMD-check +name: R-CMD-check.yaml + +permissions: read-all jobs: R-CMD-check: @@ -25,17 +27,15 @@ jobs: - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} - # Use 3.6 to trigger usage of RTools35 - - {os: windows-latest, r: '3.6'} - # use 4.1 to check with rtools40's older compiler - - {os: windows-latest, r: '4.1'} + # use 4.0 or 4.1 to check with rtools40's older compiler + - {os: windows-latest, r: 'oldrel-4'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} - - {os: ubuntu-latest, r: 'oldrel-2'} - - {os: ubuntu-latest, r: 'oldrel-3'} - - {os: ubuntu-latest, r: 'oldrel-4'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + - {os: ubuntu-latest, r: 'oldrel-2'} + - {os: ubuntu-latest, r: 'oldrel-3'} + - {os: ubuntu-latest, r: 'oldrel-4'} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -48,7 +48,7 @@ jobs: VDIFFR_LOG_PATH: "../vdiffr.Rout.fail" steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-pandoc@v2 @@ -63,10 +63,11 @@ jobs: cache-version: 3 extra-packages: > any::rcmdcheck, - Hmisc=?ignore-before-r=4.1.0, - quantreg=?ignore-before-r=3.6.0, + Hmisc=?ignore-before-r=4.2.0, + quantreg=?ignore-before-r=4.3.0 needs: check - uses: r-lib/actions/check-r-package@v2 with: upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 087f0b05fc..4bbce75080 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -9,7 +9,9 @@ on: types: [published] workflow_dispatch: -name: pkgdown +name: pkgdown.yaml + +permissions: read-all jobs: pkgdown: @@ -19,8 +21,10 @@ jobs: group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-pandoc@v2 @@ -39,7 +43,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@v4.4.1 + uses: JamesIves/github-pages-deploy-action@v4.5.0 with: clean: false branch: gh-pages diff --git a/.github/workflows/pr-commands.yaml b/.github/workflows/pr-commands.yaml index 71f335b3ea..2edd93f27e 100644 --- a/.github/workflows/pr-commands.yaml +++ b/.github/workflows/pr-commands.yaml @@ -4,7 +4,9 @@ on: issue_comment: types: [created] -name: Commands +name: pr-commands.yaml + +permissions: read-all jobs: document: @@ -13,8 +15,10 @@ jobs: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/pr-fetch@v2 with: @@ -50,8 +54,10 @@ jobs: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/pr-fetch@v2 with: diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 2c5bb50294..988226098e 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -6,7 +6,9 @@ on: pull_request: branches: [main, master] -name: test-coverage +name: test-coverage.yaml + +permissions: read-all jobs: test-coverage: @@ -15,7 +17,7 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 with: @@ -23,28 +25,37 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::covr + extra-packages: any::covr, any::xml2 needs: coverage - name: Test coverage run: | - covr::codecov( + cov <- covr::package_coverage( quiet = FALSE, clean = FALSE, - install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + covr::to_cobertura(cov) shell: Rscript {0} + - uses: codecov/codecov-action@v4 + with: + fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + - name: Show testthat output if: always() run: | ## -------------------------------------------------------------------- - find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true shell: bash - name: Upload test results if: failure() - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: coverage-test-failures path: ${{ runner.temp }}/package diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 8796efb5d8..77553769db 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -61,20 +61,19 @@ Each of these steps are described in more detail below. This might feel overwhelming the first time you get set up, but it gets easier with practice. If you get stuck at any point, please reach out for help on the [ggplot2-dev](https://groups.google.com/forum/#!forum/ggplot2-dev) mailing list. -If you're not familiar with git or github, please start by reading +If you're not familiar with git or github, please start by reading Pull requests will be evaluated against a seven point checklist: @@ -100,20 +99,16 @@ Pull requests will be evaluated against a seven point checklist: and don't submit any others until the first one has been processed. 1. __Use ggplot2 coding style__. Please follow the - [official tidyverse style](http://style.tidyverse.org). Maintaining + [official tidyverse style](https://style.tidyverse.org). Maintaining a consistent style across the whole code base makes it much easier to jump into the code. If you're modifying existing ggplot2 code that doesn't follow the style guide, a separate pull request to fix the style would be greatly appreciated. 1. If you're adding new parameters or a new function, you'll also need - to document them with [roxygen](https://github.com/klutometis/roxygen). + to document them with [roxygen2](https://github.com/r-lib/roxygen2). Make sure to re-run `devtools::document()` on the code before submitting. - Currently, ggplot2 uses the development version of roxygen2, which you - can get with `install_github("klutometis/roxygen")`. This will be - available on CRAN in the near future. - 1. If fixing a bug or adding a new feature to a non-graphical function, please add a [testthat](https://github.com/r-lib/testthat) unit test. diff --git a/DESCRIPTION b/DESCRIPTION index 7b20a5786c..88c801aaf7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,24 +30,21 @@ License: MIT + file LICENSE URL: https://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2 BugReports: https://github.com/tidyverse/ggplot2/issues Depends: - R (>= 3.5) + R (>= 4.0) Imports: cli, - glue, grDevices, grid, - gtable (>= 0.1.1), + gtable (>= 0.3.6), isoband, lifecycle (> 1.0.1), - MASS, - mgcv, rlang (>= 1.1.0), scales (>= 1.3.0), stats, - tibble, vctrs (>= 0.6.0), withr (>= 2.5.0) Suggests: + broom, covr, dplyr, ggplot2movies, @@ -56,6 +53,8 @@ Suggests: knitr, mapproj, maps, + MASS, + mgcv, multcomp, munsell, nlme, @@ -67,7 +66,8 @@ Suggests: rpart, sf (>= 0.7-3), svglite (>= 2.1.2), - testthat (>= 3.1.2), + testthat (>= 3.1.5), + tibble, vdiffr (>= 1.0.6), xml2 Enhances: @@ -76,6 +76,7 @@ VignetteBuilder: knitr Config/Needs/website: ggtext, tidyr, forcats, tidyverse/tidytemplate Config/testthat/edition: 3 +Config/usethis/last-upkeep: 2024-10-24 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) @@ -126,15 +127,15 @@ Collate: 'facet-grid-.R' 'facet-null.R' 'facet-wrap.R' - 'fortify-lm.R' 'fortify-map.R' - 'fortify-multcomp.R' + 'fortify-models.R' 'fortify-spatial.R' 'fortify.R' 'stat-.R' 'geom-abline.R' 'geom-rect.R' 'geom-bar.R' + 'geom-tile.R' 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' @@ -151,7 +152,6 @@ Collate: 'geom-density2d.R' 'geom-dotplot.R' 'geom-errorbar.R' - 'geom-errorbarh.R' 'geom-freqpoly.R' 'geom-function.R' 'geom-hex.R' @@ -168,7 +168,6 @@ Collate: 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' - 'geom-tile.R' 'geom-violin.R' 'geom-vline.R' 'ggplot2-package.R' @@ -243,10 +242,12 @@ Collate: 'scales-.R' 'stat-align.R' 'stat-bin.R' + 'stat-summary-2d.R' 'stat-bin2d.R' 'stat-bindot.R' 'stat-binhex.R' 'stat-boxplot.R' + 'stat-connect.R' 'stat-contour.R' 'stat-count.R' 'stat-density-2d.R' @@ -255,6 +256,7 @@ Collate: 'stat-ellipse.R' 'stat-function.R' 'stat-identity.R' + 'stat-manual.R' 'stat-qq-line.R' 'stat-qq.R' 'stat-quantilemethods.R' @@ -263,7 +265,6 @@ Collate: 'stat-smooth-methods.R' 'stat-smooth.R' 'stat-sum.R' - 'stat-summary-2d.R' 'stat-summary-bin.R' 'stat-summary-hex.R' 'stat-summary.R' @@ -274,10 +275,10 @@ Collate: 'theme.R' 'theme-defaults.R' 'theme-current.R' + 'theme-sub.R' 'utilities-break.R' 'utilities-grid.R' 'utilities-help.R' - 'utilities-matrix.R' 'utilities-patterns.R' 'utilities-resolution.R' 'utilities-tidy-eval.R' diff --git a/LICENSE.md b/LICENSE.md index 0a8a19674c..ce73598634 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2020 ggplot2 authors +Copyright (c) 2024 ggplot2 core developer team Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/NAMESPACE b/NAMESPACE index dad650eafe..f7c5c59f78 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,8 @@ S3method("[[",ggproto) S3method("[[<-",uneval) S3method(.DollarNames,ggproto) S3method(as.data.frame,mapped_discrete) +S3method(as.gtable,ggplot) +S3method(as.gtable,ggplot_built) S3method(as.list,ggproto) S3method(autolayer,default) S3method(autoplot,default) @@ -20,6 +22,8 @@ S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(element_grob,element_blank) S3method(element_grob,element_line) +S3method(element_grob,element_point) +S3method(element_grob,element_polygon) S3method(element_grob,element_rect) S3method(element_grob,element_text) S3method(format,ggproto) @@ -84,8 +88,6 @@ S3method(guide_train,default) S3method(guide_transform,default) S3method(heightDetails,titleGrob) S3method(heightDetails,zeroGrob) -S3method(interleave,default) -S3method(interleave,unit) S3method(limits,Date) S3method(limits,POSIXct) S3method(limits,POSIXlt) @@ -96,6 +98,7 @@ S3method(makeContext,dotstackGrob) S3method(merge_element,default) S3method(merge_element,element) S3method(merge_element,element_blank) +S3method(merge_element,margin) S3method(pattern_alpha,GridPattern) S3method(pattern_alpha,GridTilingPattern) S3method(pattern_alpha,default) @@ -126,8 +129,6 @@ S3method(scale_type,logical) S3method(scale_type,numeric) S3method(scale_type,ordered) S3method(scale_type,sfc) -S3method(single_value,default) -S3method(single_value,factor) S3method(summary,ggplot) S3method(vec_cast,character.mapped_discrete) S3method(vec_cast,double.mapped_discrete) @@ -176,6 +177,7 @@ export(GeomAbline) export(GeomAnnotationMap) export(GeomArea) export(GeomBar) +export(GeomBin2d) export(GeomBlank) export(GeomBoxplot) export(GeomCol) @@ -257,6 +259,7 @@ export(StatBin2d) export(StatBindot) export(StatBinhex) export(StatBoxplot) +export(StatConnect) export(StatContour) export(StatContourFilled) export(StatCount) @@ -267,6 +270,7 @@ export(StatEcdf) export(StatEllipse) export(StatFunction) export(StatIdentity) +export(StatManual) export(StatQq) export(StatQqLine) export(StatQuantile) @@ -305,6 +309,7 @@ export(borders) export(calc_element) export(check_device) export(combine_vars) +export(complete_theme) export(continuous_scale) export(coord_cartesian) export(coord_equal) @@ -343,8 +348,10 @@ export(draw_key_vpath) export(dup_axis) export(el_def) export(element_blank) +export(element_geom) export(element_grob) export(element_line) +export(element_point) export(element_rect) export(element_render) export(element_text) @@ -366,6 +373,7 @@ export(find_panel) export(flip_data) export(flipped_names) export(fortify) +export(from_theme) export(geom_abline) export(geom_area) export(geom_bar) @@ -424,7 +432,14 @@ export(get_element_tree) export(get_geom_defaults) export(get_guide_data) export(get_labs) +export(get_last_plot) +export(get_layer_data) +export(get_layer_grob) +export(get_panel_scales) +export(get_strip_labels) +export(get_theme) export(gg_dep) +export(gg_par) export(ggplot) export(ggplotGrob) export(ggplot_add) @@ -458,6 +473,7 @@ export(is.facet) export(is.ggplot) export(is.ggproto) export(is.theme) +export(is.waiver) export(is_coord) export(is_facet) export(is_geom) @@ -490,6 +506,8 @@ export(layer_sf) export(lims) export(map_data) export(margin) +export(margin_auto) +export(margin_part) export(max_height) export(max_width) export(mean_cl_boot) @@ -521,6 +539,9 @@ export(rel) export(remove_missing) export(render_axes) export(render_strips) +export(replace_theme) +export(reset_geom_defaults) +export(reset_stat_defaults) export(reset_theme_settings) export(resolution) export(scale_alpha) @@ -656,6 +677,7 @@ export(scale_y_sqrt) export(scale_y_time) export(sec_axis) export(set_last_plot) +export(set_theme) export(sf_transform_xy) export(should_stop) export(stage) @@ -668,6 +690,7 @@ export(stat_bin_2d) export(stat_bin_hex) export(stat_binhex) export(stat_boxplot) +export(stat_connect) export(stat_contour) export(stat_contour_filled) export(stat_count) @@ -680,6 +703,7 @@ export(stat_ecdf) export(stat_ellipse) export(stat_function) export(stat_identity) +export(stat_manual) export(stat_qq) export(stat_qq_line) export(stat_quantile) @@ -712,6 +736,17 @@ export(theme_linedraw) export(theme_minimal) export(theme_replace) export(theme_set) +export(theme_sub_axis) +export(theme_sub_axis_bottom) +export(theme_sub_axis_left) +export(theme_sub_axis_right) +export(theme_sub_axis_top) +export(theme_sub_axis_x) +export(theme_sub_axis_y) +export(theme_sub_legend) +export(theme_sub_panel) +export(theme_sub_plot) +export(theme_sub_strip) export(theme_test) export(theme_update) export(theme_void) @@ -721,6 +756,7 @@ export(unit) export(update_geom_defaults) export(update_labels) export(update_stat_defaults) +export(update_theme) export(vars) export(waiver) export(wrap_dims) @@ -734,14 +770,11 @@ import(gtable) import(rlang) import(scales) import(vctrs) -importFrom(glue,glue) -importFrom(glue,glue_collapse) importFrom(grid,arrow) importFrom(grid,unit) importFrom(lifecycle,deprecated) importFrom(scales,alpha) importFrom(stats,setNames) -importFrom(tibble,tibble) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/NEWS.md b/NEWS.md index ec738d6c09..d849bdee68 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +20,351 @@ to gracefully prepare for changes in the next major release. # ggplot2 3.5.1 This is a small release focusing on fixing regressions from 3.5.0 and +* Facet gains a new method `setup_panel_params` to interact with the panel_params setted by Coord object (@Yunuuuu, #6397, #6380) +* `position_fill()` avoids stacking observations of zero (@teunbrand, #6338) +* New `layer(layout)` argument to interact with facets (@teunbrand, #3062) +* New `stat_connect()` to connect points via steps or other shapes + (@teunbrand, #6228) +* Fixed regression with incorrectly drawn gridlines when using `coord_flip()` + (@teunbrand, #6293). +* Deprecated functions and arguments prior to ggplot2 3.0.0 throw errors instead + of warnings. +* Functions and arguments that were soft-deprecated up to ggplot2 3.4.0 now + throw warnings. +* (internal) layer data can be attenuated with parameter attributes + (@teunbrand, #3175). +* Date scales silently coerce to and datetime scales silently + coerce to (@laurabrianna, #3533) +* New parameters for `geom_label()` (@teunbrand and @steveharoz, #5365): + * The `linewidth` aesthetic is now applied and replaces the `label.size` + argument. + * The `linetype` aesthetic is now applied. + * New `border.colour` argument to set the colour of borders. + * New `text.colour` argument to set the colour of text. +* New `element_point()` and `element_polygon()` that can be given to + `theme(point, polygon)` as an extension point (@teunbrand, #6248). +* Turned off fallback for `size` to `linewidth` translation in + `geom_bar()`/`geom_col()` (#4848). +* `coord_radial()` now displays no axis instead of throwing an error when + a scale has no breaks (@teunbrand, #6271). +* The `fatten` argument has been deprecated in `geom_boxplot()`, + `geom_crossbar()` and `geom_pointrange()` (@teunbrand, #4881). +* Axis labels are now preserved better when using `coord_sf(expand = TRUE)` and + graticule lines are straight but do not meet the edge (@teunbrand, #2985). +* Attempt to boost detail in `coord_polar()` and `coord_radial()` near the + center (@teunbrand, #5023) +* Scale names, guide titles and aesthetic labels can now accept functions + (@teunbrand, #4313) +* Binned scales with zero-width data expand the default limits by 0.1 + (@teunbrand, #5066) +* New default `geom_qq_line(geom = "abline")` for better clipping in the + vertical direction. In addition, `slope` and `intercept` are new computed + variables in `stat_qq_line()` (@teunbrand, #6087). +* Position adjustments can now have auxiliary aesthetics (@teunbrand). + * `position_nudge()` gains `nudge_x` and `nudge_y` aesthetics (#3026, #5445). + * `position_dodge()` gains `order` aesthetic (#3022, #3345) +* More stability for vctrs-based palettes (@teunbrand, #6117). +* Fixed regression in `guide_bins(reverse = TRUE)` (@teunbrand, #6183). +* New function family for setting parts of a theme. For example, you can now use + `theme_sub_axis(line, text, ticks, ticks.length, line)` as a substitute for + `theme(axis.line, axis.text, axis.ticks, axis.ticks.length, axis.line)`. This + should allow slightly terser and more organised theme declarations + (@teunbrand, #5301). +* `scale_{x/y}_discrete(continuous.limits)` is a new argument to control the + display range of discrete scales (@teunbrand, #4174, #6259). +* `geom_ribbon()` now appropriately warns about, and removes, missing values + (@teunbrand, #6243). +* `guide_*()` can now accept two inside legend theme elements: + `legend.position.inside` and `legend.justification.inside`, allowing inside + legends to be placed at different positions. Only inside legends with the same + position and justification will be merged (@Yunuuuu, #6210). +* New stat: `stat_manual()` for arbitrary computations (@teunbrand, #3501) +* Reversal of a dimension, typically 'x' or 'y', is now controlled by the + `reverse` argument in `coord_cartesian()`, `coord_fixed()`, `coord_radial()` + and `coord_sf()`. In `coord_radial()`, this replaces the older `direction` + argument (#4021, @teunbrand). +* `coord_radial()` displays minor gridlines now (@teunbrand). +* (internal) `continuous_scale()` and `binned_scale()` sort the `limits` + argument internally (@teunbrand). +* Theme margins can have NA-units to inherit from parent elements. The new + function `margin_part()` has NA-units as default (@teunbrand, #6115) +* New `margin_auto()` specification for theme margins. +* New argument `labs(dictionary)` to label based on variable name rather than + based on aesthetic (@teunbrand, #5178) +* Fixed bug in out-of-bounds binned breaks (@teunbrand, #6054) +* Binned guides now accept expressions as labels (@teunbrand, #6005) +* (internal) `Scale$get_labels()` format expressions as lists. +* In non-orthogonal coordinate systems (`coord_sf()`, `coord_polar()` and + `coord_radial()`), using 'AsIs' variables escape transformation when + both `x` and `y` is an 'AsIs' variable (@teunbrand, #6205). +* The following methods have been deprecated: `fortify.lm()`, `fortify.glht()`, + `fortify.confint.glht()`, `fortify.summary.glht()` and `fortify.cld()`. It + is recommend to use `broom::augment()` and `broom::tidy()` instead + (@teunbrand, #3816). +* Custom and raster annotation now respond to scale transformations, and can + use AsIs variables for relative placement (@teunbrand based on + @yutannihilation's prior work, #3120) +* When discrete breaks have names, they'll be used as labels by default + (@teunbrand, #6147). +* The helper function `is.waiver()` is now exported to help extensions to work + with `waiver()` objects (@arcresu, #6173). +* Date(time) scales now throw appropriate errors when `date_breaks`, + `date_minor_breaks` or `date_labels` are not strings (@RodDalBen, #5880) +* `geom_errorbarh()` is deprecated in favour of + `geom_errorbar(orientation = "y")` (@teunbrand, #5961). +* `geom_contour()` should be able to recognise a rotated grid of points + (@teunbrand, #4320) +* `geom_boxplot()` gains additional arguments to style the colour, linetype and + linewidths of the box, whiskers, median line and staples (@teunbrand, #5126) +* `geom_violin()` gains additional arguments to style the colour, linetype and + linewidths of the quantiles, which replace the now-deprecated `draw_quantiles` + argument (#5912). +* (breaking) `geom_violin(quantiles)` now has actual quantiles based on + the data, rather than inferred quantiles based on the computed density. The + `quantiles` parameter that replaces `draw_quantiles` now belongs to + `stat_ydensity()` instead of `geom_violin()` (@teunbrand, #4120). +* (internal) Using `after_scale()` in the `Geom*$default_aes()` field is now + evaluated in the context of data (@teunbrand, #6135) +* Fixed bug where binned scales wouldn't simultaneously accept transformations + and function-limits (@teunbrand, #6144). +* Fixed bug where the `ggplot2::`-prefix did not work with `stage()` + (@teunbrand, #6104). +* New `get_labs()` function for retrieving completed plot labels + (@teunbrand, #6008). +* Built-in `theme_*()` functions now have `ink` and `paper` arguments to control + foreground and background colours respectively (@teunbrand) +* The `summary()` method for ggplots is now more terse about facets + (@teunbrand, #5989). +* `guide_bins()`, `guide_colourbar()` and `guide_coloursteps()` gain an `angle` + argument to overrule theme settings, similar to `guide_axis(angle)` + (@teunbrand, #4594). +* `coord_*(expand)` can now take a logical vector to control expansion at any + side of the panel (top, right, bottom, left) (@teunbrand, #6020) +* (Breaking) The defaults for all geoms can be set at one in the theme. + (@teunbrand based on pioneering work by @dpseidel, #2239) + * A new `theme(geom)` argument is used to track these defaults. + * The `element_geom()` function can be used to populate that argument. + * The `from_theme()` function allows access to the theme default fields from + inside the `aes()` function. +* Passing empty unmapped aesthetics to layers raises a warning instead of + throwing an error (@teunbrand, #6009). +* Moved {mgcv} from Imports to Suggests (@teunbrand, #5986) +* New `reset_geom_defaults()` and `reset_stat_defaults()` to restore all geom or + stat default aesthetics at once (@teunbrand, #5975). +* `facet_wrap()` can have `space = "free_x"` with 1-row layouts and + `space = "free_y"` with 1-column layouts (@teunbrand) +* Secondary axes respect `n.breaks` setting in continuous scales (@teunbrand, #4483). +* Layers can have names (@teunbrand, #4066). +* (internal) improvements to `pal_qualitative()` (@teunbrand, #5013) +* `coord_radial(clip = "on")` clips to the panel area when the graphics device + supports clipping paths (@teunbrand, #5952). +* (internal) Panel clipping responsibility moved from Facet class to Coord + class through new `Coord$draw_panel()` method. +* `theme(strip.clip)` now defaults to `"on"` and is independent of Coord + clipping (@teunbrand, 5952). +* (internal) rearranged the code of `Facet$draw_panels()` method (@teunbrand). +* Axis labels are now justified across facet panels (@teunbrand, #5820) +* Fixed bug in `stat_function()` so x-axis title now produced automatically + when no data added. (@phispu, #5647). +* geom_sf now accepts shape names (@sierrajohnson, #5808) +* Added `gg` class to `labs()` (@phispu, #5553). +* Missing values from discrete palettes are no longer translated + (@teunbrand, #5929). +* Fixed bug in `facet_grid(margins = TRUE)` when using expresssions + (@teunbrand, #1864). +* `geom_step()` now supports the `orientation` argument (@teunbrand, #5936). +* `position_dodge()` and `position_jitterdodge()` now have a `reverse` argument + (@teunbrand, #3610) +* `coord_radial(r.axis.inside)` can now take a numeric value to control + placement of internally placed radius axes (@teunbrand, #5805). +* (internal) default labels are derived in `ggplot_build()` rather than + in `ggplot_add.Layer()` (@teunbrand, #5894) +* An attempt is made to use a variable's label attribute as default label + (@teunbrand, #4631) +* Themes gain an additional `header_family` argument to easily set the font + for headers and titles (#5886). +* The `plot.subtitle`, `plot.caption` and `plot.tag` theme elements now inherit + from the root `text` element instead of the `title` element (#5886). +* ggplot2 no longer imports {glue} (@teunbrand, #5986). +* `geom_rect()` can now derive the required corners positions from `x`/`width` + or `y`/`height` parameterisation (@teunbrand, #5861). +* All position scales now use the same definition of `x` and `y` aesthetics. + This lets uncommon aesthetics like `xintercept` expand scales as usual. + (#3342, #4966, @teunbrand) +* Bare numeric values provided to Date or Datetime scales get inversely + transformed (cast to Date/POSIXct) with a warning (@teunbrand). +* `stat_bin()` now accepts functions for argument `breaks` (@aijordan, #4561) +* (internal) The plot's layout now has a coord parameter that is used to + prevent setting up identical panel parameters (#5427) +* (internal) rearranged the code of `Facet$draw_panels()` method (@teunbrand). +* `geom_rug()` prints a warning when `na.rm = FALSE`, as per documentation (@pn317, #5905) +* `position_dodge(preserve = "single")` now handles multi-row geoms better, + such as `geom_violin()` (@teunbrand based on @clauswilke's work, #2801). +* `position_jitterdodge()` now dodges by `group` (@teunbrand, #3656) +* The `arrow.fill` parameter is now applied to more line-based functions: + `geom_path()`, `geom_line()`, `geom_step()` `geom_function()`, line + geometries in `geom_sf()` and `element_line()`. +* Fixed bug where binned guides would keep out-of-bounds breaks + (@teunbrand, #5870). +* The size of the `draw_key_polygon()` glyph now reflects the `linewidth` + aesthetic (#4852). +* New function `complete_theme()` to replicate how themes are handled during + plot building (#5801). +* Special getter and setter functions have been renamed for consistency, allowing + for better tab-completion with `get_*`- and `set_*`-prefixes. The old names + remain available for backward compatibility (@teunbrand, #5568). + + | New name | Old name | + | -------------------- | ----------------- | + | `get_theme()` | `theme_get()` | + | `set_theme()` | `theme_set()` | + | `replace_theme()` | `theme_replace()` | + | `update_theme()` | `theme_update()` | + | `get_last_plot()` | `last_plot()` | + | `get_layer_data()` | `layer_data()` | + | `get_layer_grob()` | `layer_grob()` | + | `get_panel_scales()` | `layer_scales()` | + +* Discrete scales now support `minor_breaks`. This may only make sense in + discrete position scales, where it affects the placement of minor ticks + and minor gridlines (#5434). +* Discrete position scales now expose the `palette` argument, which can be used + to customise spacings between levels (@teunbrand, #5770). +* The default `se` parameter in layers with `geom = "smooth"` will be `TRUE` + when the data has `ymin` and `ymax` parameters and `FALSE` if these are + absent. Note that this does not affect the default of `geom_smooth()` or + `stat_smooth()` (@teunbrand, #5572). +* The bounded density option in `stat_density()` uses a wider range to + prevent discontinuities (#5641). +* `geom_raster()` now falls back to rendering as `geom_rect()` when coordinates + are not Cartesian (#5503). +* `stat_ecdf()` now has an optional `weight` aesthetic (@teunbrand, #5058). +* Position scales combined with `coord_sf()` can now use functions in the + `breaks` argument. In addition, `n.breaks` works as intended and + `breaks = NULL` removes grid lines and axes (@teunbrand, #4622). +* (Internal) Applying defaults in `geom_sf()` has moved from the internal + `sf_grob()` to `GeomSf$use_defaults()` (@teunbrand). +* `facet_wrap()` has new options for the `dir` argument to more precisely + control panel directions. Internally `dir = "h"` or `dir = "v"` is deprecated + (@teunbrand, #5212). +* Prevented `facet_wrap(..., drop = FALSE)` from throwing spurious errors when + a character facetting variable contained `NA`s (@teunbrand, #5485). +* When facets coerce the faceting variables to factors, the 'ordered' class + is dropped (@teunbrand, #5666). +* `geom_curve()` now appropriately removes missing data instead of throwing + errors (@teunbrand, #5831). +* `update_geom_defaults()` and `update_stat_defaults()` have a reset mechanism + when using `new = NULL` and invisible return the previous defaults (#4993). +* Fixed regression in axes where `breaks = NULL` caused the axes to disappear + instead of just rendering the axis line (@teunbrand, #5816). +* `geom_point()` can be dodged vertically by using + `position_dodge(..., orientation = "y")` (@teunbrand, #5809). +* Fixed bug where `na.value` was incorrectly mapped to non-`NA` values + (@teunbrand, #5756). +* Fixed bug in `guide_custom()` that would throw error with `theme_void()` + (@teunbrand, #5856). +* New helper function `gg_par()` to translate ggplot2's interpretation of + graphical parameters to {grid}'s interpretation (@teunbrand, #5866). +* `scale_{x/y}_discrete()` can now accept a `sec.axis`. It is recommended to + only use `dup_axis()` to set custom breaks or labels, as discrete variables + cannot be transformed (@teunbrand, #3171). +* `stat_density()` has the new computed variable: `wdensity`, which is + calculated as the density times the sum of weights (@teunbrand, #4176). +* `theme()` gets new `spacing` and `margins` arguments that all other spacings + and (non-text) margins inherit from (@teunbrand, #5622). +* `geom_ribbon()` can have varying `fill` or `alpha` in linear coordinate + systems (@teunbrand, #4690). +* `geom_tile()` and `position_jitter()` computes default widths and heights + per panel instead of per layer (@teunbrand, #5740, #3722). +* The `fill` of the `panel.border` theme setting is ignored and forced to be + transparent (#5782). +* `stat_align()` skips computation when there is only 1 group and therefore + alignment is not necessary (#5788). +* `position_stack()` skips computation when all `x` values are unique and + therefore stacking is not necessary (#5788). +* A new `ggplot_build()` S3 method for classes was added, which + returns input unaltered (@teunbrand, #5800). +* `width` is implemented as aesthetic instead of parameter in `geom_col()` and + `geom_bar()` (#3142). +* Fix a bug in `position_jitterdodge()` where different jitters would be applied + to different position aesthetics of the same axis (@teunbrand, #5818). +* In `stat_bin()`, the default `boundary` is now chosen to better adhere to + the `nbin` argument (@teunbrand, #5882, #5036) +* `after_stat()` and `after_scale()` throw warnings when the computed aesthetics + are not of the correct length (#5901). +* `guide_colourbar()` now correctly hands off `position` and `available_aes` + parameters downstream (@teunbrand, #5930) +* `geom_hline()` and `geom_vline()` now have `position` argument + (@yutannihilation, #4285). +* New function `get_strip_labels()` to retrieve facet labels (@teunbrand, #4979) +* Fixed bug in `position_dodge2()`'s identification of range overlaps + (@teunbrand, #5938, #4327). +* Fixed bug where empty discrete scales weren't recognised as such + (@teunbrand, #5945). +* (internal) The summary function of `stat_summary()` and `stat_summary_bin()` + is setup once in total instead of once per group (@teunbrand, #5971) +* `facet_grid(space = "free")` can now be combined with `coord_fixed()` + (@teunbrand, #4584). +* `theme_classic()` has the following changes (@teunbrand, #5978 & #6320): + * Axis ticks are now black (`ink`-coloured) instead of dark gray. + * Axis line ends are now `"square"`. + * The panel grid is now blank at the `panel.grid` hierarchy level instead of + the `panel.grid.major` and `panel.grid.minor` levels. +* {tibble} is now suggested instead of imported (@teunbrand, #5986) +* The ellipsis argument is now checked in `fortify()`, `get_alt_text()`, + `labs()` and several guides (@teunbrand, #3196). +* `stat_summary_bin()` no longer ignores `width` parameter (@teunbrand, #4647). +* Reintroduced `drop` argument to `stat_bin()` (@teunbrand, #3449) +* (internal) removed barriers for using 2D structures as aesthetics + (@teunbrand, #4189). +* `coord_sf()` no longer errors when dealing with empty graticules (@teunbrand, #6052) +* Added `theme_transparent()` with transparent backgrounds (@topepo). +* New theme elements `palette.{aes}.discrete` and `palette.{aes}.continuous`. + Theme palettes replace palettes in scales where `palette = NULL`, which is + the new default in many scales (@teunbrand, #4696). +* `guide_axis()` no longer reserves space for blank ticks + (@teunbrand, #4722, #6069). +* `geom_abline()` clips to the panel range in the vertical direction too + (@teunbrand, #6086). +* Added `panel.widths` and `panel.heights` to `theme()` (#5338, @teunbrand). +* Standardised the calculation of `width`, which are now implemented as + aesthetics (@teunbrand, #2800). +* Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) +* Added `weight` aesthetic for `stat_ellipse()` (@teunbrand, #5272) +* Fixed a bug where the `guide_custom(order)` wasn't working (@teunbrand, #6195) +* All binning stats now use the `boundary`/`center` parametrisation rather + than `origin`, following in `stat_bin()`'s footsteps (@teunbrand). +* `stat_summary_2d()` and `stat_bin_2d()` now deal with zero-range data + more elegantly (@teunbrand, #6207). +* Munching in `coord_polar()` and `coord_radial()` now adds more detail, + particularly for data-points with a low radius near the center + (@teunbrand, #5023). +* All scales now expose the `aesthetics` parameter (@teunbrand, #5841) +* Staged expressions are handled more gracefully if legends cannot resolve them + (@teunbrand, #6264). +* New `theme(legend.key.justification)` to control the alignment of legend keys + (@teunbrand, #3669). +* Added `scale_{x/y}_time(date_breaks, date_minor_breaks, date_labels)` + (@teunbrand, #4335). +* (internal) `legend.key.width` and `legend.key.height` calculations are no + longer precomputed before guides are drawn (@teunbrand, #6339) +* `ggsave()` can write a multi-page pdf file when provided with a list of plots + (@teunbrand, #5093). +* (internal) When `validate_subclass()` fails to find a class directly, it tries + to retrieve the class via constructor functions (@teunbrand). +* (internal) The ViewScale class has a `make_fixed_copy()` method to permit + copying trained position scales (#3441). +* `draw_key_rect()` replaces a `NA` fill by the `colour` aesthetic and + `draw_key_polygon()` has 0 linewidth as internal default (@teunbrand, #5385). +* Improved consistency of curve direction in `geom_curve()` (@teunbrand, #5069) +* `linetype = NA` is now interpreted to mean 'no line' instead of raising errors + (@teunbrand, #6269). +* The default colour and fill scales have a new `palette` argument + (@teunbrand, #6064). + +# ggplot2 3.5.1 + +This is a small release focusing on fixing regressions from 3.5.0 and documentation updates. ## Bug fixes @@ -62,6 +407,7 @@ documentation updates. * `annotate()` now warns about `stat` or `position` arguments (@teunbrand, #5151) * `guide_coloursteps(even.steps = FALSE)` now works with discrete data that has been formatted by `cut()` (@teunbrand, #3877). +* `ggsave()` now offers to install svglite if needed (@eliocamp, #6166). # ggplot2 3.5.0 diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index e128fd2c15..e29d0c5d25 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -32,7 +32,7 @@ #' Below follows an overview of the three stages of evaluation and how aesthetic #' evaluation can be controlled. #' -#' ## Stage 1: direct input +#' ## Stage 1: direct input at the start #' The default is to map at the beginning, using the layer data provided by #' the user. If you want to map directly from the layer data you should not do #' anything special. This is the only stage where the original layer data can @@ -87,9 +87,11 @@ #' ``` #' #' ## Complex staging -#' If you want to map the same aesthetic multiple times, e.g. map `x` to a -#' data column for the stat, but remap it for the geom, you can use the -#' `stage()` function to collect multiple mappings. +#' Sometimes, you may want to map the same aesthetic multiple times, e.g. map +#' `x` to a data column at the start for the layer stat, but remap it later to +#' a variable from the stat transformation for the layer geom. The `stage()` +#' function allows you to control multiple mappings for the same aesthetic +#' across all three stages of evaluation. #' #' ```r #' # Use stage to modify the scaled fill @@ -97,7 +99,7 @@ #' geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4)))) #' #' # Using data for computing summary, but placing label elsewhere. -#' # Also, we're making our own computed variable to use for the label. +#' # Also, we're making our own computed variables to use for the label. #' ggplot(mpg, aes(class, displ)) + #' geom_violin() + #' stat_summary( @@ -109,6 +111,18 @@ #' fun.data = ~ round(data.frame(mean = mean(.x), sd = sd(.x)), 2) #' ) #' ``` +#' +#' Conceptually, `aes(x)` is equivalent to `aes(stage(start = x))`, and +#' `aes(after_stat(count))` is equivalent to `aes(stage(after_stat = count))`, +#' and so on. `stage()` is most useful when at least two of its arguments are +#' specified. +#' +#' ## Theme access +#' The `from_theme()` function can be used to acces the [`element_geom()`] +#' fields of the `theme(geom)` argument. Using `aes(colour = from_theme(ink))` +#' and `aes(colour = from_theme(accent))` allows swapping between foreground and +#' accent colours. +#' #' @rdname aes_eval #' @name aes_eval #' @@ -192,6 +206,13 @@ stat <- function(x) { after_scale <- function(x) { x } + +#' @rdname aes_eval +#' @export +from_theme <- function(x) { + x +} + #' @rdname aes_eval #' @export stage <- function(start = NULL, after_stat = NULL, after_scale = NULL) { @@ -205,12 +226,10 @@ stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) { } # Regex to determine if an identifier refers to a calculated aesthetic +# The pattern includes ye olde '...var...' syntax, which was +# deprecated in 3.4.0 in favour of `after_stat()` match_calculated_aes <- "^\\.\\.([a-zA-Z._]+)\\.\\.$" -is_dotted_var <- function(x) { - grepl(match_calculated_aes, x) -} - # Determine if aesthetic is calculated is_calculated_aes <- function(aesthetics, warn = FALSE) { vapply(aesthetics, is_calculated, warn = warn, logical(1), USE.NAMES = FALSE) @@ -221,6 +240,9 @@ is_scaled_aes <- function(aesthetics) { is_staged_aes <- function(aesthetics) { vapply(aesthetics, is_staged, logical(1), USE.NAMES = FALSE) } +is_themed_aes <- function(aesthetics) { + vapply(aesthetics, is_themed, logical(1), USE.NAMES = FALSE) +} is_calculated <- function(x, warn = FALSE) { if (is_call(get_expr(x), "after_stat")) { return(TRUE) @@ -229,11 +251,12 @@ is_calculated <- function(x, warn = FALSE) { if (is.null(x) || is.atomic(x)) { FALSE } else if (is.symbol(x)) { - res <- is_dotted_var(as.character(x)) + # Test if x is a dotted variable + res <- grepl(match_calculated_aes, as.character(x)) if (res && warn) { - what <- I(glue("The dot-dot notation (`{x}`)")) + what <- I(paste0("The dot-dot notation (`", x, "`)")) var <- gsub(match_calculated_aes, "\\1", as.character(x)) - with <- I(glue("`after_stat({var})`")) + with <- I(paste0("`after_stat(", var, ")`")) deprecate_warn0("3.4.0", what, with, id = "ggplot-warn-aes-dot-dot") } res @@ -242,9 +265,9 @@ is_calculated <- function(x, warn = FALSE) { } else if (is.call(x)) { if (identical(x[[1]], quote(stat))) { if (warn) { - what <- I(glue("`{expr_deparse(x)}`")) + what <- I(paste0("`", expr_deparse(x), "`")) x[[1]] <- quote(after_stat) - with <- I(glue("`{expr_deparse(x)}`")) + with <- I(paste0("`", expr_deparse(x), "`")) deprecate_warn0("3.4.0", what, with, id = "ggplot-warn-aes-stat") } TRUE @@ -263,6 +286,9 @@ is_scaled <- function(x) { is_staged <- function(x) { is_call(get_expr(x), "stage") } +is_themed <- function(x) { + is_call(get_expr(x), "from_theme") +} # Strip dots from expressions strip_dots <- function(expr, env, strip_pronoun = FALSE) { @@ -313,7 +339,7 @@ strip_stage <- function(expr) { } else if (is_call(uq_expr, "stage")) { uq_expr <- call_match(uq_expr, stage) # Prefer stat mapping if present, otherwise original mapping (fallback to - # scale mapping) but there should always be two arguments to stage() + # scale mapping) uq_expr$after_stat %||% uq_expr$start %||% uq_expr$after_scale } else { expr @@ -339,3 +365,39 @@ make_labels <- function(mapping) { } Map(default_label, names(mapping), mapping) } + +eval_aesthetics <- function(aesthetics, data, mask = NULL) { + + env <- child_env(base_env()) + + # Here we mask functions, often to replace `stage()` with context appropriate + # functions `stage_calculated()`/`stage_scaled()`. + if (length(mask) > 0) { + aesthetics <- substitute_aes(aesthetics, mask_function, mask = mask) + } + + evaled <- lapply(aesthetics, eval_tidy, data = data, env = env) + names(evaled) <- names(aesthetics) + compact(rename_aes(evaled)) +} + +# `mask` is a list of functions where `names(mask)` indicate names of functions +# that need to be replaced, and `mask[[i]]` is the function to replace it +# with. +mask_function <- function(x, mask) { + if (!is.call(x)) { + return(x) + } + nms <- names(mask) + x[-1] <- lapply(x[-1], mask_function, mask = mask) + if (!is_call(x, nms)) { + return(x) + } + for (nm in nms) { + if (is_call(x, nm)) { + x[[1]] <- mask[[nm]] + return(x) + } + } +} + diff --git a/R/aes-position.R b/R/aes-position.R index 45590cc809..40b0089200 100644 --- a/R/aes-position.R +++ b/R/aes-position.R @@ -18,6 +18,18 @@ #' `xmiddle`, `middle`, `xupper`, `upper`, `x0` and `y0`. Many of these are used #' and automatically computed in [`geom_boxplot()`]. #' +#' ## Relation to `width` and `height` +#' +#' The position aesthetics mentioned above like `x` and `y` are all location +#' based. The `width` and `height` aesthetics are closely related length +#' based aesthetics, but are not position aesthetics. Consequently, `x` and `y` +#' aesthetics respond to scale transformations, whereas the length based +#' `width` and `height` aesthetics are not transformed by scales. For example, +#' if we have the pair `x = 10, width = 2`, that gets translated to the +#' locations `xmin = 9, xmax = 11` when using the default identity scales. +#' However, the same pair becomes `xmin = 1, xmax = 100` when using log10 scales, +#' as `width = 2` in log10-space spans a 100-fold change. +#' #' @name aes_position #' @aliases x y xmin xmax ymin ymax xend yend #' diff --git a/R/aes.R b/R/aes.R index 483cd85bad..de3376071d 100644 --- a/R/aes.R +++ b/R/aes.R @@ -38,6 +38,13 @@ NULL #' #' [Delayed evaluation][aes_eval] for working with computed variables. #' +#' @note +#' Using `I()` to create objects of class 'AsIs' causes scales to ignore the +#' variable and assumes the wrapped variable is direct input for the grid +#' package. Please be aware that variables are sometimes combined, like in +#' some stats or position adjustments, that may yield unexpected results with +#' 'AsIs' variables. +#' #' @family aesthetics documentation #' @return A list with class `uneval`. Components of the list are either #' quosures or constants. @@ -181,7 +188,12 @@ standardise_aes_names <- function(x) { x <- sub("color", "colour", x, fixed = TRUE) # convert old-style aesthetics names to ggplot version - revalue(x, ggplot_global$base_to_ggplot) + convert <- ggplot_global$base_to_ggplot + convert <- convert[names(convert) %in% x] + if (length(convert) > 0) { + x[match(names(convert), x)] <- convert + } + x } # x is a list of aesthetic mappings, as generated by aes() @@ -193,9 +205,12 @@ rename_aes <- function(x) { } x } -substitute_aes <- function(x) { + +# `x` is assumed to be a strict list of quosures; +# it should have no non-quosure constants in it, even though `aes()` allows it. +substitute_aes <- function(x, fun = standardise_aes_symbols, ...) { x <- lapply(x, function(aesthetic) { - as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic)) + as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic)) }) class(x) <- "uneval" x @@ -275,7 +290,7 @@ is_position_aes <- function(vars) { #' #' @export aes_ <- function(x, y, ...) { - deprecate_soft0( + deprecate_warn0( "3.0.0", "aes_()", details = "Please use tidy evaluation idioms with `aes()`" @@ -302,7 +317,7 @@ aes_ <- function(x, y, ...) { #' @rdname aes_ #' @export aes_string <- function(x, y, ...) { - deprecate_soft0( + deprecate_warn0( "3.0.0", "aes_string()", details = c( @@ -345,7 +360,7 @@ aes_all <- function(vars) { # refer to the data mask structure( lapply(vars, function(x) new_quosure(as.name(x), emptyenv())), - class = "uneval" + class = c("unlabelled_uneval", "uneval") ) } @@ -359,29 +374,7 @@ aes_all <- function(vars) { #' @keywords internal #' @export aes_auto <- function(data = NULL, ...) { - deprecate_warn0("2.0.0", "aes_auto()") - - # detect names of data - if (is.null(data)) { - cli::cli_abort("{.fn aes_auto} requires a {.cls data.frame} or names of data.frame.") - } else if (is.data.frame(data)) { - vars <- names(data) - } else { - vars <- data - } - - # automatically detected aes - vars <- intersect(ggplot_global$all_aesthetics, vars) - names(vars) <- vars - aes <- lapply(vars, function(x) parse(text = x)[[1]]) - - # explicitly defined aes - if (length(match.call()) > 2) { - args <- as.list(match.call()[-1]) - aes <- c(aes, args[names(args) != "data"]) - } - - structure(rename_aes(aes), class = "uneval") + lifecycle::deprecate_stop("2.0.0", "aes_auto()") } mapped_aesthetics <- function(x) { @@ -452,7 +445,9 @@ arg_enquos <- function(name, frame = caller_env()) { quo <- inject(enquo0(!!sym(name)), frame) expr <- quo_get_expr(quo) - if (!is_missing(expr) && is_triple_bang(expr)) { + is_triple_bang <- !is_missing(expr) && + 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) xs <- eval_bare(expr[[2]][[2]][[2]], env) diff --git a/R/annotation-custom.R b/R/annotation-custom.R index 4261526b89..8f060efab2 100644 --- a/R/annotation-custom.R +++ b/R/annotation-custom.R @@ -70,26 +70,17 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom, draw_panel = function(data, panel_params, coord, grob, xmin, xmax, ymin, ymax) { - if (!inherits(coord, "CoordCartesian")) { - cli::cli_abort("{.fn annotation_custom} only works with {.fn coord_cartesian}.") - } - corners <- data_frame0( - x = c(xmin, xmax), - y = c(ymin, ymax), - .size = 2 + range <- ranges_annotation( + coord, panel_params, xmin, xmax, ymin, ymax, + fun = "annotation_custom" ) - data <- coord$transform(corners, panel_params) - - x_rng <- range(data$x, na.rm = TRUE) - y_rng <- range(data$y, na.rm = TRUE) - - vp <- viewport(x = mean(x_rng), y = mean(y_rng), - width = diff(x_rng), height = diff(y_rng), + 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())) }, - default_aes = aes_(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf) + default_aes = aes(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf) ) annotation_id <- local({ @@ -99,3 +90,21 @@ annotation_id <- local({ i } }) + +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}.") + } + data <- data_frame0(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax) + data <- .ignore_data(data)[[1]] + x <- panel_params$x$scale$transform_df(data) + data[names(x)] <- x + y <- panel_params$y$scale$transform_df(data) + data[names(y)] <- y + data <- .expose_data(data)[[1]] + data <- coord$transform(data, panel_params) + list( + x = range(data$xmin, data$xmax, na.rm = TRUE), + y = range(data$ymin, data$ymax, na.rm = TRUE) + ) +} diff --git a/R/annotation-logticks.R b/R/annotation-logticks.R index 8f3e8a63c2..600bd6ce7c 100644 --- a/R/annotation-logticks.R +++ b/R/annotation-logticks.R @@ -165,7 +165,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, 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) xticks$end = -xticks$end @@ -175,14 +175,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, 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 = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt) + 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 = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt) + gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) )) } } @@ -203,7 +203,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, 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) yticks$end = -yticks$end @@ -213,14 +213,14 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, 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 = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt) + 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 = gpar(col = alpha(colour, alpha), lty = linetype, lwd = linewidth * .pt) + gp = gg_par(col = alpha(colour, alpha), lty = linetype, lwd = linewidth) )) } } @@ -228,7 +228,12 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, gTree(children = inject(gList(!!!ticks))) }, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = 1) + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = 1 + ) ) @@ -238,7 +243,7 @@ GeomLogticks <- ggproto("GeomLogticks", Geom, # - 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 = .1, midend = .2, longend = .3) { + 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 diff --git a/R/annotation-map.R b/R/annotation-map.R index 86fd0e0952..c6888f2add 100644 --- a/R/annotation-map.R +++ b/R/annotation-map.R @@ -95,9 +95,9 @@ GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap, polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id, - gp = gpar( + gp = gg_par( col = data$colour, fill = alpha(data$fill, data$alpha), - lwd = data$linewidth * .pt) + lwd = data$linewidth) ) }, diff --git a/R/annotation-raster.R b/R/annotation-raster.R index 8eb8685883..2635cf05de 100644 --- a/R/annotation-raster.R +++ b/R/annotation-raster.R @@ -73,21 +73,13 @@ GeomRasterAnn <- ggproto("GeomRasterAnn", Geom, draw_panel = function(data, panel_params, coord, raster, xmin, xmax, ymin, ymax, interpolate = FALSE) { - if (!inherits(coord, "CoordCartesian")) { - cli::cli_abort("{.fn annotation_raster} only works with {.fn coord_cartesian}.") - } - corners <- data_frame0( - x = c(xmin, xmax), - y = c(ymin, ymax), - .size = 2 + range <- ranges_annotation( + 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 ) - data <- coord$transform(corners, panel_params) - - x_rng <- range(data$x, na.rm = TRUE) - y_rng <- range(data$y, na.rm = TRUE) - - rasterGrob(raster, x_rng[1], y_rng[1], - diff(x_rng), diff(y_rng), default.units = "native", - just = c("left","bottom"), interpolate = interpolate) } ) diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 088df64713..c1d024e288 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -119,7 +119,7 @@ sec_axis <- function(transform = NULL, #' @rdname sec_axis #' #' @export -dup_axis <- function(transform = ~., name = derive(), breaks = derive(), +dup_axis <- function(transform = identity, name = derive(), breaks = derive(), labels = derive(), guide = derive(), trans = deprecated()) { sec_axis(transform, trans = trans, name, breaks, labels, guide) } @@ -129,7 +129,12 @@ is.sec_axis <- function(x) { } set_sec_axis <- function(sec.axis, scale) { - if (!is.waive(sec.axis)) { + 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.") + } + } 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}.") @@ -177,9 +182,21 @@ 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.waive(scale$name)) self$name <- scale$name + if (is.derived(self$name) && !is.waiver(scale$name)) self$name <- scale$name if (is.derived(self$breaks)) self$breaks <- scale$breaks - if (is.waive(self$breaks)) self$breaks <- scale$get_transformation()$breaks + if (is.waiver(self$breaks)) { + if (scale$is_discrete()) { + self$breaks <- setNames(nm = scale$get_breaks()) + } else { + breaks <- scale$get_transformation()$breaks + n_breaks <- scale$n.breaks + if (!is.null(n_breaks) && "n" %in% fn_fmls_names(breaks)) { + self$breaks <- function(x) breaks(x, n = n_breaks) + } else { + self$breaks <- breaks + } + } + } if (is.derived(self$labels)) self$labels <- scale$labels if (is.derived(self$guide)) self$guide <- scale$guide }, @@ -214,10 +231,15 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, if (self$empty()) return() # Test for monotonicity on unexpanded range - self$mono_test(scale) + if (!scale$is_discrete()) { + self$mono_test(scale) + breaks <- self$breaks + } else { + breaks <- setNames(scale$map(self$breaks), names(self$breaks)) + } # Get scale's original range before transformation - transformation <- scale$get_transformation() + transformation <- scale$get_transformation() %||% transform_identity() along_range <- seq(range[1], range[2], length.out = self$detail) old_range <- transformation$inverse(along_range) @@ -245,7 +267,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, 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) } else { - temp_scale <- self$create_scale(new_range) + 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 @@ -294,10 +316,11 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, }, # Temporary scale for the purpose of calling break_info() - create_scale = function(self, range, transformation = transform_identity()) { + create_scale = function(self, range, transformation = transform_identity(), + breaks = self$breaks) { scale <- ggproto(NULL, ScaleContinuousPosition, name = self$name, - breaks = self$breaks, + breaks = breaks, labels = self$labels, limits = range, expand = c(0, 0), @@ -306,7 +329,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, scale$train(range) scale }, - make_title = function(title) { - title + make_title = function(...) { + ScaleContinuous$make_title(...) } ) diff --git a/R/backports.R b/R/backports.R index a3d5eb9465..7ccedc4296 100644 --- a/R/backports.R +++ b/R/backports.R @@ -67,6 +67,6 @@ on_load({ as.mask <- grid::as.mask } if ("linearGradient" %in% getNamespaceExports("grid")) { - linearGradient <- grid::linearGradient() + linearGradient <- grid::linearGradient } }) diff --git a/R/bin.R b/R/bin.R index 8ca4bff921..1318a180e0 100644 --- a/R/bin.R +++ b/R/bin.R @@ -54,21 +54,12 @@ bin_breaks <- function(breaks, closed = c("right", "left")) { bin_breaks_width <- function(x_range, width = NULL, center = NULL, boundary = NULL, closed = c("right", "left")) { - if (length(x_range) != 2) { - cli::cli_abort("{.arg x_range} must have two elements.") - } - - # binwidth seems to be the argument name supplied to width. (stat-bin and stat-bindot) - check_number_decimal(width, min = 0, allow_infinite = FALSE, arg = "binwidth") - if (!is.null(boundary) && !is.null(center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.") - } else if (is.null(boundary)) { + if (is.null(boundary)) { if (is.null(center)) { # If neither edge nor center given, compute both using tile layer's # algorithm. This puts min and max of data in outer half of their bins. boundary <- width / 2 - } else { # If center given but not boundary, compute boundary. boundary <- center - width / 2 @@ -77,9 +68,6 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, # Find the left side of left-most bin: inputs could be Dates or POSIXct, so # coerce to numeric first. - x_range <- as.numeric(x_range) - width <- as.numeric(width) - boundary <- as.numeric(boundary) shift <- floor((x_range[1] - boundary) / width) origin <- boundary + shift * width @@ -106,19 +94,19 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, bin_breaks_bins <- function(x_range, bins = 30, center = NULL, boundary = NULL, closed = c("right", "left")) { - if (length(x_range) != 2) { - cli::cli_abort("{.arg x_range} must have two elements.") - } - check_number_whole(bins, min = 1) if (zero_range(x_range)) { # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data width <- 0.1 } else if (bins == 1) { width <- diff(x_range) boundary <- x_range[1] + center <- NULL } else { width <- (x_range[2] - x_range[1]) / (bins - 1) + if (is.null(center)) { + boundary <- boundary %||% x_range[1] - width / 2 + } } bin_breaks_width(x_range, width, boundary = boundary, center = center, @@ -128,6 +116,56 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL, # Compute bins ------------------------------------------------------------ +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) + + if (!is.null(breaks)) { + breaks <- allow_lambda(breaks) + if (is.function(breaks)) { + breaks <- breaks(x) + } + if (is_scale(scale) && !scale$is_discrete()) { + breaks <- scale$transform(breaks) + } + check_numeric(breaks) + bins <- bin_breaks(breaks, closed) + return(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.") + } + + if (!is.null(binwidth)) { + binwidth <- allow_lambda(binwidth) + if (is.function(binwidth)) { + binwidth <- binwidth(x) + } + check_number_decimal(binwidth, min = 0, allow_infinite = FALSE) + bins <- bin_breaks_width( + range, binwidth, + center = center, boundary = boundary, closed = closed + ) + return(bins) + } + + bins <- allow_lambda(bins) + if (is.function(bins)) { + bins <- bins(x) + } + check_number_whole(bins, min = 1, allow_infinite = FALSE) + bin_breaks_bins( + range, bins, + center = center, boundary = boundary, closed = closed + ) +} + bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { check_object(bins, is_bins, "a {.cls ggplot2_bins} object") @@ -141,8 +179,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { weight[is.na(weight)] <- 0 } - bin_idx <- cut(x, bins$fuzzy, right = bins$right_closed, - include.lowest = TRUE) + bin_idx <- bin_cut(x, bins) bin_count <- as.numeric(tapply(weight, bin_idx, sum, na.rm = TRUE)) bin_count[is.na(bin_count)] <- 0 @@ -161,7 +198,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { } # Add row for missings - if (any(is.na(bins))) { + if (anyNA(bins)) { bin_count <- c(bin_count, sum(is.na(bins))) bin_widths <- c(bin_widths, NA) bin_x <- c(bin_x, NA) @@ -170,6 +207,10 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { bin_out(bin_count, bin_x, bin_widths) } +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) { density <- count / width / sum(abs(count)) @@ -186,3 +227,47 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), .size = length(count) ) } + +bin_loc <- function(x, id) { + left <- x[-length(x)] + right <- x[-1] + + list( + left = left[id], + right = right[id], + mid = ((left + right) / 2)[id], + length = diff(x)[id] + ) +} + +fix_bin_params <- function(params, fun, version) { + + if (package_version(version) < "3.0.0") { + deprecate <- lifecycle::deprecate_stop + } else { + deprecate <- deprecate_warn0 + } + + if (!is.null(params$origin)) { + args <- paste0(fun, c("(origin)", "(boundary)")) + deprecate(version, args[1], args[2]) + params$boundary <- params$origin + params$origin <- NULL + } + + if (!is.null(params$right)) { + args <- paste0(fun, c("(right)", "(closed)")) + deprecate(version, args[1], args[2]) + params$closed <- if (isTRUE(params$right)) "right" else "left" + params$right <- NULL + } + + if (is.null(params$breaks %||% params$binwidth %||% params$bins)) { + cli::cli_inform( + "{.fn {fun}} using {.code bins = 30}. Pick better value {.arg binwidth}." + ) + params$bins <- 30 + } + + params +} diff --git a/R/compat-plyr.R b/R/compat-plyr.R index 95c317a02c..bb3ea73cb9 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -54,13 +54,13 @@ rename <- function(x, replace) { id_var <- function(x, drop = FALSE) { if (length(x) == 0) { id <- integer() - n = 0L + n <- 0L } else if (!is.null(attr(x, "n")) && !drop) { return(x) } else if (is.factor(x) && !drop) { x <- addNA(x, ifany = TRUE) id <- as.integer(x) - n <- length(levels(x)) + n <- nlevels(x) } else { levels <- sort(unique0(x), na.last = TRUE) id <- match(x, levels) @@ -166,84 +166,7 @@ join_keys <- function(x, y, by) { list(x = keys[seq_len(n_x)], y = keys[n_x + seq_len(n_y)], n = attr(keys, "n")) } -#' Replace specified values with new values, in a factor or character vector -#' -#' An easy to use substitution of elements in a string-like vector (character or -#' factor). If `x` is a character vector the matching elements will be replaced -#' directly and if `x` is a factor the matching levels will be replaced -#' -#' @param x A character or factor vector -#' @param replace A named character vector with the names corresponding to the -#' elements to replace and the values giving the replacement. -#' -#' @return A vector of the same class as `x` with the given values replaced -#' -#' @keywords internal -#' @noRd -#' -revalue <- function(x, replace) { - if (is.character(x)) { - replace <- replace[names(replace) %in% x] - if (length(replace) == 0) return(x) - x[match(names(replace), x)] <- replace - } else if (is.factor(x)) { - lev <- levels(x) - replace <- replace[names(replace) %in% lev] - if (length(replace) == 0) return(x) - lev[match(names(replace), lev)] <- replace - levels(x) <- lev - } else if (!is.null(x)) { - stop_input_type(x, "a factor or character vector") - } - x -} -# Iterate through a formula and return a quoted version -simplify_formula <- function(x) { - if (length(x) == 2 && x[[1]] == as.name("~")) { - return(simplify(x[[2]])) - } - if (length(x) < 3) - return(list(x)) - op <- x[[1]] - a <- x[[2]] - b <- x[[3]] - if (op == as.name("+") || op == as.name("*") || op == - as.name("~")) { - c(simplify(a), simplify(b)) - } - else if (op == as.name("-")) { - c(simplify(a), bquote(-.(x), list(x = simplify(b)))) - } - else { - list(x) - } -} -#' Create a quoted version of x -#' -#' This function captures the special meaning of formulas in the context of -#' facets in ggplot2, where `+` have special meaning. It works as -#' `plyr::as.quoted` but only for the special cases of `character`, `call`, and -#' `formula` input as these are the only situations relevant for ggplot2. -#' -#' @param x A formula, string, or call to be quoted -#' @param env The environment to a attach to the quoted expression. -#' -#' @keywords internal -#' @noRd -#' -as.quoted <- function(x, env = parent.frame()) { - x <- if (is.character(x)) { - lapply(x, function(x) parse(text = x)[[1]]) - } else if (is.formula(x)) { - simplify_formula(x) - } else if (is.call(x)) { - as.list(x)[-1] - } else { - cli::cli_abort("Must be a character vector, call, or formula.") - } - attributes(x) <- list(env = env, class = 'quoted') - x -} + # round a number to a given precision round_any <- function(x, accuracy, f = round) { check_numeric(x) @@ -286,29 +209,20 @@ dapply <- function(df, by, fun, ..., drop = TRUE) { } # Shortcut when only one group - if (all(vapply(grouping_cols, single_value, logical(1)))) { + has_single_group <- all(vapply( + grouping_cols, + function(x) identical(as.character(levels(x) %||% attr(x, "n")), "1"), + logical(1) + )) + if (has_single_group) { return(apply_fun(df)) } ids <- id(grouping_cols, drop = drop) group_rows <- split_with_index(seq_len(nrow(df)), ids) result <- lapply(seq_along(group_rows), function(i) { - cur_data <- df_rows(df, group_rows[[i]]) + cur_data <- vec_slice(df, group_rows[[i]]) apply_fun(cur_data) }) vec_rbind0(!!!result) } - -single_value <- function(x, ...) { - UseMethod("single_value") -} -#' @export -single_value.default <- function(x, ...) { - # This is set by id() used in creating the grouping var - identical(attr(x, "n"), 1L) -} -#' @export -single_value.factor <- function(x, ...) { - # Panels are encoded as factor numbers and can never be missing (NA) - identical(levels(x), "1") -} diff --git a/R/coord-.R b/R/coord-.R index 7e1682640e..2b560292c4 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -59,13 +59,18 @@ Coord <- ggproto("Coord", # "on" = yes, "off" = no clip = "on", + # Should any of the scales be reversed? + reverse = "none", + aspect = function(ranges) NULL, labels = function(self, labels, panel_params) { labels }, - render_fg = function(panel_params, theme) element_render(theme, "panel.border"), + render_fg = function(panel_params, theme) { + element_render(theme, "panel.border", fill = NA) + }, render_bg = function(self, panel_params, theme) { cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_bg} method.") @@ -182,11 +187,8 @@ Coord <- ggproto("Coord", # Will generally have to return FALSE for coordinate systems that enforce a fixed aspect ratio. is_free = function() FALSE, - setup_params = function(data) { - list( - guide_default = guide_axis(), - guide_missing = guide_none() - ) + setup_params = function(self, data) { + list(expand = parse_coord_expand(self$expand %||% TRUE)) }, setup_data = function(data, params = list()) { @@ -194,6 +196,11 @@ Coord <- ggproto("Coord", }, setup_layout = function(layout, params) { + # We're appending a COORD variable to the layout that determines the + # uniqueness of panel parameters. The layout uses this to prevent redundant + # setups of these parameters. + scales <- layout[c("SCALE_X", "SCALE_Y")] + layout$COORD <- vec_match(scales, unique0(scales)) layout }, @@ -201,6 +208,20 @@ Coord <- ggproto("Coord", # used as a fudge for CoordFlip and CoordPolar modify_scales = function(scales_x, scales_y) { invisible() + }, + + draw_panel = function(self, panel, params, theme) { + fg <- self$render_fg(params, theme) + bg <- self$render_bg(params, theme) + if (isTRUE(theme$panel.ontop)) { + panel <- list2(!!!panel, bg, fg) + } else { + panel <- list2(bg, !!!panel, fg) + } + gTree( + children = inject(gList(!!!panel)), + vp = viewport(clip = self$clip) + ) } ) @@ -228,6 +249,29 @@ render_axis <- function(panel_params, axis, scale, position, theme) { } } +# Elaborates an 'expand' argument for every side (top, right, bottom or left) +parse_coord_expand <- function(expand) { + if (is.numeric(expand) && all(expand %in% c(0, 1))) { + expand <- as.logical(expand) + } + check_logical(expand) + if (anyNA(expand)) { + cli::cli_abort("{.arg expand} cannot contain missing values.") + } + + if (!is_named(expand)) { + return(rep_len(expand, 4)) + } + + # Match by top/right/bottom/left + out <- rep(TRUE, 4) + i <- match(names(expand), .trbl) + if (sum(!is.na(i)) > 0) { + out[i] <- unname(expand)[!is.na(i)] + } + out +} + # Utility function to check coord limits check_coord_limits <- function( limits, arg = caller_arg(limits), call = caller_env() @@ -235,14 +279,27 @@ check_coord_limits <- function( if (is.null(limits)) { return(invisible(NULL)) } - if (!obj_is_vector(limits) || length(limits) != 2) { - what <- "{.obj_type_friendly {limits}}" - if (is.vector(limits)) { - what <- paste0(what, " of length {length(limits)}") - } - cli::cli_abort( - paste0("{.arg {arg}} must be a vector of length 2, not ", what, "."), - call = call - ) + check_object(limits, is_vector, "a vector", arg = arg, call = call) + check_length(limits, 2L, arg = arg, call = call) +} + +is_transform_immune <- function(data, coord_name) { + x <- inherits(data$x, "AsIs") + y <- inherits(data$y, "AsIs") + if (!(x || y)) { + # Neither variable is AsIs, so we need to transform + return(FALSE) + } + if (x && y) { + # Both variables are AsIs, so no need to transform + return(TRUE) } + # We're now in the `xor(x, y)` case + var <- if (x) "x" else "y" + alt <- if (x) "y" else "x" + cli::cli_warn( + "{.fn {coord_name}} cannot respect the {.cls AsIs} class of {.var {var}} \\ + when {.var {alt}} is not also {.cls AsIs}." + ) + return(FALSE) } diff --git a/R/coord-cartesian-.R b/R/coord-cartesian-.R index 35be78a285..350e9bfd86 100644 --- a/R/coord-cartesian-.R +++ b/R/coord-cartesian-.R @@ -9,6 +9,10 @@ #' @param expand If `TRUE`, the default, adds a small expansion factor to #' the limits to ensure that data and axes don't overlap. If `FALSE`, #' limits are taken exactly from the data or `xlim`/`ylim`. +#' Giving a logical vector will separately control the expansion for the four +#' directions (top, left, bottom and right). The `expand` argument will be +#' recycled to length 4 if necessary. Alternatively, can be a named logical +#' vector to control a single direction, e.g. `expand = c(bottom = FALSE)`. #' @param default Is this the default coordinate system? If `FALSE` (the default), #' then replacing this coordinate system with another one creates a message alerting #' the user that the coordinate system is being replaced. If `TRUE`, that warning @@ -21,6 +25,10 @@ #' limits are set via `xlim` and `ylim` and some data points fall outside those #' limits, then those data points may show up in places such as the axes, the #' legend, the plot title, or the plot margins. +#' @param reverse A string giving which directions to reverse. `"none"` +#' (default) keeps directions as is. `"x"` and `"y"` can be used to reverse +#' their respective directions. `"xy"` can be used to reverse both +#' directions. #' @export #' @examples #' # There are two ways of zooming the plot display: with scales or @@ -60,11 +68,12 @@ #' # displayed bigger #' d + coord_cartesian(xlim = c(0, 1)) coord_cartesian <- function(xlim = NULL, ylim = NULL, expand = TRUE, - default = FALSE, clip = "on") { + default = FALSE, clip = "on", reverse = "none") { check_coord_limits(xlim) check_coord_limits(ylim) ggproto(NULL, CoordCartesian, limits = list(x = xlim, y = ylim), + reverse = reverse, expand = expand, default = default, clip = clip @@ -93,26 +102,23 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, self$range(panel_params) }, - transform = function(data, panel_params) { - data <- transform_position(data, panel_params$x$rescale, panel_params$y$rescale) + transform = function(self, data, panel_params) { + reverse <- self$reverse %||% "none" + x <- panel_params$x[[switch(reverse, xy = , x = "reverse", "rescale")]] + y <- panel_params$y[[switch(reverse, xy = , y = "reverse", "rescale")]] + data <- transform_position(data, x, y) transform_position(data, squish_infinite, squish_infinite) }, setup_panel_params = function(self, scale_x, scale_y, params = list()) { c( - view_scales_from_scale(scale_x, self$limits$x, self$expand), - view_scales_from_scale(scale_y, self$limits$y, self$expand) + view_scales_from_scale(scale_x, self$limits$x, params$expand[c(4, 2)]), + view_scales_from_scale(scale_y, self$limits$y, params$expand[c(3, 1)]) ) }, - render_bg = function(panel_params, theme) { - guide_grid( - theme, - panel_params$x$break_positions_minor(), - panel_params$x$break_positions(), - panel_params$y$break_positions_minor(), - panel_params$y$break_positions() - ) + render_bg = function(self, panel_params, theme) { + guide_grid(theme, panel_params, self) }, render_axis_h = function(panel_params, theme) { diff --git a/R/coord-fixed.R b/R/coord-fixed.R index a942fbb28b..d48824cfc4 100644 --- a/R/coord-fixed.R +++ b/R/coord-fixed.R @@ -22,13 +22,15 @@ #' p + coord_fixed(xlim = c(15, 30)) #' #' # Resize the plot to see that the specified aspect ratio is maintained -coord_fixed <- function(ratio = 1, xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") { +coord_fixed <- function(ratio = 1, xlim = NULL, ylim = NULL, expand = TRUE, + clip = "on", reverse = "none") { check_coord_limits(xlim) check_coord_limits(ylim) ggproto(NULL, CoordFixed, limits = list(x = xlim, y = ylim), ratio = ratio, expand = expand, + reverse = reverse, clip = clip ) } diff --git a/R/coord-flip.R b/R/coord-flip.R index 7ff519d15c..502ff56f88 100644 --- a/R/coord-flip.R +++ b/R/coord-flip.R @@ -89,6 +89,7 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, }, setup_panel_params = function(self, scale_x, scale_y, params = list()) { + params$expand <- params$expand[c(2, 1, 4, 3)] parent <- ggproto_parent(CoordCartesian, self) panel_params <- parent$setup_panel_params(scale_x, scale_y, params) flip_axis_labels(panel_params) @@ -99,6 +100,7 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, }, setup_layout = function(layout, params) { + layout <- Coord$setup_layout(layout, params) # Switch the scales layout[c("SCALE_X", "SCALE_Y")] <- layout[c("SCALE_Y", "SCALE_X")] layout diff --git a/R/coord-map.R b/R/coord-map.R index d300d33dce..3ba9260206 100644 --- a/R/coord-map.R +++ b/R/coord-map.R @@ -157,7 +157,7 @@ CoordMap <- ggproto("CoordMap", Coord, transform = function(self, data, panel_params) { trans <- mproject(self, data$x, data$y, panel_params$orientation) - out <- cunion(trans[c("x", "y")], data) + out <- data_frame0(!!!defaults(trans[c("x", "y")], data)) out$x <- rescale(out$x, 0:1, panel_params$x.proj) out$y <- rescale(out$y, 0:1, panel_params$y.proj) diff --git a/R/coord-polar.R b/R/coord-polar.R index 6c8b4813b4..b8855f52b9 100644 --- a/R/coord-polar.R +++ b/R/coord-polar.R @@ -20,7 +20,7 @@ #' # to demonstrate how these common plots can be described in the #' # grammar. Use with EXTREME caution. #' -#' #' # A pie chart = stacked bar chart + polar coordinates +#' # A pie chart = stacked bar chart + polar coordinates #' pie <- ggplot(mtcars, aes(x = factor(1), fill = factor(cyl))) + #' geom_bar(width = 1) #' pie + coord_polar(theta = "y") @@ -84,7 +84,7 @@ CoordPolar <- ggproto("CoordPolar", Coord, is_free = function() TRUE, - distance = function(self, x, y, details) { + distance = function(self, x, y, details, boost = 0.75) { arc <- self$start + c(0, 2 * pi) dir <- self$direction if (self$theta == "x") { @@ -94,8 +94,8 @@ CoordPolar <- ggproto("CoordPolar", Coord, r <- rescale(x, from = details$r.range) theta <- theta_rescale_no_clip(y, details$theta.range, arc, dir) } - - dist_polar(r, theta) + # The ^boost boosts detailed munching when r is small + dist_polar(r^boost, theta) }, backtransform_range = function(self, panel_params) { @@ -137,7 +137,7 @@ CoordPolar <- ggproto("CoordPolar", Coord, ret[[n]]$sec.labels <- out$sec.labels } - details = list( + 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, @@ -180,6 +180,10 @@ CoordPolar <- ggproto("CoordPolar", Coord, }, transform = function(self, data, panel_params) { + if (is_transform_immune(data, snake_class(self))) { + return(data) + } + arc <- self$start + c(0, 2 * pi) dir <- self$direction data <- rename_data(self, data) @@ -265,7 +269,7 @@ CoordPolar <- ggproto("CoordPolar", Coord, render_fg = function(self, panel_params, theme) { if (is.null(panel_params$theta.major)) { - return(element_render(theme, "panel.border")) + return(element_render(theme, "panel.border", fill = NA)) } arc <- self$start + c(0, 2 * pi) dir <- self$direction @@ -297,7 +301,7 @@ CoordPolar <- ggproto("CoordPolar", Coord, unit(0.45 * cos(theta) + 0.5, "native"), hjust = 0.5, vjust = 0.5 ), - element_render(theme, "panel.border") + element_render(theme, "panel.border", fill = NA) ) }, diff --git a/R/coord-radial.R b/R/coord-radial.R index 62b3bff136..8df50bcb1e 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -4,25 +4,34 @@ #' @param end Position from 12 o'clock in radians where plot ends, to allow #' for partial polar coordinates. The default, `NULL`, is set to #' `start + 2 * pi`. -#' @param expand If `TRUE`, the default, adds a small expansion factor the +#' @param thetalim,rlim Limits for the theta and r axes. +#' @param expand If `TRUE`, the default, adds a small expansion factor to #' the limits to prevent overlap between data and axes. If `FALSE`, limits #' are taken directly from the scale. -#' @param r.axis.inside If `TRUE`, places the radius axis inside the -#' panel. If `FALSE`, places the radius axis next to the panel. The default, -#' `NULL`, places the radius axis outside if the `start` and `end` arguments -#' form a full circle. +#' @param r.axis.inside One of the following: +#' * `NULL` (default) places the axis next to the panel if `start` and +#' `end` arguments form a full circle and inside the panel otherwise. +#' * `TRUE` to place the radius axis inside the panel. +#' * `FALSE` to place the radius axis next to the panel. +#' * A numeric value, setting a theta axis value at which +#' the axis should be placed inside the panel. Can be given as a length 2 +#' vector to control primary and secondary axis placement separately. #' @param rotate.angle If `TRUE`, transforms the `angle` aesthetic in data #' in accordance with the computed `theta` position. If `FALSE` (default), #' no such transformation is performed. Can be useful to rotate text geoms in #' alignment with the coordinates. -#' @param inner.radius A `numeric` between 0 and 1 setting the size of a inner.radius hole. +#' @param inner.radius A `numeric` between 0 and 1 setting the size of a +#' inner radius hole. +#' @param reverse A string giving which directions to reverse. `"none"` +#' (default) keep directions as is. `"theta"` reverses the angle and `"r"` +#' reverses the radius. `"thetar"` reverses both the angle and the radius. #' @param r_axis_inside,rotate_angle `r lifecycle::badge("deprecated")` #' #' @note -#' In `coord_radial()`, position guides are can be defined by using +#' In `coord_radial()`, position guides can be defined by using #' `guides(r = ..., theta = ..., r.sec = ..., theta.sec = ...)`. Note that #' these guides require `r` and `theta` as available aesthetics. The classic -#' `guide_axis()` can be used for the `r` positions and `guide_axis_theta()` can +#' [guide_axis()] can be used for the `r` positions and [guide_axis_theta()] can #' be used for the `theta` positions. Using the `theta.sec` position is only #' sensible when `inner.radius > 0`. #' @@ -32,14 +41,25 @@ #' ggplot(mtcars, aes(disp, mpg)) + #' geom_point() + #' coord_radial(start = -0.4 * pi, end = 0.4 * pi, inner.radius = 0.3) +#' +#' # Similar with coord_cartesian(), you can set limits. +#' ggplot(mtcars, aes(disp, mpg)) + +#' geom_point() + +#' coord_radial( +#' start = -0.4 * pi, +#' end = 0.4 * pi, inner.radius = 0.3, +#' thetalim = c(200, 300), +#' rlim = c(15, 30), +#' ) coord_radial <- function(theta = "x", start = 0, end = NULL, - expand = TRUE, - direction = 1, + 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()) { @@ -55,32 +75,47 @@ coord_radial <- function(theta = "x", ) rotate.angle <- rotate_angle } + if (lifecycle::is_present(direction)) { + deprecate_warn0( + "3.5.2", "coord_radial(direction)", "coord_radial(reverse)" + ) + reverse <- switch(reverse, "r" = "thetar", "theta") + } theta <- arg_match0(theta, c("x", "y")) r <- if (theta == "x") "y" else "x" - check_bool(r.axis.inside, allow_null = TRUE) - check_bool(expand) + if (!is.numeric(r.axis.inside)) { + check_bool(r.axis.inside, allow_null = TRUE) + } + reverse <- arg_match0(reverse, c("theta", "thetar", "r", "none")) + check_bool(rotate.angle) check_number_decimal(start, allow_infinite = FALSE) check_number_decimal(end, allow_infinite = FALSE, allow_null = TRUE) check_number_decimal(inner.radius, min = 0, max = 1, allow_infinite = FALSE) - end <- end %||% (start + 2 * pi) - if (start > end) { - n_rotate <- ((start - end) %/% (2 * pi)) + 1 - start <- start - n_rotate * 2 * pi + arc <- c(start, end %||% (start + 2 * pi)) + if (arc[1] > arc[2]) { + n_rotate <- ((arc[1] - arc[2]) %/% (2 * pi)) + 1 + arc[1] <- arc[1] - n_rotate * 2 * pi } - r.axis.inside <- r.axis.inside %||% !(abs(end - start) >= 1.999 * pi) + arc <- switch(reverse, thetar = , theta = rev(arc), arc) + + r.axis.inside <- r.axis.inside %||% !(abs(arc[2] - arc[1]) >= 1.999 * pi) + + inner.radius <- c(inner.radius, 1) * 0.4 + inner.radius <- switch(reverse, thetar = , r = rev, identity)(inner.radius) ggproto(NULL, CoordRadial, + limits = list(theta = thetalim, r = rlim), theta = theta, r = r, - arc = c(start, end), + arc = arc, expand = expand, - direction = sign(direction), + reverse = reverse, r_axis_inside = r.axis.inside, rotate_angle = rotate.angle, - inner_radius = c(inner.radius, 1) * 0.4, + inner_radius = inner.radius, clip = clip ) } @@ -97,23 +132,17 @@ CoordRadial <- ggproto("CoordRadial", Coord, is_free = function() TRUE, - distance = function(self, x, y, details) { + distance = function(self, x, y, details, boost = 0.75) { arc <- details$arc %||% c(0, 2 * pi) if (self$theta == "x") { r <- rescale(y, from = details$r.range, to = self$inner_radius / 0.4) - theta <- theta_rescale_no_clip( - x, details$theta.range, - arc, self$direction - ) + theta <- theta_rescale_no_clip(x, details$theta.range, arc) } else { r <- rescale(x, from = details$r.range, to = self$inner_radius / 0.4) - theta <- theta_rescale_no_clip( - y, details$theta.range, - arc, self$direction - ) + theta <- theta_rescale_no_clip(y, details$theta.range, arc) } - - dist_polar(r, theta) + # The ^boost boosts detailed munching when r is small + dist_polar(r^boost, theta) }, backtransform_range = function(self, panel_params) { @@ -130,12 +159,39 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, setup_panel_params = function(self, scale_x, scale_y, params = list()) { - c( - view_scales_polar(scale_x, self$theta, expand = self$expand), - view_scales_polar(scale_y, self$theta, expand = self$expand), + if (self$theta == "x") { + xlimits <- self$limits$theta + ylimits <- self$limits$r + } else { + xlimits <- self$limits$r + ylimits <- self$limits$theta + } + params <- c( + view_scales_polar(scale_x, self$theta, xlimits, + expand = params$expand[c(4, 2)] + ), + 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) ) + + axis_rotation <- self$r_axis_inside + if (is.numeric(axis_rotation)) { + theta_scale <- switch(self$theta, x = scale_x, y = scale_y) + 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 + ) + params$axis_rotation <- rep_len(axis_rotation, length.out = 2) + } else { + params$axis_rotation <- params$arc + } + + params }, setup_panel_guides = function(self, panel_params, guides, params = list()) { @@ -157,7 +213,7 @@ CoordRadial <- ggproto("CoordRadial", Coord, # Validate appropriateness of guides drop_guides <- character(0) for (type in aesthetics) { - drop_guides <- check_polar_guide(drop_guides, guides, type) + drop_guides <- validate_polar_guide(drop_guides, guides, type) } guide_params <- guides$get_params(aesthetics) @@ -173,18 +229,17 @@ CoordRadial <- ggproto("CoordRadial", Coord, opposite_r <- isTRUE(scales$r$position %in% c("bottom", "left")) } - if (self$r_axis_inside) { + if (!isFALSE(self$r_axis_inside)) { - arc <- rad2deg(self$arc) r_position <- c("left", "right") # If both opposite direction and opposite position, don't flip - if (xor(self$direction == -1, opposite_r)) { - arc <- rev(arc) + if (xor(self$reverse %in% c("thetar", "theta"), opposite_r)) { r_position <- rev(r_position) } - - guide_params[["r"]]$position <- r_position[1] - guide_params[["r.sec"]]$position <- r_position[2] + arc <- rad2deg(panel_params$axis_rotation) + if (opposite_r) { + 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] @@ -193,9 +248,9 @@ CoordRadial <- ggproto("CoordRadial", Coord, if (opposite_r) { r_position <- rev(r_position) } - guide_params[["r"]]$position <- r_position[1] - guide_params[["r.sec"]]$position <- r_position[2] } + guide_params[["r"]]$position <- r_position[1] + guide_params[["r.sec"]]$position <- r_position[2] guide_params[drop_guides] <- list(NULL) guides$update_params(guide_params) @@ -217,13 +272,20 @@ CoordRadial <- ggproto("CoordRadial", Coord, names(gdefs) <- aesthetics # Train theta guide - for (t in intersect(c("theta", "theta.sec"), aesthetics[!empty])) { - gdefs[[t]] <- guides[[t]]$train(gdefs[[t]], panel_params[[t]]) - gdefs[[t]] <- guides[[t]]$transform(gdefs[[t]], self, panel_params) - gdefs[[t]] <- guides[[t]]$get_layer_key(gdefs[[t]], layers) - } + t <- intersect(c("theta", "theta.sec"), aesthetics[!empty]) + gdefs[t] <- Map( + function(guide, guide_param, scale) { + guide_param$theme_suffix <- "theta" + guide_param <- guide$train(guide_param, scale) + guide_param <- guide$transform(guide_param, self, panel_params) + guide_param <- guide$get_layer_key(guide_param, layers) + }, + guide = guides[t], + guide_param = gdefs[t], + scale = panel_params[t] + ) - if (self$r_axis_inside) { + if (!isFALSE(self$r_axis_inside)) { # For radial axis, we need to pretend that rotation starts at 0 and # the bounding box is for circles, otherwise tick positions will be # spaced too closely. @@ -236,32 +298,34 @@ CoordRadial <- ggproto("CoordRadial", Coord, temp <- modify_list(panel_params, mod) # Train radial guide - for (r in intersect(c("r", "r.sec"), aesthetics[!empty])) { - gdefs[[r]] <- guides[[r]]$train(gdefs[[r]], panel_params[[r]]) - gdefs[[r]] <- guides[[r]]$transform(gdefs[[r]], self, temp) # Use temp - gdefs[[r]] <- guides[[r]]$get_layer_key(gdefs[[r]], layers) - } - - # Set theme suffixes - gdefs$theta$theme_suffix <- "theta" - gdefs$theta.sec$theme_suffix <- "theta" - gdefs$r$theme_suffix <- "r" - gdefs$r.sec$theme_suffix <- "r" + r <- intersect(c("r", "r.sec"), aesthetics[!empty]) + gdefs[r] <- Map( + function(guide, guide_param, scale) { + guide_param$theme_suffix <- "r" + guide_param <- guide$train(guide_param, scale) + guide_param <- guide$transform(guide_param, self, temp) + guide_param <- guide$get_layer_key(guide_param, layers) + }, + guide = guides[r], + guide_param = gdefs[r], + scale = panel_params[r] + ) panel_params$guides$update_params(gdefs) panel_params }, transform = function(self, data, panel_params) { + if (is_transform_immune(data, snake_class(self))) { + return(data) + } + 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) 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, self$direction - ) + 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) @@ -273,118 +337,82 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, render_axis_v = function(self, panel_params, theme) { - if (self$r_axis_inside) { + if (!isFALSE(self$r_axis_inside)) { return(list(left = zeroGrob(), right = zeroGrob())) } CoordCartesian$render_axis_v(panel_params, theme) }, render_axis_h = function(self, panel_params, theme) { - if (self$r_axis_inside) { + if (!isFALSE(self$r_axis_inside)) { return(list(top = zeroGrob(), bottom = zeroGrob())) } CoordCartesian$render_axis_h(panel_params, theme) }, render_bg = function(self, panel_params, theme) { - - bbox <- panel_params$bbox %||% list(x = c(0, 1), y = c(0, 1)) - arc <- panel_params$arc %||% c(0, 2 * pi) - dir <- self$direction - inner_radius <- panel_params$inner_radius - - theta_lim <- panel_params$theta.range - theta_maj <- panel_params$theta.major - theta_min <- setdiff(panel_params$theta.minor, theta_maj) - - if (length(theta_maj) > 0) { - theta_maj <- theta_rescale(theta_maj, theta_lim, arc, dir) - } - if (length(theta_min) > 0) { - theta_min <- theta_rescale(theta_min, theta_lim, arc, dir) - } - theta_fine <- seq(self$arc[1], self$arc[2], length.out = 100) - - r_fine <- r_rescale(panel_params$r.major, panel_params$r.range, - panel_params$inner_radius) - - # This gets the proper theme element for theta and r grid lines: - # panel.grid.major.x or .y - grid_elems <- paste( - c("panel.grid.major.", "panel.grid.minor.", "panel.grid.major."), - c(self$theta, self$theta, self$r), sep = "" + panel_params <- switch( + self$theta, + x = rename(panel_params, c(theta = "x", r = "y")), + y = rename(panel_params, c(theta = "y", r = "x")) ) - grid_elems <- lapply(grid_elems, calc_element, theme = theme) - majortheta <- paste("panel.grid.major.", self$theta, sep = "") - minortheta <- paste("panel.grid.minor.", self$theta, sep = "") - majorr <- paste("panel.grid.major.", self$r, sep = "") - - bg_element <- calc_element("panel.background", theme) - if (!inherits(bg_element, "element_blank")) { - background <- data_frame0( - x = c(Inf, Inf, -Inf, -Inf), - y = c(Inf, -Inf, -Inf, Inf) - ) - background <- coord_munch(self, background, panel_params, is_closed = TRUE) - bg_gp <- gpar( - lwd = len0_null(bg_element$linewidth * .pt), - col = bg_element$colour, fill = bg_element$fill, - lty = bg_element$linetype - ) - background <- polygonGrob( - x = background$x, y = background$y, - gp = bg_gp - ) - } else { - background <- zeroGrob() - } - - ggname("grill", grobTree( - background, - theta_grid(theta_maj, grid_elems[[1]], inner_radius, bbox), - theta_grid(theta_min, grid_elems[[2]], inner_radius, bbox), - element_render( - theme, majorr, name = "radius", - x = rescale(rep(r_fine, each = length(theta_fine)) * - rep(sin(theta_fine), length(r_fine)) + 0.5, from = bbox$x), - y = rescale(rep(r_fine, each = length(theta_fine)) * - rep(cos(theta_fine), length(r_fine)) + 0.5, from = bbox$y), - id.lengths = rep(length(theta_fine), length(r_fine)), - default.units = "native" - ) - )) + guide_grid(theme, panel_params, self, square = FALSE) }, render_fg = function(self, panel_params, theme) { - if (!self$r_axis_inside) { + border <- element_render(theme, "panel.border", fill = NA) + + if (isFALSE(self$r_axis_inside)) { out <- grobTree( panel_guides_grob(panel_params$guides, "theta", theme), panel_guides_grob(panel_params$guides, "theta.sec", theme), - element_render(theme, "panel.border") + border ) return(out) } bbox <- panel_params$bbox dir <- self$direction - arc <- if (dir == 1) self$arc else rev(self$arc) - arc <- dir * rad2deg(-arc) + 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, arc[1], bbox, "left") + left <- rotate_r_axis(left, rot[1], bbox, "left") right <- panel_guides_grob(panel_params$guides, position = "right", theme) - right <- rotate_r_axis(right, arc[2], bbox, "right") + right <- rotate_r_axis(right, rot[2], bbox, "right") grobTree( panel_guides_grob(panel_params$guides, "theta", theme), panel_guides_grob(panel_params$guides, "theta.sec", theme), left, right, - element_render(theme, "panel.border") + border ) }, + + draw_panel = function(self, panel, params, theme) { + clip_support <- check_device("clippingPaths", "test", maybe = TRUE) + if (self$clip == "on" && !isFALSE(clip_support)) { + clip_path <- data_frame0( + x = c(Inf, Inf, -Inf, -Inf), + y = c(Inf, -Inf, -Inf, Inf) + ) + clip_path <- coord_munch(self, clip_path, params, is_closed = TRUE) + clip_path <- polygonGrob(clip_path$x, clip_path$y) + # Note that clipping path is applied to panel without coord + # foreground/background (added in parent method). + # These may contain decorations that needn't be clipped + panel <- list(gTree( + children = inject(gList(!!!panel)), + vp = viewport(clip = clip_path) + )) + } + ggproto_parent(Coord, self)$draw_panel(panel, params, theme) + }, + labels = function(self, labels, panel_params) { # `Layout$resolve_label()` doesn't know to look for theta/r/r.sec guides, # so we'll handle title propagation here. @@ -424,31 +452,32 @@ CoordRadial <- ggproto("CoordRadial", Coord, }, setup_params = function(self, data) { - if (!self$r_axis_inside) { - place <- in_arc(c(0, 0.5, 1, 1.5) * pi, self$arc) - if (place[1]) { - return(list(r_axis = "left", fake_arc = c(0, 2) * pi)) - } - if (place[3]) { - return(list(r_axis = "left", fake_arc = c(1, 3)* pi)) - } - if (place[2]) { - return(list(r_axis = "bottom", fake_arc = c(0.5, 2.5) * pi)) - } - if (place[4]) { - return(list(r_axis = "bottom", fake_arc = c(1.5, 3.5) * pi)) - } + params <- ggproto_parent(Coord, self)$setup_params(data) + if (!isFALSE(self$r_axis_inside)) { + return(params) + } + + place <- in_arc(c(0, 0.5, 1, 1.5) * pi, self$arc) + if (!any(place)) { cli::cli_warn(c( "No appropriate placement found for {.arg r_axis_inside}.", i = "Axis will be placed at panel edge." )) - self$r_axis_inside <- TRUE + params$r_axis_inside <- TRUE + return(params) } - return(NULL) + + 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 + params } ) -view_scales_polar <- function(scale, theta = "x", expand = TRUE) { +view_scales_polar <- function(scale, theta = "x", coord_limits = NULL, + expand = TRUE) { aesthetic <- scale$aesthetics[1] is_theta <- theta == aesthetic @@ -456,7 +485,10 @@ view_scales_polar <- function(scale, theta = "x", expand = TRUE) { expansion <- default_expansion(scale, expand = expand) limits <- scale$get_limits() - continuous_range <- expand_limits_scale(scale, expansion, limits) + continuous_range <- expand_limits_scale( + scale, expansion, limits, + coord_limits + ) primary <- view_scale_primary(scale, limits, continuous_range) view_scales <- list( @@ -492,6 +524,7 @@ polar_bbox <- function(arc, margin = c(0.05, 0.05, 0.05, 0.05), if (abs(diff(arc)) >= 2 * pi) { return(list(x = c(0, 1), y = c(0, 1))) } + arc <- sort(arc) # X and Y position of the sector arc ends xmax <- 0.5 * sin(arc) + 0.5 @@ -604,7 +637,7 @@ theta_grid <- function(theta, element, inner_radius = c(0, 0.4), ) } -check_polar_guide <- function(drop_list, guides, type = "theta") { +validate_polar_guide <- function(drop_list, guides, type = "theta") { guide <- guides$get_guide(type) primary <- gsub("\\.sec$", "", type) if (inherits(guide, "GuideNone") || primary %in% guide$available_aes) { diff --git a/R/coord-sf.R b/R/coord-sf.R index 331ca4f1f0..d603d57de7 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -18,12 +18,10 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, }, setup_params = function(self, data) { - crs <- self$determine_crs(data) + params <- ggproto_parent(Coord, self)$setup_params(data) - params <- list( - crs = crs, - default_crs = self$default_crs - ) + params$crs <- self$determine_crs(data) + params$default_crs <- self$default_crs self$params <- params params @@ -79,22 +77,30 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, }, transform = function(self, data, panel_params) { + if (is_transform_immune(data, snake_class(self))) { + return(data) + } + # we need to transform all non-sf data into the correct coordinate system source_crs <- panel_params$default_crs target_crs <- panel_params$crs + # CoordSf doesn't use the viewscale rescaling, so we just flip ranges + reverse <- self$reverse %||% "none" + x_range <- switch(reverse, xy = , x = rev, identity)(panel_params$x_range) + 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) ]], - panel_params$x_range, - panel_params$y_range + x_range, y_range ) # transform and normalize regular position data data <- transform_position( sf_transform_xy(data, target_crs, source_crs), - function(x) rescale(x, from = panel_params$x_range), - function(x) rescale(x, from = panel_params$y_range) + function(x) rescale(x, from = x_range), + function(x) rescale(x, from = y_range) ) transform_position(data, squish_infinite, squish_infinite) @@ -110,7 +116,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, x_breaks <- graticule$degree[graticule$type == "E"] if (is.null(scale_x$labels)) { x_labels <- rep(NA, length(x_breaks)) - } else if (is.waive(scale_x$labels)) { + } else if (is.waiver(scale_x$labels)) { x_labels <- graticule$degree_label[graticule$type == "E"] needs_autoparsing[graticule$type == "E"] <- TRUE } else { @@ -135,7 +141,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, y_breaks <- graticule$degree[graticule$type == "N"] if (is.null(scale_y$labels)) { y_labels <- rep(NA, length(y_breaks)) - } else if (is.waive(scale_y$labels)) { + } else if (is.waiver(scale_y$labels)) { y_labels <- graticule$degree_label[graticule$type == "N"] needs_autoparsing[graticule$type == "N"] <- TRUE } else { @@ -170,8 +176,8 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, setup_panel_params = function(self, scale_x, scale_y, params = list()) { # expansion factors for scale limits - expansion_x <- default_expansion(scale_x, expand = self$expand) - expansion_y <- default_expansion(scale_y, expand = self$expand) + expansion_x <- default_expansion(scale_x, expand = params$expand[c(4, 2)]) + expansion_y <- default_expansion(scale_y, expand = params$expand[c(3, 1)]) # get scale limits and coord limits and merge together # coord limits take precedence over scale limits @@ -222,16 +228,25 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, x_range[2], y_range[2] ) + breaks <- sf_breaks(scale_x, scale_y, bbox, params$crs) + # Generate graticule and rescale to plot coords graticule <- sf::st_graticule( bbox, crs = params$crs, - lat = scale_y$breaks %|W|% NULL, - lon = scale_x$breaks %|W|% NULL, + lat = breaks$y %|W|% NULL, + lon = breaks$x %|W|% NULL, datum = self$datum, ndiscr = self$ndiscr ) + if (is.null(breaks$x)) { + graticule <- vec_slice(graticule, graticule$type != "E") + } + if (is.null(breaks$y)) { + graticule <- vec_slice(graticule, graticule$type != "N") + } + # override graticule labels provided by sf::st_graticule() if necessary graticule <- self$fixup_graticule_labels(graticule, scale_x, scale_y, params) @@ -248,21 +263,17 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, ) ) - # Rescale graticule for panel grid - sf::st_geometry(graticule) <- sf_rescale01(sf::st_geometry(graticule), x_range, y_range) - graticule$x_start <- rescale(graticule$x_start, from = x_range) - graticule$x_end <- rescale(graticule$x_end, from = x_range) - graticule$y_start <- rescale(graticule$y_start, from = y_range) - graticule$y_end <- rescale(graticule$y_end, from = y_range) - - list2( + panel_params <- list2( x_range = x_range, y_range = y_range, - graticule = graticule, crs = params$crs, default_crs = params$default_crs, !!!viewscales ) + + # Rescale graticule for panel grid + panel_params$graticule <- self$transform(graticule, panel_params) + panel_params }, train_panel_guides = function(self, panel_params, layers, params = list()) { @@ -326,9 +337,9 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, if (inherits(el, "element_blank")) { grobs <- list(element_render(theme, "panel.background")) } else { - line_gp <- gpar( + line_gp <- gg_par( col = el$colour, - lwd = len0_null(el$linewidth * .pt), + lwd = el$linewidth, lty = el$linetype ) grobs <- c( @@ -397,17 +408,31 @@ sf_transform_xy <- function(data, target_crs, source_crs, authority_compliant = ## helper functions to normalize geometry and position data # normalize geometry data (variable x is geometry column) +# this is a wrapper for `sf::st_normalize()`, but deals with empty input and +# reversed ranges too sf_rescale01 <- function(x, x_range, y_range) { if (is.null(x)) { return(x) } - - sf::st_normalize(x, c(x_range[1], y_range[1], x_range[2], y_range[2])) + mult <- cbind(1, 1) + if (isTRUE(x_range[1] > x_range[2])) { + x_range <- sort(x_range) + mult[1] <- -1 + } + if (isTRUE(y_range[1] > y_range[2])) { + y_range <- sort(y_range) + mult[2] <- -1 + } + x <- sf::st_normalize(x, c(x_range[1], y_range[1], x_range[2], y_range[2])) + if (all(mult == 1)) { + return(x) + } + x * mult + pmax(-mult, 0) } # different limits methods calc_limits_bbox <- function(method, xlim, ylim, crs, default_crs) { - if (any(!is.finite(c(xlim, ylim))) && method != "geometry_bbox") { + 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}.", "i" = "Consider setting {.code lims_method = \"geometry_bbox\"} or {.code default_crs = NULL}." @@ -525,9 +550,10 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, datum = sf::st_crs(4326), label_graticule = waiver(), label_axes = waiver(), lims_method = "cross", - ndiscr = 100, default = FALSE, clip = "on") { + ndiscr = 100, default = FALSE, clip = "on", + reverse = "none") { - if (is.waive(label_graticule) && is.waive(label_axes)) { + 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 label_graticule <- "" @@ -538,11 +564,7 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, label_axes <- label_axes %|W|% "" } - if (is.character(label_axes)) { - label_axes <- parse_axes_labeling(label_axes) - } else if (!is.list(label_axes)) { - cli::cli_abort("Panel labeling format not recognized.") - } + label_axes <- parse_axes_labeling(label_axes) if (is.character(label_graticule)) { label_graticule <- unlist(strsplit(label_graticule, "")) @@ -569,17 +591,70 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, label_axes = label_axes, label_graticule = label_graticule, ndiscr = ndiscr, + reverse = reverse, expand = expand, default = default, clip = clip ) } -parse_axes_labeling <- function(x) { - labs = unlist(strsplit(x, "")) - list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4]) +parse_axes_labeling <- function(x, call = caller_env()) { + if (is.character(x)) { + x <- unlist(strsplit(x, "")) + x <- list(top = x[1], right = x[2], bottom = x[3], left = x[4]) + } else if (!is.list(x)) { + cli::cli_abort("Panel labeling format not recognized.", call = call) + } + x } +# This function does two things differently from standard breaks: +# 1. It does not resolve `waiver()`, unless `n.breaks` is given. In the case +# that breaks are `waiver()`, we use the default graticule breaks. +# 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. + # To preserve that assumption for function breaks, the bounding box + # needs to be translated to long/lat coordinates. + if (!is_named(bbox)) { + names(bbox) <- c("xmin", "ymin", "xmax", "ymax") + } + # Convert bounding box to long/lat coordinates + bbox <- sf::st_as_sfc(sf::st_bbox(bbox, crs = crs)) + bbox <- sf::st_bbox(sf::st_transform(bbox, 4326)) + bbox <- as.numeric(bbox) + + # If any bbox is NA the transformation has probably failed. + # (.e.g from IGH to long/lat). In this case, just provide full long/lat. + bbox[is.na(bbox)] <- c(-180, -90, 180, 90)[is.na(bbox)] + } + + if (!(is.waiver(scale_x$breaks) && is.null(scale_x$n.breaks))) { + x_breaks <- scale_x$get_breaks(limits = bbox[c(1, 3)]) + finite <- is.finite(x_breaks) + x_breaks <- if (any(finite)) x_breaks[finite] else NULL + } + + if (!(is.waiver(scale_y$breaks) && is.null(scale_y$n.breaks))) { + y_breaks <- scale_y$get_breaks(limits = bbox[c(2, 4)]) + finite <- is.finite(y_breaks) + y_breaks <- if (any(finite)) y_breaks[finite] else NULL + } + } + + list(x = x_breaks, y = y_breaks) +} #' ViewScale from graticule #' @@ -602,6 +677,9 @@ parse_axes_labeling <- function(x) { #' @keywords internal view_scales_from_graticule <- function(graticule, scale, aesthetic, label, label_graticule, bbox) { + if (empty(graticule)) { + return(ggproto(NULL, ViewScale)) + } # Setup position specific parameters # Note that top/bottom doesn't necessarily mean to label the meridians and @@ -643,6 +721,14 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, accept_start <- graticule[[orth_start]] < 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 + accept_start <- straight + } # Parsing the information of the `label_axes` argument: # should we label the meridians ("E") or parallels ("N")? diff --git a/R/coord-transform.R b/R/coord-transform.R index 81f06afad3..18230a1742 100644 --- a/R/coord-transform.R +++ b/R/coord-transform.R @@ -78,7 +78,8 @@ #' plot + coord_trans(x = "sqrt") #' } coord_trans <- function(x = "identity", y = "identity", xlim = NULL, ylim = NULL, - limx = deprecated(), limy = deprecated(), clip = "on", expand = TRUE) { + limx = deprecated(), limy = deprecated(), clip = "on", + expand = TRUE, reverse = "none") { if (lifecycle::is_present(limx)) { deprecate_warn0("3.3.0", "coord_trans(limx)", "coord_trans(xlim)") xlim <- limx @@ -99,6 +100,7 @@ coord_trans <- function(x = "identity", y = "identity", xlim = NULL, ylim = NULL trans = list(x = x, y = y), limits = list(x = xlim, y = ylim), expand = expand, + reverse = reverse, clip = clip ) } @@ -132,14 +134,17 @@ CoordTrans <- ggproto("CoordTrans", Coord, transform = function(self, data, panel_params) { # trans_x() and trans_y() needs to keep Inf values because this can be called # in guide_transform.axis() + reverse <- self$reverse %||% "none" + x_range <- switch(reverse, xy = , x = rev, identity)(panel_params$x.range) + y_range <- switch(reverse, xy = , y = rev, identity)(panel_params$y.range) trans_x <- function(data) { idx <- !is.infinite(data) - data[idx] <- transform_value(self$trans$x, data[idx], panel_params$x.range) + data[idx] <- transform_value(self$trans$x, data[idx], x_range) data } trans_y <- function(data) { idx <- !is.infinite(data) - data[idx] <- transform_value(self$trans$y, data[idx], panel_params$y.range) + data[idx] <- transform_value(self$trans$y, data[idx], y_range) data } @@ -153,19 +158,13 @@ CoordTrans <- ggproto("CoordTrans", Coord, 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, self$expand), - view_scales_from_scale_with_coord_trans(scale_y, self$limits$y, self$trans$y, self$expand) + 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)]) ) }, - render_bg = function(panel_params, theme) { - guide_grid( - theme, - panel_params$x.minor, - panel_params$x.major, - panel_params$y.minor, - panel_params$y.major - ) + render_bg = function(self, panel_params, theme) { + guide_grid(theme, panel_params, self) }, render_axis_h = function(panel_params, theme) { @@ -198,7 +197,7 @@ view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, if (scale$is_discrete()) { continuous_ranges <- expand_limits_discrete_trans( - scale_limits, + scale$map(scale_limits), expansion, coord_limits, trans, diff --git a/R/facet-.R b/R/facet-.R index baa6daffbf..6e8c96f277 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -46,6 +46,10 @@ NULL #' the default behaviour of one or more of the following methods: #' #' - `setup_params`: +#' +#' - `setup_panel_params`: modifies the x and y ranges for each panel. This is +#' used to allow the `Facet` to interact with the `panel_params`. +#' #' - `init_scales`: Given a master scale for x and y, create panel #' specific scales for each panel defined in the layout. The default is to #' simply clone the master scale. @@ -90,6 +94,7 @@ Facet <- ggproto("Facet", NULL, map_data = function(data, layout, params) { cli::cli_abort("Not implemented.") }, + setup_panel_params = function(self, panel_params, coord, ...) panel_params, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { scales <- list() if (!is.null(x_scale)) { @@ -133,8 +138,35 @@ Facet <- ggproto("Facet", NULL, draw_front = function(data, layout, x_scales, y_scales, theme, params) { rep(list(zeroGrob()), vec_unique_count(layout$PANEL)) }, - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { - cli::cli_abort("Not implemented.") + 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 + if (!is.null(aspect_ratio) && (space$x || space$y)) { + cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio.") + } + + if (!coord$is_free()) { + if (space$x && space$y) { + aspect_ratio <- aspect_ratio %||% coord$ratio + } else if (free$x || free$y) { + cli::cli_abort( + "{.fn {snake_class(self)}} can't use free scales with \\ + {.fn {snake_class(coord)}}." + ) + } + } + + table <- self$init_gtable( + panels, layout, theme, ranges, params, + aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]]) + ) + + table <- self$attach_axes(table, layout, ranges, coord, theme, params) + self$attach_strips(table, layout, params, theme) }, draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { panel_dim <- find_panel(panels) @@ -173,8 +205,116 @@ Facet <- ggproto("Facet", NULL, finish_data = function(data, layout, x_scales, y_scales, params) { data }, + init_gtable = function(panels, layout, theme, ranges, params, + aspect_ratio = NULL) { + + # Initialise matrix of panels + 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") + 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] + widths <- vapply(idx, function(i) diff(ranges[[i]]$x.range), numeric(1)) + widths <- unit(widths, "null") + } + + if (space$y) { + idx <- layout$PANEL[layout$COL == 1] + heights <- vapply(idx, function(i) diff(ranges[[i]]$y.range), numeric(1)) + heights <- unit(heights * abs(aspect_ratio %||% 1), "null") + } + + # Build gtable + table <- gtable_matrix( + "layout", table, + widths = widths, heights = heights, + respect = !is.null(aspect_ratio), + clip = "off", z = matrix(1, dim[1], dim[2]) + ) + + # Set panel names + table$layout$name <- paste( + "panel", + rep(seq_len(dim[2]), each = dim[1]), + rep(seq_len(dim[1]), dim[2]), + sep = "-" + ) + + # Add spacing between panels + spacing <- lapply( + c(x = "panel.spacing.x", y = "panel.spacing.y"), + calc_element, theme = theme + ) + + table <- gtable_add_col_space(table, spacing$x) + table <- gtable_add_row_space(table, spacing$y) + table + }, + attach_axes = function(table, layout, ranges, coord, theme, params) { + table + }, + attach_strips = function(table, layout, params, theme) { + table + }, vars = function() { character(0) + }, + format_strip_labels = function(layout, params) { + return() + }, + set_panel_size = function(table, theme) { + + new_widths <- calc_element("panel.widths", theme) + new_heights <- calc_element("panel.heights", theme) + + if (is.null(new_widths) && is.null(new_heights)) { + return(table) + } + + if (isTRUE(table$respect)) { + args <- !c(is.null(new_widths), is.null(new_heights)) + args <- c("panel.widths", "panel.heights")[args] + cli::cli_warn( + "Aspect ratios are overruled by {.arg {args}} theme element{?s}." + ) + table$respect <- FALSE + } + + rows <- panel_rows(table) + cols <- panel_cols(table) + + if (length(new_widths) == 1L && nrow(cols) > 1L) { + # Get total size of non-panel widths in between panels + 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 + new_widths <- (new_widths - extra) * (relative / sum(relative)) + } + if (!is.null(new_widths)) { + table$widths[cols$l] <- rep(new_widths, length.out = nrow(cols)) + } + + if (length(new_heights) == 1L && nrow(rows) > 1L) { + # Get total size of non-panel heights in between panels + 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 + new_heights <- (new_heights - extra) * (relative / sum(relative)) + } + if (!is.null(new_heights)) { + table$heights[rows$t] <- rep(new_heights, length.out = nrow(rows)) + } + + table } ) @@ -251,6 +391,32 @@ is.facet <- function(x) { is_facet(x) } +#' Accessing a plot's facet strip labels +#' +#' This functions retrieves labels from facet strips with the labeller applied. +#' +#' @param plot A ggplot or build ggplot object. +#' +#' @return `NULL` if there are no labels, otherwise a list of data.frames +#' containing the labels. +#' @export +#' @keywords internal +#' +#' @examples +#' # Basic plot +#' p <- ggplot(mpg, aes(displ, hwy)) + +#' geom_point() +#' +#' get_strip_labels(p) # empty facets +#' 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) + layout <- plot$layout$layout + params <- plot$layout$facet_params + plot$plot$facet$format_strip_labels(layout, params) +} + # A "special" value, currently not used but could be used to determine # if faceting is active NO_PANEL <- -1L @@ -290,7 +456,7 @@ df.grid <- function(a, b) { # facetting variables. as_facets_list <- function(x) { - x <- validate_facets(x) + check_vars(x) if (is_quosures(x)) { x <- quos_auto_name(x) return(list(x)) @@ -309,7 +475,14 @@ as_facets_list <- function(x) { # distinct facet dimensions and `+` defines multiple facet variables # inside each dimension. if (is_formula(x)) { - return(f_as_facets_list(x)) + if (length(x) == 2) { + rows <- f_as_facets(NULL) + cols <- f_as_facets(x) + } else { + rows <- f_as_facets(x[-3]) + cols <- f_as_facets(x[-2]) + } + return(list(rows, cols)) } # For backward-compatibility with facet_wrap() @@ -327,7 +500,7 @@ as_facets_list <- function(x) { x } -validate_facets <- function(x) { +check_vars <- function(x) { if (is_mapping(x)) { cli::cli_abort("Please use {.fn vars} to supply facet variables.") } @@ -339,13 +512,12 @@ validate_facets <- function(x) { "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?" )) } - x + invisible() } - # 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) is_list <- vapply(proxy, vec_is_list, logical(1)) proxy[is_list] <- lapply(proxy[is_list], unclass) @@ -392,18 +564,10 @@ simplify <- function(x) { } } -f_as_facets_list <- function(f) { - lhs <- function(x) if (length(x) == 2) NULL else x[-3] - rhs <- function(x) if (length(x) == 2) x else x[-2] - - rows <- f_as_facets(lhs(f)) - cols <- f_as_facets(rhs(f)) - - list(rows, cols) -} - as_facets <- function(x) { - if (is_facets(x)) { + is_facets <- is.list(x) && length(x) > 0 && + all(vapply(x, is_quosure, logical(1))) + if (is_facets) { return(x) } @@ -424,27 +588,13 @@ f_as_facets <- function(f) { env <- f_env(f) %||% globalenv() # as.quoted() handles `+` specifications - vars <- as.quoted(f) + vars <- simplify(f) - # `.` in formulas is ignored - vars <- discard_dots(vars) + # `.` in formulas is discarded + vars <- vars[!vapply(vars, identical, logical(1), as.name("."))] as_quosures(vars, env, named = TRUE) } -discard_dots <- function(x) { - x[!vapply(x, identical, logical(1), as.name("."))] -} - -is_facets <- function(x) { - if (!is.list(x)) { - return(FALSE) - } - if (!length(x)) { - return(FALSE) - } - all(vapply(x, is_quosure, logical(1))) -} - # When evaluating variables in a facet specification, we evaluate bare # variables and expressions slightly differently. Bare variables should @@ -455,7 +605,7 @@ is_facets <- function(x) { # 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)) - data_frame0(tibble::as_tibble(vars)) + data_frame0(!!!vars) } eval_facet <- function(facet, data, possible_columns = NULL) { # Treat the case when `facet` is a quosure of a symbol specifically @@ -572,7 +722,7 @@ find_panel <- function(table) { } #' @rdname find_panel #' @export -panel_cols = function(table) { +panel_cols <- function(table) { panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] unique0(panels[, c('l', 'r')]) } @@ -701,7 +851,7 @@ render_axes <- function(x = NULL, y = NULL, coord, theme, transpose = FALSE) { #' #' @keywords internal #' @export -render_strips <- function(x = NULL, y = NULL, labeller, theme) { +render_strips <- function(x = NULL, y = NULL, labeller = identity, theme) { list( x = build_strip(x, labeller, theme, TRUE), y = build_strip(y, labeller, theme, FALSE) @@ -735,3 +885,95 @@ censor_labels <- function(ranges, layout, labels) { } ranges } + +map_facet_data <- function(data, layout, params) { + + if (empty(data)) { + return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) + } + + vars <- params$facet %||% c(params$rows, params$cols) + + if (length(vars) == 0) { + data$PANEL <- layout$PANEL + return(data) + } + + grid_layout <- all(c("rows", "cols") %in% names(params)) + layer_layout <- attr(data, "layout") + if (identical(layer_layout, "fixed")) { + n <- vec_size(data) + data <- vec_rep(data, vec_size(layout)) + data$PANEL <- vec_rep_each(layout$PANEL, n) + return(data) + } + + # Compute faceting values + facet_vals <- eval_facets(vars, data, params$.possible_columns) + + include_margins <- !isFALSE(params$margin %||% FALSE) && + 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))), + params$margins %||% FALSE + ) + # Apply recycling on original data to fit margins + # We're using base subsetting here because `data` might have a superclass + # that isn't handled well by vctrs::vec_slice + data <- data[facet_vals$.index, , drop = FALSE] + facet_vals$.index <- NULL + } + + # If we need to fix rows or columns, we make the corresponding faceting + # variables missing on purpose + if (grid_layout) { + if (identical(layer_layout, "fixed_rows")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$cols))] + } + if (identical(layer_layout, "fixed_cols")) { + facet_vals <- facet_vals[setdiff(names(facet_vals), names(params$rows))] + } + } + + # If any faceting variables are missing, add them in by + # 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)) + facet_rep <- rep(seq_len(nrow(to_add)), each = nrow(data)) + + data <- unrowname(data[data_rep, , drop = FALSE]) + facet_vals <- unrowname(vec_cbind( + unrowname(facet_vals[data_rep, , drop = FALSE]), + unrowname(to_add[facet_rep, , drop = FALSE]) + )) + } + + if (nrow(facet_vals) < 1) { + # Add PANEL variable + data$PANEL <- NO_PANEL + return(data) + } + + facet_vals[] <- lapply(facet_vals, as_unordered_factor) + facet_vals[] <- lapply(facet_vals, addNA, ifany = TRUE) + layout[] <- lapply(layout, as_unordered_factor) + + # Add PANEL variable + keys <- join_keys(facet_vals, layout, by = names(vars)) + data$PANEL <- layout$PANEL[match(keys$x, keys$y)] + + # Filter panels when layer_layout is an integer + if (is_integerish(layer_layout)) { + data <- vec_slice(data, data$PANEL %in% layer_layout) + } + + data +} diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 43897e4c9c..86bbad2b04 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -69,6 +69,17 @@ NULL #' labels and the interior axes get none. When `"all_x"` or `"all_y"`, only #' draws the labels at the interior axes in the x- or y-direction #' respectively. +#' +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_grid()` can take +#' the following values: +#' * `NULL` (default) to use the faceting variables to assign panels. +#' * An integer vector to include selected panels. Panel numbers not included in +#' the integer vector are excluded. +#' * `"fixed"` to repeat data across every panel. +#' * `"fixed_rows"` to repeat data across rows. +#' * `"fixed_cols"` to repeat data across columns. +#' #' @export #' @seealso #' The `r link_book("facet grid section", "facet#facet-grid")` @@ -132,10 +143,9 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", switch = NULL, drop = TRUE, margins = FALSE, axes = "margins", axis.labels = "all", facets = deprecated()) { - # `facets` is deprecated and renamed to `rows` + # `facets` is deprecated if (lifecycle::is_present(facets)) { - deprecate_warn0("2.2.0", "facet_grid(facets)", "facet_grid(rows)") - rows <- facets + lifecycle::deprecate_stop("2.2.0", "facet_grid(facets)", "facet_grid(rows)") } # Should become a warning in a future release @@ -177,7 +187,7 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", facets_list <- grid_as_facets_list(rows, cols) # Check for deprecated labellers - labeller <- check_labeller(labeller) + check_labeller(labeller) ggproto(NULL, FacetGrid, shrink = shrink, @@ -219,8 +229,8 @@ grid_as_facets_list <- function(rows, cols) { check_object(cols, is_quosures, "a {.fn vars} specification", allow_null = TRUE) list( - rows = compact_facets(as_facets_list(rows)), - cols = compact_facets(as_facets_list(cols)) + rows = compact_facets(rows), + cols = compact_facets(cols) ) } @@ -283,239 +293,186 @@ FacetGrid <- ggproto("FacetGrid", Facet, panels }, - map_data = function(data, layout, params) { - if (empty(data)) { - return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) - } - - rows <- params$rows - cols <- params$cols - vars <- c(names(rows), names(cols)) - - if (length(vars) == 0) { - data$PANEL <- layout$PANEL - return(data) - } - - # Compute faceting values and add margins - margin_vars <- list(intersect(names(rows), names(data)), - intersect(names(cols), names(data))) - data <- reshape_add_margins(data, margin_vars, params$margins) - facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns) + map_data = map_facet_data, - # If any faceting variables are missing, add them in by - # duplicating the data - missing_facets <- setdiff(vars, names(facet_vals)) - if (length(missing_facets) > 0) { - to_add <- unique0(layout[missing_facets]) + attach_axes = function(table, layout, ranges, coord, theme, params) { - data_rep <- rep.int(1:nrow(data), nrow(to_add)) - facet_rep <- rep(1:nrow(to_add), each = nrow(data)) + # Setup parameters + draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) + axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) - data <- unrowname(data[data_rep, , drop = FALSE]) - facet_vals <- unrowname(vec_cbind( - unrowname(facet_vals[data_rep, , drop = FALSE]), - unrowname(to_add[facet_rep, , drop = FALSE])) - ) - } - - # Add PANEL variable - if (nrow(facet_vals) == 0) { - # Special case of no faceting - data$PANEL <- NO_PANEL + dim <- c(max(layout$ROW), max(layout$COL)) + if (!axis_labels$x) { + cols <- seq_len(nrow(layout)) + x_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) } else { - facet_vals[] <- lapply(facet_vals[], as_unordered_factor) - facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE) - layout[] <- lapply(layout[], as_unordered_factor) - - keys <- join_keys(facet_vals, layout, by = vars) - - data$PANEL <- layout$PANEL[match(keys$x, keys$y)] + cols <- which(layout$ROW == 1) + x_order <- layout$COL } - data - }, - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { - if ((params$free$x || params$free$y) && !coord$is_free()) { - cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales.") + if (!axis_labels$y) { + rows <- seq_len(nrow(layout)) + y_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) + } else { + rows <- which(layout$COL == 1) + y_order <- layout$ROW } - # Fill missing parameters for backward compatibility - params$draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) - params$axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) + # 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) - if (!params$axis_labels$x) { - cols <- seq_len(nrow(layout)) - x_axis_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) + if (draw_axes$x) { + table <- weave_axes(table, lapply(axes$x, mtx, o = x_order)) } else { - cols <- which(layout$ROW == 1) - x_axis_order <- layout$COL - } - if (!params$axis_labels$y) { - rows <- seq_len(nrow(layout)) - y_axis_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)]) - } else { - rows <- which(layout$COL == 1) - y_axis_order <- layout$ROW + 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) } - ranges <- censor_labels(ranges, layout, params$axis_labels) - axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE) - - col_vars <- unique0(layout[names(params$cols)]) - row_vars <- unique0(layout[names(params$rows)]) - # Adding labels metadata, useful for labellers - attr(col_vars, "type") <- "cols" - attr(col_vars, "facet") <- "grid" - attr(row_vars, "type") <- "rows" - attr(row_vars, "facet") <- "grid" - strips <- render_strips(col_vars, row_vars, params$labeller, theme) - - aspect_ratio <- theme$aspect.ratio - if (!is.null(aspect_ratio) && (params$space_free$x || params$space_free$y)) { - cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio.") - } - aspect_ratio <- aspect_ratio %||% coord$aspect(ranges[[1]]) - if (is.null(aspect_ratio)) { - aspect_ratio <- 1 - respect <- FALSE - } else { - respect <- TRUE - } - ncol <- max(layout$COL) - nrow <- max(layout$ROW) - mtx <- function(x) matrix(x, nrow = nrow, ncol = ncol, byrow = TRUE) - panel_table <- mtx(panels) - - # @kohske - # Now size of each panel is calculated using PANEL$ranges, which is given by - # coord_train called by train_range. - # So here, "scale" need not to be referred. - # - # In general, panel has all information for building facet. - if (params$space_free$x) { - ps <- layout$PANEL[layout$ROW == 1] - widths <- vapply(ps, function(i) diff(ranges[[i]]$x.range), numeric(1)) - panel_widths <- unit(widths, "null") + if (draw_axes$y) { + table <- weave_axes(table, lapply(axes$y, mtx, o = y_order)) } else { - panel_widths <- rep(unit(1, "null"), ncol) - } - if (params$space_free$y) { - ps <- layout$PANEL[layout$COL == 1] - heights <- vapply(ps, function(i) diff(ranges[[i]]$y.range), numeric(1)) - panel_heights <- unit(heights, "null") - } else { - panel_heights <- rep(unit(1 * abs(aspect_ratio), "null"), nrow) + 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) } - panel_table <- gtable_matrix("layout", panel_table, - panel_widths, panel_heights, respect = respect, clip = coord$clip, z = mtx(1)) - panel_table$layout$name <- paste0('panel-', rep(seq_len(nrow), ncol), '-', rep(seq_len(ncol), each = nrow)) + table + }, - panel_table <- gtable_add_col_space(panel_table, - theme$panel.spacing.x %||% theme$panel.spacing) - panel_table <- gtable_add_row_space(panel_table, - theme$panel.spacing.y %||% theme$panel.spacing) + attach_strips = function(self, table, layout, params, theme) { - # Add axes - if (params$draw_axes$x) { - axes$x <- lapply(axes$x, function(x) mtx(x[x_axis_order])) - panel_table <- weave_axes(panel_table, axes$x)$panels - } else { - panel_table <- gtable_add_rows(panel_table, max_height(axes$x$top), 0) - panel_table <- gtable_add_rows(panel_table, max_height(axes$x$bottom), -1) - panel_pos_col <- panel_cols(panel_table) - panel_table <- gtable_add_grob(panel_table, axes$x$top, 1, panel_pos_col$l, clip = "off", name = paste0("axis-t-", seq_along(axes$x$top)), z = 3) - panel_table <- gtable_add_grob(panel_table, axes$x$bottom, -1, panel_pos_col$l, clip = "off", name = paste0("axis-b-", seq_along(axes$x$bottom)), z = 3) - } + strips <- self$format_strip_labels(layout, params) + strips <- render_strips(strips$cols, strips$rows, theme = theme) - if (params$draw_axes$y) { - axes$y <- lapply(axes$y, function(y) mtx(y[y_axis_order])) - panel_table <- weave_axes(panel_table, axes$y)$panels - } else { - panel_table <- gtable_add_cols(panel_table, max_width(axes$y$left), 0) - panel_table <- gtable_add_cols(panel_table, max_width(axes$y$right), -1) - panel_pos_rows <- panel_rows(panel_table) - panel_table <- gtable_add_grob(panel_table, axes$y$left, panel_pos_rows$t, 1, clip = "off", name = paste0("axis-l-", seq_along(axes$y$left)), z = 3) - panel_table <- gtable_add_grob(panel_table, axes$y$right, panel_pos_rows$t, -1, clip = "off", name = paste0("axis-r-", seq_along(axes$y$right)), z= 3) - } + padding <- convertUnit(calc_element("strip.switch.pad.grid", theme), "cm") - # Add strips switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x") - switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y") - inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside" - inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside" - strip_padding <- convertUnit(theme$strip.switch.pad.grid, "cm") - panel_pos_col <- panel_cols(panel_table) + inside_x <- (calc_element("strip.placement.x", theme) %||% "inside") == "inside" + shift_x <- if (inside_x) 1 else 2 + if (switch_x) { - if (!is.null(strips$x$bottom)) { - if (inside_x) { - panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -2) - panel_table <- gtable_add_grob(panel_table, strips$x$bottom, -2, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2) - } else { - if (!all(vapply(axes$x$bottom, is.zero, logical(1)))) { - panel_table <- gtable_add_rows(panel_table, strip_padding, -1) - } - panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -1) - panel_table <- gtable_add_grob(panel_table, strips$x$bottom, -1, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2) - } - } + 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 + ) } else { - if (!is.null(strips$x$top)) { - if (inside_x) { - panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 1) - panel_table <- gtable_add_grob(panel_table, strips$x$top, 2, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2) - } else { - if (!all(vapply(axes$x$top, is.zero, logical(1)))) { - panel_table <- gtable_add_rows(panel_table, strip_padding, 0) - } - panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 0) - panel_table <- gtable_add_grob(panel_table, strips$x$top, 1, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2) - } - } + 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 + ) } - panel_pos_rows <- panel_rows(panel_table) + + 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 + if (switch_y) { - if (!is.null(strips$y$left)) { - if (inside_y) { - panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 1) - panel_table <- gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 2, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2) - } else { - if (!all(vapply(axes$y$left, is.zero, logical(1)))) { - panel_table <- gtable_add_cols(panel_table, strip_padding, 0) - } - panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 0) - panel_table <- gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 1, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2) - } - } + 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 + ) } else { - if (!is.null(strips$y$right)) { - if (inside_y) { - panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -2) - panel_table <- gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -2, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2) - } else { - if (!all(vapply(axes$y$right, is.zero, logical(1)))) { - panel_table <- gtable_add_cols(panel_table, strip_padding, -1) - } - panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -1) - panel_table <- gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -1, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2) - } - } + 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 + ) } - panel_table + table }, + vars = function(self) { names(c(self$params$rows, self$params$cols)) + }, + + 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, "facet") <- "grid" + cols <- data_frame0(!!!labeller(col_vars)) + } else { + cols <- NULL + } + + rows <- intersect(names(layout), names(params$rows)) + if (length(rows) > 0) { + row_vars <- unique0(layout[rows]) + attr(row_vars, "type") <- "rows" + attr(row_vars, "facet") <- "grid" + rows <- data_frame0(!!!labeller(row_vars)) + } else { + rows <- NULL + } + + list(cols = cols, rows = rows) } ) # Helpers ----------------------------------------------------------------- -ulevels <- function(x) { +ulevels <- function(x, na.last = TRUE) { if (is.factor(x)) { x <- addNA(x, TRUE) factor(levels(x), levels(x), exclude = NULL) } else { - sort(unique0(x)) + sort(unique0(x), na.last = na.last) + } +} + +table_has_grob <- function(table, pattern) { + grobs <- table$grobs[grep(pattern, table$layout$name)] + !all(vapply(grobs, is.zero, logical(1))) +} + +seam_table <- function(table, grobs = NULL, side, shift = 1, name, z = 1, + clip = "off", spacing = NULL) { + if (is.null(grobs)) { + return(table) + } + + panel_col <- panel_cols(table) + panel_row <- panel_rows(table) + + row <- switch( + side, + bottom = max(panel_row$b) + shift - 1L, + 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, + 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) + ) + row <- row + as.numeric(side == "bottom") + col <- col + as.numeric(side == "right") } + + table <- switch( + side, + 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) } diff --git a/R/facet-null.R b/R/facet-null.R index bc95141fde..26b610fdfa 100644 --- a/R/facet-null.R +++ b/R/facet-null.R @@ -6,6 +6,9 @@ NULL #' @inheritParams facet_grid #' @keywords internal #' @export +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_null()` is +#' completely ignored. #' @examples #' # facet_null is the default faceting specification if you #' # don't override it with facet_grid or facet_wrap @@ -27,9 +30,9 @@ FacetNull <- ggproto("FacetNull", Facet, layout_null() }, map_data = function(data, layout, params) { - # Need the is.waive check for special case where no data, but aesthetics + # Need the is.waiver check for special case where no data, but aesthetics # are mapped to vectors - if (is.waive(data)) + if (is.waiver(data)) return(data_frame0(PANEL = factor())) if (empty(data)) @@ -63,11 +66,10 @@ FacetNull <- ggproto("FacetNull", Facet, 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_clip <- c("off", "off", "off", "off", coord$clip, "off", "off", "off", "off") layout <- gtable_matrix("layout", all, widths = grob_widths, heights = grob_heights, - respect = respect, clip = grob_clip, + 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 3fcd05eacd..e1eda21cdb 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -18,12 +18,23 @@ NULL #' @param scales Should scales be fixed (`"fixed"`, the default), #' free (`"free"`), or free in one dimension (`"free_x"`, #' `"free_y"`)? +#' @param space If `"fixed"` (default), all panels have the same size and +#' the number of rows and columns in the layout can be arbitrary. If +#' `"free_x"`, panels have widths proportional to the length of the x-scale, +#' but the layout is constrained to one row. If `"free_y"`, panels have +#' heights proportional to the length of the y-scale, but the layout is +#' constrained to one column. #' @param strip.position By default, the labels are displayed on the top of #' the plot. Using `strip.position` it is possible to place the labels on #' either of the four sides by setting \code{strip.position = c("top", #' "bottom", "left", "right")} #' @param dir Direction: either `"h"` for horizontal, the default, or `"v"`, -#' for vertical. +#' for vertical. When `"h"` or `"v"` will be combined with `as.table` to +#' set final layout. Alternatively, a combination of `"t"` (top) or +#' `"b"` (bottom) with `"l"` (left) or `"r"` (right) to set a layout directly. +#' These two letters give the starting position and the first letter gives +#' the growing direction. For example `"rt"` will place the first panel in +#' the top-right and starts filling in panels right-to-left. #' @param axes Determines which axes will be drawn in case of fixed scales. #' When `"margins"` (default), axes will be drawn at the exterior margins. #' `"all_x"` and `"all_y"` will draw the respective axes at the interior @@ -34,6 +45,15 @@ NULL #' the exterior axes get labels, and the interior axes get none. When #' `"all_x"` or `"all_y"`, only draws the labels at the interior axes in the #' x- or y-direction respectively. +#' +#' @section Layer layout: +#' The [`layer(layout)`][layer()] argument in context of `facet_wrap()` can take +#' the following values: +#' * `NULL` (default) to use the faceting variables to assign panels. +#' * An integer vector to include selected panels. Panel numbers not included in +#' the integer vector are excluded. +#' * `"fixed"` to repeat data across every panel. +#' #' @inheritParams facet_grid #' @seealso #' The `r link_book("facet wrap section", "facet#sec-facet-wrap")` @@ -95,18 +115,58 @@ NULL #' facet_wrap(vars(variable), scales = "free_y", nrow = 2, strip.position = "top") + #' theme(strip.background = element_blank(), strip.placement = "outside") #' } +#' +#' # The two letters determine the starting position, so 'tr' starts +#' # in the top-right. +#' # The first letter determines direction, so 'tr' fills top-to-bottom. +#' # `dir = "tr"` is equivalent to `dir = "v", as.table = FALSE` +#' ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' facet_wrap(vars(class), dir = "tr") facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", - shrink = TRUE, labeller = "label_value", as.table = TRUE, - switch = deprecated(), drop = TRUE, dir = "h", - strip.position = 'top', axes = "margins", + 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")) + dir <- arg_match0(dir, c("h", "v", "lt", "tl", "lb", "bl", "rt", "tr", "rb", "br")) + if (nchar(dir) == 1) { + dir <- base::switch( + dir, + h = if (as.table) "lt" else "lb", + v = if (as.table) "tl" else "tr" + ) + } + free <- list( x = any(scales %in% c("free_x", "free")), y = any(scales %in% c("free_y", "free")) ) + # We cannot have free space in both directions + space <- arg_match0(space, c("free_x", "free_y", "fixed")) + space_free <- list(x = space == "free_x", y = space == "free_y") + if (space_free$x) { + if ((nrow %||% 1) != 1 || !is.null(ncol)) { + cli::cli_warn( + "Cannot use {.code space = \"free_x\"} with custom \\ + {.arg nrow} or {.arg ncol}." + ) + } + ncol <- NULL + nrow <- 1L + } + if (space_free$y) { + if ((ncol %||% 1) != 1 || !is.null(nrow)) { + cli::cli_warn( + "Cannot use {.code space= \"free_y\"} with custom \\ + {.arg nrow} or {.arg ncol}." + ) + } + ncol <- 1L + nrow <- NULL + } + # If scales are free, always draw the axes draw_axes <- arg_match0(axes, c("margins", "all_x", "all_y", "all")) draw_axes <- list( @@ -123,14 +183,15 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", ) # Check for deprecated labellers - labeller <- check_labeller(labeller) + check_labeller(labeller) # Flatten all facets dimensions into a single one - facets <- wrap_as_facets_list(facets) + facets <- compact_facets(facets) if (lifecycle::is_present(switch) && !is.null(switch)) { - deprecate_warn0("2.2.0", "facet_wrap(switch)", "facet_wrap(strip.position)") - strip.position <- if (switch == "x") "bottom" else "left" + lifecycle::deprecate_stop( + "2.2.0", "facet_wrap(switch)", "facet_wrap(strip.position)" + ) } strip.position <- arg_match0(strip.position, c("top", "bottom", "left", "right")) @@ -149,11 +210,11 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", params = list( facets = facets, free = free, - as.table = as.table, strip.position = strip.position, drop = drop, ncol = ncol, nrow = nrow, + space_free = space_free, labeller = labeller, dir = dir, draw_axes = draw_axes, @@ -162,12 +223,6 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", ) } -# Returns a quosures object -wrap_as_facets_list <- function(x) { - facets_list <- as_facets_list(x) - compact_facets(facets_list) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -189,21 +244,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, n <- attr(id, "n") dims <- wrap_dims(n, params$nrow, params$ncol) - layout <- data_frame0( - PANEL = factor(id, levels = seq_len(n)), - ROW = if (params$as.table) { - as.integer((id - 1L) %/% dims[2] + 1L) - } else { - as.integer(dims[1] - (id - 1L) %/% dims[2]) - }, - COL = as.integer((id - 1L) %% dims[2] + 1L), - .size = length(id) - ) - - # For vertical direction, flip row and col - if (identical(params$dir, "v")) { - layout[c("ROW", "COL")] <- layout[c("COL", "ROW")] - } + layout <- wrap_layout(id, dims, params$dir) panels <- vec_cbind(layout, base) panels <- panels[order(panels$PANEL), , drop = FALSE] @@ -215,267 +256,205 @@ FacetWrap <- ggproto("FacetWrap", Facet, panels }, - map_data = function(data, layout, params) { - if (empty(data)) { - return(vec_cbind(data %|W|% NULL, PANEL = integer(0))) - } - vars <- params$facets + 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) + + # Render individual axes + ranges <- censor_labels(ranges, layout, axis_labels) + original <- render_axes(ranges, ranges, coord, theme, transpose = TRUE) + + # Sort axes + x_order <- if (axis_labels$x) layout$SCALE_X else seq_len(nrow(layout)) + y_order <- if (axis_labels$y) layout$SCALE_Y else seq_len(nrow(layout)) + original$x <- lapply(original$x, `[`, i = x_order) + original$y <- lapply(original$y, `[`, i = y_order) + + # Setup matrices for axes + dim <- c(max(layout$ROW), max(layout$COL)) + index <- convertInd(layout$ROW, layout$COL, dim[1]) + empty <- matrix(list(zeroGrob()), dim[1], dim[2]) + top <- bottom <- left <- right <- empty + + # Fill axis matrices + top[index] <- original$x$top + bottom[index] <- original$x$bottom + left[index] <- original$y$left + right[index] <- original$y$right + + # Suppress interior axes + if (!(free$x || draw_axes$x)) { + top[-1, ] <- list(zeroGrob()) + bottom[-dim[1], ] <- list(zeroGrob()) + } + if (!(free$y || draw_axes$y)) { + left[, -1] <- list(zeroGrob()) + right[, -dim[2]] <- list(zeroGrob()) + } - if (length(vars) == 0) { - data$PANEL <- layout$PANEL - return(data) + # Check for empty panels and exit early if there are none + empty <- matrix(TRUE, dim[1], dim[2]) + empty[index] <- FALSE + if (!any(empty)) { + axes <- list(top = top, bottom = bottom, left = left, right = right) + return(weave_axes(table, axes, empty)) } - facet_vals <- eval_facets(vars, data, params$.possible_columns) - facet_vals[] <- lapply(facet_vals[], as_unordered_factor) - layout[] <- lapply(layout[], as_unordered_factor) + # Match empty table to layout + matched <- vec_match( + data_frame0(ROW = as.vector(row(empty)), COL = as.vector(col(empty))), + layout[, c("ROW", "COL")] + ) - missing_facets <- setdiff(names(vars), names(facet_vals)) - if (length(missing_facets) > 0) { + # 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)))) + + # 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) + + # 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 && + !all(vapply(x_axes, is.zero, logical(1))) + if (!clash["bottom"]) { + bottom[empty_bottom] <- x_axes + } + } - to_add <- unique0(layout[missing_facets]) + if (length(empty_top) > 0) { + x_axes <- original$x$top[matched[empty_top]] + clash["top"] <- strip == "top" && !inside && !free$x && + !all(vapply(x_axes, is.zero, logical(1))) + if (!clash["top"]) { + top[empty_top] <- x_axes + } + } - data_rep <- rep.int(1:nrow(data), nrow(to_add)) - facet_rep <- rep(1:nrow(to_add), each = nrow(data)) + if (length(empty_right) > 0) { + y_axes <- original$y$right[matched[empty_right]] + clash["right"] <- strip == "right" && !inside && !free$y && + !all(vapply(y_axes, is.zero, logical(1))) + if (!clash["right"]) { + right[empty_right] <- y_axes + } + } - data <- data[data_rep, , drop = FALSE] - facet_vals <- vec_cbind( - facet_vals[data_rep, , drop = FALSE], - to_add[facet_rep, , drop = FALSE] - ) + if (length(empty_left) > 0) { + y_axes <- original$y$left[matched[empty_left]] + clash["left"] <- strip == "left" && !inside && !free$y && + !all(vapply(y_axes, is.zero, logical(1))) + if (!clash["left"]) { + left[empty_left] <- y_axes + } } - keys <- join_keys(facet_vals, layout, by = names(vars)) + if (any(clash)) { + cli::cli_warn( + "Suppressing axis rendering when \\ + {.code strip.position =\"{strip}\"} and \\ + {.code strip.placement = \"outside\".}" + ) + } - data$PANEL <- layout$PANEL[match(keys$x, keys$y)] - data + axes <- list(top = top, bottom = bottom, left = left, right = right) + weave_axes(table, axes, empty) }, - draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { - if ((params$free$x || params$free$y) && !coord$is_free()) { - cli::cli_abort("{.fn {snake_class(self)}} can't use free scales with {.fn {snake_class(coord)}}.") + + 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") + position <- params$strip.position %||% "top" + pos <- substr(position, 1, 1) + prefix <- paste0("strip-", pos) + + # Setup weaving table + dim <- c(max(layout$ROW), max(layout$COL)) + index <- convertInd(layout$ROW, layout$COL, dim[1]) + mat <- matrix(list(zeroGrob()), dim[1], dim[2]) + mat[index] <- unlist(unname(strips), recursive = FALSE)[[position]] + + # 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 + } else { + 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") + + table <- weave(table, mat, shift, size, name = prefix, z = 2, clip = "off") + + if (!inside) { + 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[!has_axes] <- unit(0, "cm") + table <- weave(table, , shift, padding) + } + + table + }, + + draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { if (inherits(coord, "CoordFlip")) { - if (params$free$x) { - layout$SCALE_X <- seq_len(nrow(layout)) - } else { - layout$SCALE_X <- 1L - } - if (params$free$y) { - layout$SCALE_Y <- seq_len(nrow(layout)) - } else { - layout$SCALE_Y <- 1L - } + # Switch the scales back + layout[c("SCALE_X", "SCALE_Y")] <- layout[c("SCALE_Y", "SCALE_X")] } - ncol <- max(layout$COL) - nrow <- max(layout$ROW) - n <- nrow(layout) panel_order <- order(layout$ROW, layout$COL) layout <- layout[panel_order, ] panels <- panels[panel_order] - panel_pos <- convertInd(layout$ROW, layout$COL, nrow) - - # Fill missing parameters for backward compatibility - params$draw_axes <- params$draw_axes %||% list(x = FALSE, y = FALSE) - params$axis_labels <- params$axis_labels %||% list(x = TRUE, y = TRUE) - - x_axis_order <- if (params$axis_labels$x) layout$SCALE_X else seq(n) - y_axis_order <- if (params$axis_labels$y) layout$SCALE_Y else seq(n) - ranges <- censor_labels(ranges, layout, params$axis_labels) - axes <- render_axes(ranges, ranges, coord, theme, transpose = TRUE) + ggproto_parent(Facet, self)$draw_panels( + panels = panels, layout = layout, + ranges = ranges, coord = coord, + theme = theme, params = params + ) + }, + vars = function(self) { + names(self$params$facets) + }, + format_strip_labels = function(layout, params) { if (length(params$facets) == 0) { - # Add a dummy label - labels_df <- data_frame0("(all)" = "(all)", .size = 1) + labels <- data_frame0("(all)" = "(all)", .size = 1) } else { - labels_df <- layout[names(params$facets)] + labels <- layout[intersect(names(params$facets), names(layout))] } - attr(labels_df, "facet") <- "wrap" - strips <- render_strips( - structure(labels_df, type = "rows"), - structure(labels_df, type = "cols"), - params$labeller, theme) - - # If user hasn't set aspect ratio, ask the coordinate system if - # it wants to specify one - aspect_ratio <- theme$aspect.ratio %||% coord$aspect(ranges[[1]]) - - if (is.null(aspect_ratio)) { - aspect_ratio <- 1 - respect <- FALSE - } else { - respect <- TRUE - } - - empty_table <- matrix(list(zeroGrob()), nrow = nrow, ncol = ncol) - panel_table <- empty_table - panel_table[panel_pos] <- panels - empties <- apply(panel_table, c(1,2), function(x) is.zero(x[[1]])) - panel_table <- gtable_matrix("layout", panel_table, - widths = unit(rep(1, ncol), "null"), - heights = unit(rep(abs(aspect_ratio), nrow), "null"), respect = respect, clip = coord$clip, z = matrix(1, ncol = ncol, nrow = nrow)) - panel_table$layout$name <- paste0('panel-', rep(seq_len(ncol), nrow), '-', rep(seq_len(nrow), each = ncol)) - - panel_table <- gtable_add_col_space(panel_table, - theme$panel.spacing.x %||% theme$panel.spacing) - panel_table <- gtable_add_row_space(panel_table, - theme$panel.spacing.y %||% theme$panel.spacing) - - # Add axes - axis_mat_x_top <- empty_table - axis_mat_x_top[panel_pos] <- axes$x$top[x_axis_order] - axis_mat_x_bottom <- empty_table - axis_mat_x_bottom[panel_pos] <- axes$x$bottom[x_axis_order] - axis_mat_y_left <- empty_table - axis_mat_y_left[panel_pos] <- axes$y$left[y_axis_order] - axis_mat_y_right <- empty_table - axis_mat_y_right[panel_pos] <- axes$y$right[y_axis_order] - if (!(params$free$x || params$draw_axes$x)) { - axis_mat_x_top[-1,]<- list(zeroGrob()) - axis_mat_x_bottom[-nrow,]<- list(zeroGrob()) + if (empty(labels)) { + return(NULL) } - if (!(params$free$y || params$draw_axes$y)) { - axis_mat_y_left[, -1] <- list(zeroGrob()) - axis_mat_y_right[, -ncol] <- list(zeroGrob()) - } - + attr(labels, "facet") <- "wrap" + attr(labels, "type") <- switch(params$strip.position, left = , right = "rows", "cols") - # Add back missing axes - if (any(empties)) { - row_ind <- row(empties) - col_ind <- col(empties) - inside <- (theme$strip.placement %||% "inside") == "inside" - empty_bottom <- apply(empties, 2, function(x) c(diff(x) == 1, FALSE)) - if (any(empty_bottom)) { - pos <- which(empty_bottom) - panel_loc <- data_frame0( - ROW = row_ind[pos], - COL = col_ind[pos], - .size = length(pos) - ) - panels <- vec_match(panel_loc, layout[, c("ROW", "COL")]) - x_axes <- axes$x$bottom[x_axis_order[panels]] - if (params$strip.position == "bottom" && - !inside && - any(!vapply(x_axes, is.zero, logical(1))) && - !params$free$x) { - cli::cli_warn("Suppressing axis rendering when {.code strip.position = \"bottom\"} and {.code strip.placement == \"outside\"}") - } else { - axis_mat_x_bottom[pos] <- x_axes - } - } - empty_top <- apply(empties, 2, function(x) c(FALSE, diff(x) == -1)) - if (any(empty_top)) { - pos <- which(empty_top) - panel_loc <- data_frame0( - ROW = row_ind[pos], - COL = col_ind[pos], - .size = length(pos) - ) - panels <- vec_match(panel_loc, layout[, c("ROW", "COL")]) - x_axes <- axes$x$top[x_axis_order[panels]] - if (params$strip.position == "top" && - !inside && - any(!vapply(x_axes, is.zero, logical(1))) && - !params$free$x) { - cli::cli_warn("Suppressing axis rendering when {.code strip.position = \"top\"} and {.code strip.placement == \"outside\"}") - } else { - axis_mat_x_top[pos] <- x_axes - } - } - empty_right <- t(apply(empties, 1, function(x) c(diff(x) == 1, FALSE))) - if (any(empty_right)) { - pos <- which(empty_right) - panel_loc <- data_frame0( - ROW = row_ind[pos], - COL = col_ind[pos], - .size = length(pos) - ) - panels <- vec_match(panel_loc, layout[, c("ROW", "COL")]) - y_axes <- axes$y$right[y_axis_order[panels]] - if (params$strip.position == "right" && - !inside && - any(!vapply(y_axes, is.zero, logical(1))) && - !params$free$y) { - cli::cli_warn("Suppressing axis rendering when {.code strip.position = \"right\"} and {.code strip.placement == \"outside\"}") - } else { - axis_mat_y_right[pos] <- y_axes - } - } - empty_left <- t(apply(empties, 1, function(x) c(FALSE, diff(x) == -1))) - if (any(empty_left)) { - pos <- which(empty_left) - panel_loc <- data_frame0( - ROW = row_ind[pos], - COL = col_ind[pos], - .size = length(pos) - ) - panels <- vec_match(panel_loc, layout[, c("ROW", "COL")]) - y_axes <- axes$y$left[y_axis_order[panels]] - if (params$strip.position == "left" && - !inside && - any(!vapply(y_axes, is.zero, logical(1))) && - !params$free$y) { - cli::cli_warn("Suppressing axis rendering when {.code strip.position = \"left\"} and {.code strip.placement == \"outside\"}") - } else { - axis_mat_y_left[pos] <- y_axes - } - } - } - panel_table <- weave_axes( - panel_table, - axes = list( - top = axis_mat_x_top, bottom = axis_mat_x_bottom, - left = axis_mat_y_left, right = axis_mat_y_right - ), - empty = empties - ) - axis_size <- panel_table$sizes - panel_table <- panel_table$panels - - strip_padding <- convertUnit(theme$strip.switch.pad.wrap, "cm") - strip_name <- paste0("strip-", substr(params$strip.position, 1, 1)) - strip_mat <- empty_table - strip_mat[panel_pos] <- unlist(unname(strips), recursive = FALSE)[[params$strip.position]] - if (params$strip.position %in% c("top", "bottom")) { - inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside" - if (params$strip.position == "top") { - placement <- if (inside_x) -1 else -2 - strip_pad <- axis_size$top - } else { - placement <- if (inside_x) 0 else 1 - strip_pad <- axis_size$bottom - } - strip_height <- unit(apply(strip_mat, 1, max_height, value_only = TRUE), "cm") - panel_table <- weave_tables_row(panel_table, strip_mat, placement, strip_height, strip_name, 2, coord$clip) - if (!inside_x) { - strip_pad[as.numeric(strip_pad) != 0] <- strip_padding - panel_table <- weave_tables_row(panel_table, row_shift = placement, row_height = strip_pad) - } - } else { - inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside" - if (params$strip.position == "left") { - placement <- if (inside_y) -1 else -2 - strip_pad <- axis_size$left - } else { - placement <- if (inside_y) 0 else 1 - strip_pad <- axis_size$right - } - strip_pad[as.numeric(strip_pad) != 0] <- strip_padding - strip_width <- unit(apply(strip_mat, 2, max_width, value_only = TRUE), "cm") - panel_table <- weave_tables_col(panel_table, strip_mat, placement, strip_width, strip_name, 2, coord$clip) - if (!inside_y) { - strip_pad[as.numeric(strip_pad) != 0] <- strip_padding - panel_table <- weave_tables_col(panel_table, col_shift = placement, col_width = strip_pad) - } - } - panel_table - }, - vars = function(self) { - names(self$params$facets) + labeller <- match.fun(params$labeller) + list(facets = data_frame0(!!!labeller(labels))) } ) @@ -554,7 +533,7 @@ weave_axes <- function(panels, axes, empty = NULL, z = 3L) { for (i in seq_along(axes)) { panels <- weave[[i]](panels, axes[[i]], shift[i], sizes[[i]], names[i], z = z) } - list(panels = panels, sizes = sizes) + panels } # Measures the size of axes while ignoring those bordering empty panels @@ -576,3 +555,46 @@ measure_axes <- function(empty_idx, axis, margin = 1L, shift = 0) { cm[set_zero] <- 0 unit(apply(cm, margin, max), "cm") } + +wrap_layout <- function(id, dims, dir) { + as.table <- TRUE + n <- attr(id, "n") + + if (nchar(dir) != 2) { + # Should only occur when `as.table` was not incorporated into `dir` + dir <- switch(dir, h = "lt", v = "tl") + deprecate_soft0( + "3.5.2", + 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, "\"`.") + )) + ) + } + + dir <- arg_match0(dir, c("lt", "tl", "lb", "bl", "rt", "tr", "rb", "br")) + + 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] + ) + + 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] + ) + + data_frame0( + PANEL = factor(id, levels = seq_len(n)), + ROW = as.integer(ROW), + COL = as.integer(COL), + .size = length(id) + ) +} diff --git a/R/fortify-lm.R b/R/fortify-lm.R deleted file mode 100644 index ebfb0334b2..0000000000 --- a/R/fortify-lm.R +++ /dev/null @@ -1,87 +0,0 @@ -#' Supplement the data fitted to a linear model with model fit statistics. -#' -#' If you have missing values in your model data, you may need to refit -#' the model with `na.action = na.exclude`. -#' -#' @return The original data with extra columns: -#' \item{.hat}{Diagonal of the hat matrix} -#' \item{.sigma}{Estimate of residual standard deviation when -#' corresponding observation is dropped from model} -#' \item{.cooksd}{Cooks distance, [cooks.distance()]} -#' \item{.fitted}{Fitted values of model} -#' \item{.resid}{Residuals} -#' \item{.stdresid}{Standardised residuals} -#' @param model linear model -#' @param data data set, defaults to data used to fit model -#' @param ... not used by this method -#' @keywords internal -#' @export -#' @examples -#' mod <- lm(mpg ~ wt, data = mtcars) -#' head(fortify(mod)) -#' head(fortify(mod, mtcars)) -#' -#' plot(mod, which = 1) -#' -#' ggplot(mod, aes(.fitted, .resid)) + -#' geom_point() + -#' geom_hline(yintercept = 0) + -#' geom_smooth(se = FALSE) -#' -#' ggplot(mod, aes(.fitted, .stdresid)) + -#' geom_point() + -#' geom_hline(yintercept = 0) + -#' geom_smooth(se = FALSE) -#' -#' ggplot(fortify(mod, mtcars), aes(.fitted, .stdresid)) + -#' geom_point(aes(colour = factor(cyl))) -#' -#' ggplot(fortify(mod, mtcars), aes(mpg, .stdresid)) + -#' geom_point(aes(colour = factor(cyl))) -#' -#' plot(mod, which = 2) -#' ggplot(mod) + -#' stat_qq(aes(sample = .stdresid)) + -#' geom_abline() -#' -#' plot(mod, which = 3) -#' ggplot(mod, aes(.fitted, sqrt(abs(.stdresid)))) + -#' geom_point() + -#' geom_smooth(se = FALSE) -#' -#' plot(mod, which = 4) -#' ggplot(mod, aes(seq_along(.cooksd), .cooksd)) + -#' geom_col() -#' -#' plot(mod, which = 5) -#' ggplot(mod, aes(.hat, .stdresid)) + -#' geom_vline(linewidth = 2, colour = "white", xintercept = 0) + -#' geom_hline(linewidth = 2, colour = "white", yintercept = 0) + -#' geom_point() + geom_smooth(se = FALSE) -#' -#' ggplot(mod, aes(.hat, .stdresid)) + -#' geom_point(aes(size = .cooksd)) + -#' geom_smooth(se = FALSE, linewidth = 0.5) -#' -#' plot(mod, which = 6) -#' ggplot(mod, aes(.hat, .cooksd)) + -#' geom_vline(xintercept = 0, colour = NA) + -#' geom_abline(slope = seq(0, 3, by = 0.5), colour = "white") + -#' geom_smooth(se = FALSE) + -#' geom_point() -#' -#' ggplot(mod, aes(.hat, .cooksd)) + -#' geom_point(aes(size = .cooksd / .hat)) + -#' scale_size_area() -fortify.lm <- function(model, data = model$model, ...) { - infl <- stats::influence(model, do.coef = FALSE) - data$.hat <- infl$hat - data$.sigma <- infl$sigma - data$.cooksd <- stats::cooks.distance(model, infl) - - data$.fitted <- stats::predict(model) - data$.resid <- stats::resid(model) - data$.stdresid <- stats::rstandard(model, infl) - - data -} diff --git a/R/fortify-map.R b/R/fortify-map.R index d0dc76b716..19b58a04bf 100644 --- a/R/fortify-map.R +++ b/R/fortify-map.R @@ -1,5 +1,8 @@ #' Fortify method for map objects #' +#' @description +#' `r lifecycle::badge("deprecated")` +#' #' This function turns a map into a data frame that can more easily be #' plotted with ggplot2. #' @@ -24,6 +27,9 @@ #' geom_polygon(aes(group = group), colour = "white") #' } fortify.map <- function(model, data, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), "map_data()" + ) df <- data_frame0( long = model$x, lat = model$y, @@ -46,10 +52,10 @@ fortify.map <- function(model, data, ...) { #' for plotting with ggplot2. #' #' @param map name of map provided by the \pkg{maps} package. These -#' include [maps::county()], [maps::france()], -#' [maps::italy()], [maps::nz()], -#' [maps::state()], [maps::usa()], -#' [maps::world()], [maps::world2()]. +#' include [`"county"`][maps::county], [`"france"`][maps::france], +#' [`"italy"`][maps::italy], [`"nz"`][maps::nz], +#' [`"state"`][maps::state], [`"usa"`][maps::usa], +#' [`"world"`][maps::world], or [`"world2"`][maps::world2]. #' @param region name(s) of subregion(s) to include. Defaults to `.` which #' includes all subregions. See documentation for [maps::map()] #' for more details. @@ -80,7 +86,27 @@ 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, ...) - fortify(map_obj) + + if (!inherits(map_obj, "map")) { + cli::cli_abort(c( + "{.fn maps::map} must return an object of type {.cls map}, not \\ + {obj_type_friendly(map_obj)}.", + i = "Did you pass the right arguments?" + )) + } + + df <- data_frame0( + 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) + ) + + names <- lapply(strsplit(map_obj$names, "[:,]"), "[", 1:2) + names <- vec_rbind(!!!names, .name_repair = ~ c("region", "subregion")) + df[names(names)] <- vec_slice(names, df$group) + vec_slice(df, stats::complete.cases(df$lat, df$long)) } #' Create a layer of map borders @@ -133,6 +159,6 @@ map_data <- function(map, region = ".", exact = FALSE, ...) { borders <- function(database = "world", regions = ".", fill = NA, colour = "grey50", xlim = NULL, ylim = NULL, ...) { df <- map_data(database, regions, xlim = xlim, ylim = ylim) - geom_polygon(aes_(~long, ~lat, group = ~group), data = df, + geom_polygon(aes(.data$long, .data$lat, group = .data$group), data = df, fill = fill, colour = colour, ..., inherit.aes = FALSE) } diff --git a/R/fortify-models.R b/R/fortify-models.R new file mode 100644 index 0000000000..5a0e95199a --- /dev/null +++ b/R/fortify-models.R @@ -0,0 +1,169 @@ +#' Supplement the data fitted to a linear model with model fit statistics. +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' +#' This method is deprecated because using `broom::augment()` is a better +#' solution to supplement data from a linear model. +#' If you have missing values in your model data, you may need to refit +#' the model with `na.action = na.exclude`. +#' +#' @return The original data with extra columns: +#' \item{.hat}{Diagonal of the hat matrix} +#' \item{.sigma}{Estimate of residual standard deviation when +#' corresponding observation is dropped from model} +#' \item{.cooksd}{Cooks distance, [cooks.distance()]} +#' \item{.fitted}{Fitted values of model} +#' \item{.resid}{Residuals} +#' \item{.stdresid}{Standardised residuals} +#' @param model linear model +#' @param data data set, defaults to data used to fit model +#' @param ... not used by this method +#' @keywords internal +#' @export +#' @examplesIf require("broom") +#' mod <- lm(mpg ~ wt, data = mtcars) +#' +#' # Show augmented model +#' head(augment(mod)) +#' head(fortify(mod)) +#' +#' # Using augment to convert model to ready-to-plot data +#' ggplot(augment(mod), aes(.fitted, .resid)) + +#' geom_point() + +#' geom_hline(yintercept = 0) + +#' geom_smooth(se = FALSE) +#' +#' # Colouring by original data not included in the model +#' ggplot(augment(mod, mtcars), aes(.fitted, .std.resid, colour = factor(cyl))) + +#' geom_point() +fortify.lm <- function(model, data = model$model, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), I("`broom::augment()`") + ) + infl <- stats::influence(model, do.coef = FALSE) + data$.hat <- infl$hat + data$.sigma <- infl$sigma + data$.cooksd <- stats::cooks.distance(model, infl) + + data$.fitted <- stats::predict(model) + data$.resid <- stats::resid(model) + data$.stdresid <- stats::rstandard(model, infl) + + data +} + +#' Fortify methods for objects produced by \pkg{multcomp} +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' +#' This function is deprecated because using `broom::tidy()` is a better +#' solution to convert model objects. +#' +#' @param model an object of class `glht`, `confint.glht`, +#' `summary.glht` or [multcomp::cld()] +#' @param data,... other arguments to the generic ignored in this method. +#' @name fortify-multcomp +#' @keywords internal +#' @examplesIf require("multcomp") && require("broom") +#' amod <- aov(breaks ~ wool + tension, data = warpbreaks) +#' wht <- multcomp::glht(amod, linfct = multcomp::mcp(tension = "Tukey")) +#' +#' tidy(wht) # recommended +#' fortify(wht) +#' +#' ggplot(tidy(wht), aes(contrast, estimate)) + geom_point() +#' +#' ci <- confint(wht) +#' tidy(ci) # recommended +#' fortify(ci) +#' +#' ggplot(tidy(confint(wht)), +#' aes(contrast, estimate, ymin = conf.low, ymax = conf.high)) + +#' geom_pointrange() +#' +#' smry <- summary(wht) +#' tidy(smry) # recommended +#' fortify(smry) +#' +#' ggplot(mapping = aes(contrast, estimate)) + +#' geom_linerange(aes(ymin = conf.low, ymax = conf.high), data = tidy(ci)) + +#' geom_point(aes(size = adj.p.value), data = tidy(smry)) + +#' scale_size(transform = "reverse") +#' +#' cld <- multcomp::cld(wht) +#' tidy(cld) # recommended +#' fortify(cld) +NULL + +#' @method fortify glht +#' @rdname fortify-multcomp +#' @export +fortify.glht <- function(model, data, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + ) + base::data.frame( + lhs = rownames(model$linfct), + rhs = model$rhs, + estimate = stats::coef(model), + check.names = FALSE, + stringsAsFactors = FALSE + ) +} + +#' @rdname fortify-multcomp +#' @method fortify confint.glht +#' @export +fortify.confint.glht <- function(model, data, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + ) + coef <- model$confint + colnames(coef) <- to_lower_ascii(colnames(coef)) + + base::data.frame( + lhs = rownames(coef), + rhs = model$rhs, + coef, + check.names = FALSE, + stringsAsFactors = FALSE + ) +} + +#' @method fortify summary.glht +#' @rdname fortify-multcomp +#' @export +fortify.summary.glht <- function(model, data, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + ) + coef <- as.data.frame( + model$test[c("coefficients", "sigma", "tstat", "pvalues")]) + names(coef) <- c("estimate", "se", "t", "p") + + base::data.frame( + lhs = rownames(coef), + rhs = model$rhs, + coef, + check.names = FALSE, + stringsAsFactors = FALSE + ) +} + + +#' @method fortify cld +#' @rdname fortify-multcomp +#' @export +fortify.cld <- function(model, data, ...) { + lifecycle::deprecate_warn( + "3.6.0", I("`fortify()`"), I("`broom::tidy()`") + ) + base::data.frame( + lhs = names(model$mcletters$Letters), + letters = model$mcletters$Letters, + check.names = FALSE, + stringsAsFactors = FALSE + ) +} diff --git a/R/fortify-multcomp.R b/R/fortify-multcomp.R deleted file mode 100644 index 79714b2a68..0000000000 --- a/R/fortify-multcomp.R +++ /dev/null @@ -1,89 +0,0 @@ -#' Fortify methods for objects produced by \pkg{multcomp} -#' -#' @param model an object of class `glht`, `confint.glht`, -#' `summary.glht` or [multcomp::cld()] -#' @param data,... other arguments to the generic ignored in this method. -#' @name fortify-multcomp -#' @keywords internal -#' @examples -#' if (require("multcomp")) { -#' amod <- aov(breaks ~ wool + tension, data = warpbreaks) -#' wht <- glht(amod, linfct = mcp(tension = "Tukey")) -#' -#' fortify(wht) -#' ggplot(wht, aes(lhs, estimate)) + geom_point() -#' -#' CI <- confint(wht) -#' fortify(CI) -#' ggplot(CI, aes(lhs, estimate, ymin = lwr, ymax = upr)) + -#' geom_pointrange() -#' -#' fortify(summary(wht)) -#' ggplot(mapping = aes(lhs, estimate)) + -#' geom_linerange(aes(ymin = lwr, ymax = upr), data = CI) + -#' geom_point(aes(size = p), data = summary(wht)) + -#' scale_size(transform = "reverse") -#' -#' cld <- cld(wht) -#' fortify(cld) -#' } -NULL - -#' @method fortify glht -#' @rdname fortify-multcomp -#' @export -fortify.glht <- function(model, data, ...) { - base::data.frame( - lhs = rownames(model$linfct), - rhs = model$rhs, - estimate = stats::coef(model), - check.names = FALSE, - stringsAsFactors = FALSE - ) -} - -#' @rdname fortify-multcomp -#' @method fortify confint.glht -#' @export -fortify.confint.glht <- function(model, data, ...) { - coef <- model$confint - colnames(coef) <- to_lower_ascii(colnames(coef)) - - base::data.frame( - lhs = rownames(coef), - rhs = model$rhs, - coef, - check.names = FALSE, - stringsAsFactors = FALSE - ) -} - -#' @method fortify summary.glht -#' @rdname fortify-multcomp -#' @export -fortify.summary.glht <- function(model, data, ...) { - coef <- as.data.frame( - model$test[c("coefficients", "sigma", "tstat", "pvalues")]) - names(coef) <- c("estimate", "se", "t", "p") - - base::data.frame( - lhs = rownames(coef), - rhs = model$rhs, - coef, - check.names = FALSE, - stringsAsFactors = FALSE - ) -} - - -#' @method fortify cld -#' @rdname fortify-multcomp -#' @export -fortify.cld <- function(model, data, ...) { - base::data.frame( - lhs = names(model$mcletters$Letters), - letters = model$mcletters$Letters, - check.names = FALSE, - stringsAsFactors = FALSE - ) -} diff --git a/R/fortify-spatial.R b/R/fortify-spatial.R index 6fe7392a37..2bdcf06557 100644 --- a/R/fortify-spatial.R +++ b/R/fortify-spatial.R @@ -1,5 +1,8 @@ #' Fortify method for classes from the sp package. #' +#' @description +#' `r lifecycle::badge("deprecated")` +#' #' To figure out the correct variable name for region, inspect #' `as.data.frame(model)`. #' @@ -71,7 +74,7 @@ fortify.Polygons <- function(model, data, ...) { }) pieces <- vec_rbind0(!!!pieces) - pieces$order <- 1:nrow(pieces) + pieces$order <- seq_len(nrow(pieces)) pieces$id <- model@ID pieces$piece <- factor(pieces$piece) pieces$group <- interaction(pieces$id, pieces$piece) @@ -89,7 +92,7 @@ fortify.Polygon <- function(model, data, ...) { df <- as.data.frame(model@coords) names(df) <- c("long", "lat") - df$order <- 1:nrow(df) + df$order <- seq_len(nrow(df)) df$hole <- model@hole df } @@ -124,7 +127,7 @@ fortify.Lines <- function(model, data, ...) { }) pieces <- vec_rbind0(!!!pieces) - pieces$order <- 1:nrow(pieces) + pieces$order <- seq_len(nrow(pieces)) pieces$id <- model@ID pieces$piece <- factor(pieces$piece) pieces$group <- interaction(pieces$id, pieces$piece) @@ -142,7 +145,7 @@ fortify.Line <- function(model, data, ...) { df <- as.data.frame(model@coords) names(df) <- c("long", "lat") - df$order <- 1:nrow(df) + df$order <- seq_len(nrow(df)) df } diff --git a/R/fortify.R b/R/fortify.R index 15d61c3fd0..108be24674 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -8,19 +8,19 @@ #' @seealso [fortify.lm()] #' @param model model or other R object to convert to data frame #' @param data original dataset, if needed -#' @param ... other arguments passed to methods +#' @inheritParams rlang::args_dots_used #' @export -fortify <- function(model, data, ...) UseMethod("fortify") +fortify <- function(model, data, ...) { + warn_dots_used() + UseMethod("fortify") +} #' @export fortify.data.frame <- function(model, data, ...) model #' @export fortify.tbl_df <- function(model, data, ...) model #' @export -fortify.tbl <- function(model, data, ...) { - check_installed("dplyr", reason = "to work with `tbl` objects.") - dplyr::collect(model) -} +fortify.tbl <- function(model, data, ...) as.data.frame(model) #' @export fortify.NULL <- function(model, data, ...) waiver() #' @export @@ -44,54 +44,66 @@ fortify.grouped_df <- function(model, data, ...) { # There are a lot of ways that dim(), colnames(), or as.data.frame() could # do non-sensical things (they are not even guaranteed to work!) hence the # paranoid mode. -.prevalidate_data_frame_like_object <- function(data) { +check_data_frame_like <- function(data) { orig_dims <- dim(data) - if (!vec_is(orig_dims, integer(), size=2)) - cli::cli_abort(paste0("{.code dim(data)} must return ", - "an {.cls integer} of length 2.")) - if (anyNA(orig_dims) || any(orig_dims < 0)) # extra-paranoid mode - cli::cli_abort(paste0("{.code dim(data)} can't have {.code NA}s ", - "or negative values.")) + if (!vec_is(orig_dims, integer(), size = 2)) { + cli::cli_abort( + "{.code dim(data)} must return an {.cls integer} of length 2." + ) + } + 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." + ) + } orig_colnames <- colnames(data) - if (!vec_is(orig_colnames, character(), size = ncol(data))) - cli::cli_abort(paste0("{.code colnames(data)} must return a ", - "{.cls character} of length {.code ncol(data)}.")) + if (!vec_is(orig_colnames, character(), size = ncol(data))) { + cli::cli_abort( + "{.code colnames(data)} must return a {.cls character} of length {.code ncol(data)}." + ) + } + invisible() } -.postvalidate_data_frame_like_object <- function(df, data) { +check_data_frame_conversion <- function(new, old) { msg0 <- "{.code as.data.frame(data)} must " - if (!is.data.frame(df)) + if (!is.data.frame(new)) { cli::cli_abort(paste0(msg0, "return a {.cls data.frame}.")) - if (!identical(dim(df), dim(data))) + } + if (!identical(dim(new), dim(old))) { cli::cli_abort(paste0(msg0, "preserve dimensions.")) - if (!identical(colnames(df), colnames(data))) + } + if (!identical(colnames(new), colnames(old))) { cli::cli_abort(paste0(msg0, "preserve column names.")) + } + invisible() } validate_as_data_frame <- function(data) { - if (is.data.frame(data)) + if (is.data.frame(data)) { return(data) - .prevalidate_data_frame_like_object(data) + } + check_data_frame_like(data) df <- as.data.frame(data) - .postvalidate_data_frame_like_object(df, data) + check_data_frame_conversion(df, data) df } #' @export fortify.default <- function(model, data, ...) { - msg0 <- paste0( - "{{.arg data}} must be a {{.cls data.frame}}, ", - "or an object coercible by {{.fn fortify}}, or a valid ", - "{{.cls data.frame}}-like object coercible by {{.fn as.data.frame}}" + msg <- paste0( + "{.arg data} must be a {.cls data.frame}, ", + "or an object coercible by {.fn fortify}, or a valid ", + "{.cls data.frame}-like object coercible by {.fn as.data.frame}" ) if (is_mapping(model)) { msg <- c( - glue(msg0, ", not {obj_type_friendly(model)}."), + paste0(msg, ", not ", obj_type_friendly(model), "."), "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?" ) cli::cli_abort(msg) } - msg0 <- paste0(msg0, ". ") + msg <- paste0(msg, ".") try_fetch( validate_as_data_frame(model), - error = function(cnd) cli::cli_abort(glue(msg0), parent = cnd) + error = function(cnd) cli::cli_abort(msg, parent = cnd) ) } diff --git a/R/geom-.R b/R/geom-.R index 6ad6fb67fb..e2d8806b35 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -114,8 +114,9 @@ Geom <- ggproto("Geom", setup_data = function(data, params) data, # Combine data with defaults and set aesthetics from parameters - use_defaults = function(self, data, params = list(), modifiers = aes()) { - default_aes <- self$default_aes + 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)) { @@ -125,14 +126,24 @@ Geom <- ggproto("Geom", # 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_soft0("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 } # Fill in missing aesthetics with their defaults missing_aes <- setdiff(names(default_aes), names(data)) + default_aes <- default_aes[missing_aes] + themed_defaults <- eval_from_theme(default_aes, theme, class(self)) + default_aes[names(themed_defaults)] <- themed_defaults + + # Mark staged/scaled defaults as modifier (#6135) + delayed <- is_scaled_aes(default_aes) | is_staged_aes(default_aes) + if (any(delayed)) { + modifiers <- defaults(modifiers, default_aes[delayed]) + default_aes <- default_aes[!delayed] + } - missing_eval <- lapply(default_aes[missing_aes], eval_tidy) + missing_eval <- lapply(default_aes, eval_tidy) # Needed for geoms with defaults set to NULL (e.g. GeomSf) missing_eval <- compact(missing_eval) @@ -142,34 +153,36 @@ Geom <- ggproto("Geom", data[names(missing_eval)] <- missing_eval } + themed <- is_themed_aes(modifiers) + if (any(themed)) { + themed <- eval_from_theme(modifiers[themed], theme) + modifiers <- modifiers[setdiff(names(modifiers), names(themed))] + data[names(themed)] <- themed + } + # If any after_scale mappings are detected they will be resolved here # This order means that they will have access to all default aesthetics if (length(modifiers) != 0) { - # Set up evaluation environment - env <- child_env(baseenv(), after_scale = after_scale) - # Mask stage with stage_scaled so it returns the correct expression - stage_mask <- child_env(emptyenv(), stage = stage_scaled) - mask <- new_data_mask(as_environment(data, stage_mask), stage_mask) - mask$.data <- as_data_pronoun(mask) - modified_aes <- lapply(substitute_aes(modifiers), eval_tidy, mask, env) + modified_aes <- try_fetch( + eval_aesthetics( + substitute_aes(modifiers), data, + mask = list(stage = stage_scaled) + ), + error = function(cnd) { + cli::cli_warn("Unable to apply staged modifications.", parent = cnd) + data_frame0() + } + ) # Check that all output are valid data - nondata_modified <- check_nondata_cols(modified_aes) - if (length(nondata_modified) > 0) { - issues <- paste0("{.code ", nondata_modified, " = ", as_label(modifiers[[nondata_modified]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetic modifiers returned invalid values", - "x" = "The following mappings are invalid", - issues, - "i" = "Did you map the modifier in the wrong layer?" - )) - } - - names(modified_aes) <- names(rename_aes(modifiers)) - modified_aes <- data_frame0(!!!compact(modified_aes)) - - data <- cunion(modified_aes, data) + check_nondata_cols( + modified_aes, modifiers, + problem = "Aesthetic modifiers returned invalid values.", + hint = "Did you map the modifier in the wrong layer?" + ) + + modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale") + data[names(modified_aes)] <- modified_aes } # Override mappings with params @@ -226,6 +239,35 @@ Geom <- ggproto("Geom", #' @rdname is_tests is_geom <- function(x) inherits(x, "Geom") +eval_from_theme <- function(aesthetics, theme, class = NULL) { + themed <- is_themed_aes(aesthetics) + if (!any(themed)) { + return(aesthetics) + } + + element <- calc_element("geom", theme) %||% .default_geom_element + 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) + class <- to_lower_ascii(class) + + class <- class[class %in% names(theme)] + + # Inherit up to parent geom class + if (length(class) > 0) { + for (cls in rev(class)) { + element <- combine_elements(theme[[cls]], element) + } + } + } + + lapply(aesthetics[themed], eval_tidy, data = element) +} + #' Graphical units #' #' Multiply size in mm by these constants in order to convert to the units @@ -244,7 +286,7 @@ NULL .stroke <- 96 / 25.4 check_aesthetics <- function(x, n) { - ns <- lengths(x) + ns <- list_sizes(x) good <- ns == 1L | ns == n if (all(good)) { @@ -257,9 +299,9 @@ check_aesthetics <- function(x, n) { )) } -check_linewidth <- function(data, name) { +fix_linewidth <- function(data, name) { if (is.null(data$linewidth) && !is.null(data$size)) { - deprecate_soft0("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 da65483635..d87dfdc58b 100644 --- a/R/geom-abline.R +++ b/R/geom-abline.R @@ -132,17 +132,27 @@ GeomAbline <- ggproto("GeomAbline", Geom, # Ensure the line extends well outside the panel to avoid visible line # ending for thick lines ranges$x <- ranges$x + c(-1, 1) * diff(ranges$x) + ranges$y <- ranges$y + c(-1, 1) * diff(ranges$y) } - data$x <- ranges$x[1] - data$xend <- ranges$x[2] - data$y <- ranges$x[1] * data$slope + data$intercept - data$yend <- ranges$x[2] * data$slope + data$intercept + # Restrict 'x' to where 'y' is in range: x = (y - intercept) / slope + x <- sweep(outer(ranges$y, data$intercept, FUN = "-"), 2, data$slope, FUN = "/") + + 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$yend <- data$xend * data$slope + data$intercept GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) }, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), + required_aes = c("slope", "intercept"), draw_key = draw_key_abline, diff --git a/R/geom-bar.R b/R/geom-bar.R index e4611fbabb..b0901502d9 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -45,8 +45,6 @@ #' columns to the left/right of axis breaks. Note that this argument may have #' unintended behaviour when used with alternative positions, e.g. #' `position_dodge()`. -#' @param width Bar width. By default, set to 90% of the [resolution()] of the -#' data. #' @param geom,stat Override the default connection between `geom_bar()` and #' `stat_count()`. For more information about overriding these connections, #' see how the [stat][layer_stats] and [geom][layer_geoms] arguments work. @@ -98,7 +96,6 @@ geom_bar <- function(mapping = NULL, data = NULL, stat = "count", position = "stack", ..., just = 0.5, - width = NULL, na.rm = FALSE, orientation = NA, show.legend = NA, @@ -113,7 +110,6 @@ geom_bar <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list2( just = just, - width = width, na.rm = na.rm, orientation = orientation, ... @@ -134,6 +130,8 @@ GeomBar <- ggproto("GeomBar", GeomRect, # limits, not just those for which x and y are outside the limits non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), + default_aes = aes(!!!GeomRect$default_aes, width = 0.9), + setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params) params @@ -141,14 +139,13 @@ GeomBar <- ggproto("GeomBar", GeomRect, extra_params = c("just", "na.rm", "orientation"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (min(vapply( - split(data$x, data$PANEL, drop = TRUE), - resolution, numeric(1), zero = FALSE - )) * 0.9) + data <- compute_data_size( + 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), @@ -158,16 +155,5 @@ GeomBar <- ggproto("GeomBar", GeomRect, flip_data(data, params$flipped_aes) }, - draw_panel = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", width = NULL, flipped_aes = FALSE) { - # Hack to ensure that width is detected as a parameter - ggproto_parent(GeomRect, self)$draw_panel( - data, - panel_params, - coord, - lineend = lineend, - linejoin = linejoin - ) - }, - rename_size = TRUE + rename_size = FALSE ) diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 2fe756dc96..e0c78ab5e4 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -1,3 +1,6 @@ +#' @include geom-tile.R +NULL + #' Heatmap of 2d bin counts #' #' Divides the plane into rectangles, counts the number of cases in @@ -22,7 +25,7 @@ #' # You can control the size of the bins by specifying the number of #' # bins in each direction: #' d + geom_bin_2d(bins = 10) -#' d + geom_bin_2d(bins = 30) +#' d + geom_bin_2d(bins = list(x = 30, y = 10)) #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) @@ -37,7 +40,7 @@ geom_bin_2d <- function(mapping = NULL, data = NULL, data = data, mapping = mapping, stat = stat, - geom = GeomTile, + geom = GeomBin2d, position = position, show.legend = show.legend, inherit.aes = inherit.aes, @@ -53,3 +56,8 @@ geom_bin_2d <- function(mapping = NULL, data = NULL, #' @usage NULL geom_bin2d <- geom_bin_2d +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomBin2d <- ggproto("GeomBin2d", GeomTile) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 399f92d7a8..316dd6004b 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -43,11 +43,20 @@ #' needs to show the full data range, please use `outlier.shape = NA` instead. #' @param outlier.colour,outlier.color,outlier.fill,outlier.shape,outlier.size,outlier.stroke,outlier.alpha #' Default aesthetics for outliers. Set to `NULL` to inherit from the -#' aesthetics used for the box. -#' -#' In the unlikely event you specify both US and UK spellings of colour, the -#' US spelling will take precedence. -#' +#' data's aesthetics. +#' @param whisker.colour,whisker.color,whisker.linetype,whisker.linewidth +#' Default aesthetics for the whiskers. Set to `NULL` to inherit from the +#' data's aesthetics. +#' @param median.colour,median.color,median.linetype,median.linewidth +#' Default aesthetics for the median line. Set to `NULL` to inherit from the +#' data's aesthetics. +#' @param staple.colour,staple.color,staple.linetype,staple.linewidth +#' Default aesthetics for the staples. Set to `NULL` to inherit from the +#' data's aesthetics. Note that staples don't appear unless the `staplewidth` +#' argument is set to a non-zero size. +#' @param box.colour,box.color,box.linetype,box.linewidth +#' Default aesthetics for the boxes. Set to `NULL` to inherit from the +#' data's aesthetics. #' @param notch If `FALSE` (default) make a standard box plot. If #' `TRUE`, make a notched box plot. Notches are used to compare groups; #' if the notches of two boxes do not overlap, this suggests that the medians @@ -60,6 +69,9 @@ #' `TRUE`, boxes are drawn with widths proportional to the #' square-roots of the number of observations in the groups (possibly #' weighted, using the `weight` aesthetic). +#' @note In the unlikely event you specify both US and UK spellings of colour, +#' the US spelling will take precedence. +#' #' @export #' @references McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of #' box plots. The American Statistician 32, 12-16. @@ -117,10 +129,26 @@ geom_boxplot <- function(mapping = NULL, data = NULL, outlier.colour = NULL, outlier.color = NULL, outlier.fill = NULL, - outlier.shape = 19, - outlier.size = 1.5, + 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, @@ -140,6 +168,39 @@ geom_boxplot <- function(mapping = NULL, data = NULL, } } + outlier_gp <- list( + colour = outlier.color %||% outlier.colour, + fill = outlier.fill, + shape = outlier.shape, + size = outlier.size, + stroke = outlier.stroke, + alpha = outlier.alpha + ) + + whisker_gp <- list( + colour = whisker.color %||% whisker.colour, + linetype = whisker.linetype, + linewidth = whisker.linewidth + ) + + staple_gp <- list( + colour = staple.color %||% staple.colour, + linetype = staple.linetype, + linewidth = staple.linewidth + ) + + median_gp <- list( + colour = median.color %||% median.colour, + linetype = median.linetype, + linewidth = median.linewidth + ) + + box_gp <- list( + colour = box.color %||% box.colour, + linetype = box.linetype, + linewidth = box.linewidth + ) + check_number_decimal(staplewidth) check_bool(outliers) @@ -153,12 +214,11 @@ geom_boxplot <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list2( outliers = outliers, - outlier.colour = outlier.color %||% outlier.colour, - outlier.fill = outlier.fill, - outlier.shape = outlier.shape, - outlier.size = outlier.size, - outlier.stroke = outlier.stroke, - outlier.alpha = outlier.alpha, + outlier_gp = outlier_gp, + whisker_gp = whisker_gp, + staple_gp = staple_gp, + median_gp = median_gp, + box_gp = box_gp, notch = notch, notchwidth = notchwidth, staplewidth = staplewidth, @@ -176,21 +236,30 @@ geom_boxplot <- function(mapping = NULL, data = NULL, #' @export GeomBoxplot <- ggproto("GeomBoxplot", Geom, - # need to declare `width` here in case this geom is used with a stat that - # doesn't have a `width` parameter (e.g., `stat_identity`). - extra_params = c("na.rm", "width", "orientation", "outliers"), + extra_params = c("na.rm", "orientation", "outliers"), setup_params = function(data, params) { + if ("fatten" %in% names(params)) { + deprecate_soft0( + "3.6.0", "geom_boxplot(fatten)", + "geom_boxplot(median.linewidth)" + ) + } else { + # For backward compatibility reasons + params$fatten <- 2 + } params$flipped_aes <- has_flipped_aes(data, params) params }, - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) - + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) if (isFALSE(params$outliers)) { data$outliers <- NULL } @@ -222,12 +291,11 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, }, draw_group = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", fatten = 2, outlier.colour = NULL, - outlier.fill = NULL, outlier.shape = 19, - outlier.size = 1.5, outlier.stroke = 0.5, - outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, + 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 <- check_linewidth(data, snake_class(self)) + 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) { @@ -237,36 +305,30 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, )) } - common <- list( - colour = data$colour, - linewidth = data$linewidth, - linetype = data$linetype, - fill = fill_alpha(data$fill, data$alpha), - group = data$group - ) + common <- list(fill = fill_alpha(data$fill, data$alpha), group = data$group) whiskers <- data_frame0( x = c(data$x, data$x), xend = c(data$x, data$x), y = c(data$upper, data$lower), yend = c(data$ymax, data$ymin), + 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, .size = 2 ) whiskers <- flip_data(whiskers, flipped_aes) - box <- data_frame0( - xmin = data$xmin, - xmax = data$xmax, - ymin = data$lower, - y = data$middle, - ymax = data$upper, - ynotchlower = ifelse(notch, data$notchlower, NA), - ynotchupper = ifelse(notch, data$notchupper, NA), - notchwidth = notchwidth, - alpha = data$alpha, - !!!common + box <- transform( + data, + y = middle, + ymax = upper, + ymin = lower, + ynotchlower = ifelse(notch, notchlower, NA), + ynotchupper = ifelse(notch, notchupper, NA), + notchwidth = notchwidth ) box <- flip_data(box, flipped_aes) @@ -274,13 +336,13 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, outliers <- data_frame0( y = data$outliers[[1]], x = data$x[1], - colour = outlier.colour %||% data$colour[1], - fill = outlier.fill %||% data$fill[1], - shape = outlier.shape %||% data$shape[1], - size = outlier.size %||% data$size[1], - stroke = outlier.stroke %||% data$stroke[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, + stroke = outlier_gp$stroke %||% data$stroke[1] %||% 0.5, fill = NA, - alpha = outlier.alpha %||% data$alpha[1], + alpha = outlier_gp$alpha %||% data$alpha[1], .size = length(data$outliers[[1]]) ) outliers <- flip_data(outliers, flipped_aes) @@ -296,6 +358,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, xend = rep((data$xmax - data$x) * staplewidth + data$x, 2), y = c(data$ymax, data$ymin), yend = c(data$ymax, data$ymin), + linetype = rep(staple_gp$linetype %||% data$linetype, 2), + linewidth = rep(staple_gp$linewidth %||% data$linewidth, 2), + colour = rep(staple_gp$colour %||% data$colour, 2), alpha = c(NA_real_, NA_real_), !!!common, .size = 2 @@ -320,15 +385,22 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, coord, lineend = lineend, linejoin = linejoin, - flipped_aes = flipped_aes + flipped_aes = flipped_aes, + middle_gp = median_gp, + box_gp = box_gp ) )) }, draw_key = draw_key_boxplot, - default_aes = aes(weight = 1, colour = "grey20", fill = "white", size = NULL, - alpha = NA, shape = 19, linetype = "solid", linewidth = 0.5), + 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), + linewidth = from_theme(borderwidth), + width = 0.9 + ), required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"), diff --git a/R/geom-col.R b/R/geom-col.R index 2dc07f12da..77c756f573 100644 --- a/R/geom-col.R +++ b/R/geom-col.R @@ -4,7 +4,6 @@ geom_col <- function(mapping = NULL, data = NULL, position = "stack", ..., just = 0.5, - width = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) { @@ -19,7 +18,6 @@ geom_col <- function(mapping = NULL, data = NULL, inherit.aes = inherit.aes, params = list2( just = just, - width = width, na.rm = na.rm, ... ) diff --git a/R/geom-contour.R b/R/geom-contour.R index 7dfe9fb228..00cddd51e5 100644 --- a/R/geom-contour.R +++ b/R/geom-contour.R @@ -124,13 +124,7 @@ geom_contour_filled <- function(mapping = NULL, data = NULL, #' @export #' @include geom-path.R GeomContour <- ggproto("GeomContour", GeomPath, - default_aes = aes( - weight = 1, - colour = "#3366FF", - linewidth = 0.5, - linetype = 1, - alpha = NA - ) + default_aes = aes(weight = 1, !!!GeomPath$default_aes) ) #' @rdname ggplot2-ggproto diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 36c3d4b9ff..c8452b2e9a 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -1,13 +1,40 @@ #' @export #' @rdname geom_linerange +#' @param middle.colour,middle.color,middle.linetype,middle.linewidth +#' Default aesthetics for the middle line. Set to `NULL` to inherit from the +#' data's aesthetics. +#' @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", ..., - fatten = 2.5, + 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, + linewidth = middle.linewidth + ) + + box_gp <- list( + colour = box.color %||% box.colour, + linetype = box.linetype, + linewidth = box.linewidth + ) + layer( data = data, mapping = mapping, @@ -17,6 +44,8 @@ geom_crossbar <- function(mapping = NULL, data = NULL, show.legend = show.legend, inherit.aes = inherit.aes, params = list2( + middle_gp = middle_gp, + box_gp = box_gp, fatten = fatten, na.rm = na.rm, orientation = orientation, @@ -31,6 +60,15 @@ geom_crossbar <- function(mapping = NULL, data = NULL, #' @export GeomCrossbar <- ggproto("GeomCrossbar", Geom, setup_params = function(data, params) { + if (lifecycle::is_present(params$fatten %||% deprecated())) { + deprecate_soft0( + "3.6.0", "geom_crossbar(fatten)", + "geom_crossbar(middle.linewidth)" + ) + } else { + # For backward compatibility reasons + params$fatten <- 2.5 + } GeomErrorbar$setup_params(data, params) }, @@ -40,8 +78,13 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, GeomErrorbar$setup_data(data, params) }, - default_aes = aes(colour = "black", fill = NA, linewidth = 0.5, linetype = 1, - alpha = NA), + default_aes = aes( + colour = from_theme(colour %||% ink), + fill = from_theme(fill %||% NA), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), + alpha = NA + ), required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"), @@ -49,11 +92,12 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre", fatten = 2.5, width = NULL, - flipped_aes = FALSE) { - data <- check_linewidth(data, snake_class(self)) + 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 <- 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) @@ -82,9 +126,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, 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) ) @@ -94,13 +138,14 @@ 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 ) } + box <- data_frame0(!!!defaults(compact(box_gp), box)) box <- flip_data(box, flipped_aes) middle <- flip_data(middle, flipped_aes) diff --git a/R/geom-curve.R b/R/geom-curve.R index a2597a8d72..6d6ec0027d 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -40,16 +40,30 @@ geom_curve <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomCurve <- ggproto("GeomCurve", GeomSegment, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + draw_panel = function(data, panel_params, coord, curvature = 0.5, angle = 90, ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) { if (!coord$is_linear()) { cli::cli_warn("{.fn geom_curve} is not implemented for non-linear coordinates") } + data <- remove_missing( + data, na.rm = na.rm, + c("x", "y", "xend", "yend", "linetype", "linewidth"), + name = "geom_curve" + ) trans <- coord$transform(data, panel_params) + flip <- flip_curve(trans, coord, panel_params) + if (flip) { + trans <- rename(trans, c(x = "xend", xend = "x", y = "yend", yend = "y")) + if (!is.null(arrow)) { + # Flip end where arrow appears (2 = last, 1 = first, 3 = both) + arrow$ends <- match(arrow$ends, c(2, 1, 3)) + } + } + arrow.fill <- arrow.fill %||% trans$colour curveGrob( @@ -57,13 +71,51 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, default.units = "native", curvature = curvature, angle = angle, ncp = ncp, square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE, - gp = gpar( + gp = gg_par( col = alpha(trans$colour, trans$alpha), fill = alpha(arrow.fill, trans$alpha), - lwd = trans$linewidth * .pt, + lwd = trans$linewidth, lty = trans$linetype, lineend = lineend), arrow = arrow ) } ) + +# Helper function for determining whether curves should swap segment ends to +# keep curvature consistent over transformations +flip_curve <- function(data, coord, params) { + flip <- FALSE + + # Figure implicit flipping transformations in coords + if (inherits(coord, "CoordFlip")) { + flip <- !flip + } else if (inherits(coord, "CoordTrans")) { + if (identical(coord$trans$x$name, "reverse")) { + flip <- !flip + } + if (identical(coord$trans$y$name, "reverse")) { + flip <- !flip + } + } + + # We don't flip when none or both directions are reversed + if ((coord$reverse %||% "none") %in% c("x", "y")) { + flip <- !flip + } + + # Check scales for reverse transforms + # Note that polar coords do not have x/y scales, but these are unsupported + # anyway + fn <- params$x$get_transformation + if (is.function(fn) && identical(fn()$name, "reverse")) { + flip <- !flip + } + + fn <- params$y$get_transformation + if (is.function(fn) && identical(fn()$name, "reverse")) { + flip <- !flip + } + + flip +} diff --git a/R/geom-defaults.R b/R/geom-defaults.R index 228194b4d2..0d4cbf9142 100644 --- a/R/geom-defaults.R +++ b/R/geom-defaults.R @@ -1,10 +1,27 @@ #' Modify geom/stat aesthetic defaults for future plots #' +#' Functions to update or reset the default aesthetics of geoms and stats. +#' #' @param stat,geom Name of geom/stat to modify (like `"point"` or #' `"bin"`), or a Geom/Stat object (like `GeomPoint` or #' `StatBin`). -#' @param new Named list of aesthetics. +#' @param new One of the following: +#' * A named list of aesthetics to serve as new defaults. +#' * `NULL` to reset the defaults. #' @keywords internal +#' @note +#' Please note that geom defaults can be set *en masse* via the `theme(geom)` +#' argument. The guidelines for when to use which function are as follows: +#' +#' * If you want to change defaults for all geoms in all plots, use +#' `theme_update(geom = element_geom(...))`. +#' * If you want to change defaults for all geoms in a single plot, use +#' `+ theme(geom = element_geom(...))`. +#' * If you want to change defaults for one geom in all plots, use +#' `update_geom_defaults()`. +#' * If you want to change settings for one geom in a single plot, use fixed +#' aesthetic parameters in a layer, like so: `geom_point(colour = "red")`. +#' #' @export #' @examples #' @@ -15,9 +32,11 @@ #' GeomPoint$default_aes #' ggplot(mtcars, aes(mpg, wt)) + geom_point() #' -#' # reset default -#' update_geom_defaults("point", aes(color = "black")) +#' # reset single default +#' update_geom_defaults("point", NULL) #' +#' # reset all defaults +#' reset_geom_defaults() #' #' # updating a stat's default aesthetic settings #' # example: change stat_bin()'s default y-axis to the density scale @@ -28,30 +47,21 @@ #' geom_histogram() + #' geom_function(fun = dnorm, color = "red") #' -#' # reset default -#' update_stat_defaults("bin", aes(y = after_stat(count))) +#' # reset single default +#' update_stat_defaults("bin", NULL) +#' +#' # reset all defaults +#' reset_stat_defaults() #' #' @rdname update_defaults update_geom_defaults <- function(geom, new) { - g <- check_subclass(geom, "Geom", env = parent.frame()) - old <- g$default_aes - new <- rename_aes(new) - new_names_order <- unique(c(names(old), names(new))) - new <- defaults(new, old)[new_names_order] - g$default_aes[names(new)] <- new - invisible() + update_defaults(geom, "Geom", new, env = parent.frame()) } #' @rdname update_defaults #' @export update_stat_defaults <- function(stat, new) { - g <- check_subclass(stat, "Stat", env = parent.frame()) - old <- g$default_aes - new <- rename_aes(new) - new_names_order <- unique(c(names(old), names(new))) - new <- defaults(new, old)[new_names_order] - g$default_aes[names(new)] <- new - invisible() + update_defaults(stat, "Stat", new, env = parent.frame()) } #' Resolve and get geom defaults @@ -80,24 +90,82 @@ update_stat_defaults <- function(stat, new) { #' #' # Using a class #' get_geom_defaults(GeomPoint) -get_geom_defaults <- function(geom, theme = theme_get()) { - theme <- theme %||% list() +#' +#' # Changed theme +#' get_geom_defaults("point", theme(geom = element_geom(ink = "purple"))) +get_geom_defaults <- function(geom, theme = get_theme()) { + theme <- theme %||% list(geom = .default_geom_element) if (is.function(geom)) { geom <- geom() } if (is_layer(geom)) { data <- data_frame0(.id = 1L) - data <- geom$compute_geom_2(data = data) + data <- geom$compute_geom_2(data = data, theme = theme) data$.id <- NULL return(data) } if (is.character(geom)) { - geom <- check_subclass(geom, "Geom") + geom <- validate_subclass(geom, "Geom") } - if (inherits(geom, "Geom")) { - out <- geom$use_defaults(data = NULL) + if (is_geom(geom)) { + out <- geom$use_defaults(data = NULL, theme = theme) return(out) } stop_input_type(geom, as_cli("a layer function, string or {.cls Geom} object")) } + +#' @rdname update_defaults +#' @export +reset_geom_defaults <- function() reset_defaults("geom") + +#' @rdname update_defaults +#' @export +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) + index <- snake_class(obj) + + 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 + + old <- obj$default_aes + # Only update cache the first time defaults are changed + if (!exists(index, envir = cache_defaults)) { + cache_defaults[[index]] <- old + } + new <- rename_aes(new) + name_order <- unique(c(names(old), names(new))) + new <- defaults(new, old)[name_order] + obj$default_aes[names(new)] <- new + invisible(old) + + } +} + +reset_defaults <- function(type) { + # Lookup matching names in cache + prefix <- paste0("^", type, "_") + full_names <- grep(prefix, ls(cache_defaults), value = TRUE) + # Early exit if there is nothing to reset + if (length(full_names) < 1) { + return(invisible()) + } + # Format names without prefix + short_names <- gsub(prefix, "", full_names) + names(short_names) <- full_names + + # Run updates + update <- switch(type, geom = update_geom_defaults, update_stat_defaults) + invisible(lapply(short_names, update, new = NULL)) +} diff --git a/R/geom-density.R b/R/geom-density.R index c71a9f98eb..bc9bfd7b81 100644 --- a/R/geom-density.R +++ b/R/geom-density.R @@ -92,8 +92,12 @@ geom_density <- function(mapping = NULL, data = NULL, #' @export #' @include geom-ribbon.R GeomDensity <- ggproto("GeomDensity", GeomArea, - default_aes = defaults( - aes(fill = NA, weight = 1, colour = "black", alpha = NA), - GeomArea$default_aes + default_aes = aes( + colour = from_theme(colour %||% ink), + fill = from_theme(fill %||% NA), + weight = 1, + alpha = NA, + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype) ) ) diff --git a/R/geom-density2d.R b/R/geom-density2d.R index e95a8b2c31..778cac80fe 100644 --- a/R/geom-density2d.R +++ b/R/geom-density2d.R @@ -106,7 +106,12 @@ geom_density2d <- geom_density_2d #' @usage NULL #' @export GeomDensity2d <- ggproto("GeomDensity2d", GeomPath, - default_aes = aes(colour = "#3366FF", linewidth = 0.5, linetype = 1, alpha = NA) + default_aes = aes( + colour = from_theme(colour %||% accent), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ) ) #' @export diff --git a/R/geom-dotplot.R b/R/geom-dotplot.R index d79e6a823e..e912c44877 100644 --- a/R/geom-dotplot.R +++ b/R/geom-dotplot.R @@ -188,34 +188,44 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, required_aes = c("x", "y"), non_missing_aes = c("size", "shape"), - default_aes = aes(colour = "black", fill = "black", alpha = NA, - stroke = 1, linetype = "solid", weight = 1), + default_aes = aes( + colour = from_theme(colour %||% ink), + fill = from_theme(fill %||% ink), + alpha = NA, + stroke = from_theme(borderwidth * 2), + linetype = from_theme(linetype), + weight = 1, + width = 0.9 + ), - setup_data = function(data, params) { - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + setup_data = function(self, data, params) { + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) # Set up the stacking function and range if (is.null(params$stackdir) || params$stackdir == "up") { - stackdots <- function(a) a - .5 + stackdots <- function(a) a - 0.5 stackaxismin <- 0 stackaxismax <- 1 } else if (params$stackdir == "down") { - stackdots <- function(a) -a + .5 + stackdots <- function(a) -a + 0.5 stackaxismin <- -1 stackaxismax <- 0 } else if (params$stackdir == "center") { stackdots <- function(a) a - 1 - max(a - 1) / 2 - stackaxismin <- -.5 - stackaxismax <- .5 + stackaxismin <- -0.5 + stackaxismax <- 0.5 } else if (params$stackdir == "centerwhole") { stackdots <- function(a) a - 1 - floor(max(a - 1) / 2) - stackaxismin <- -.5 - stackaxismax <- .5 + stackaxismin <- -0.5 + stackaxismax <- 0.5 } # Fill the bins: at a given x (or y), if count=3, make 3 entries at that x - data <- data[rep(1:nrow(data), data$count), ] + data <- data[rep(seq_len(nrow(data)), data$count), ] # Next part will set the position of each dot within each stack # If stackgroups=TRUE, split only on x (or y) and panel; if not stacking, also split by group @@ -231,7 +241,7 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, # Within each x, or x+group, set countidx=1,2,3, and set stackpos according to stack function data <- dapply(data, plyvars, function(xx) { - xx$countidx <- 1:nrow(xx) + xx$countidx <- seq_len(nrow(xx)) xx$stackpos <- stackdots(xx$countidx) xx }) @@ -281,11 +291,11 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, binaxis <- ifelse(binaxis == "x", "y", "x") if (binaxis == "x") { - stackaxis = "y" + stackaxis <- "y" dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$x.range) - min(panel_params$x.range)) } else if (binaxis == "y") { - stackaxis = "x" + stackaxis <- "x" dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$y.range) - min(panel_params$y.range)) } @@ -293,10 +303,10 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, dotstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc, stackposition = tdata$stackpos, stackdir = stackdir, stackratio = stackratio, default.units = "npc", - gp = gpar(col = alpha(tdata$colour, tdata$alpha), - fill = fill_alpha(tdata$fill, tdata$alpha), - lwd = tdata$stroke, lty = tdata$linetype, - lineend = lineend)) + 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 c02ab16ed9..f6102a04d6 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -23,13 +23,48 @@ geom_errorbar <- function(mapping = NULL, data = NULL, ) } +#' @export +#' @rdname geom_linerange +#' @note +#' `geom_errorbarh()` is `r lifecycle::badge("deprecated")`. Use +#' `geom_errorbar(orientation = "y")` instead. +geom_errorbarh <- function(mapping = NULL, data = NULL, + stat = "identity", position = "identity", + ..., + orientation = "y", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE) { + deprecate_soft0( + "3.5.2", "geom_errobarh()", "geom_errorbar(orientation = \"y\")", + id = "no-more-errorbarh" + ) + geom_errorbar( + mapping = mapping, + data = data, + stat = stat, + position = position, + ..., + orientation = orientation, + na.rm = na.rm, + show.legend = show.legend, + inherit.aes = inherit.aes + ) +} + #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL #' @export GeomErrorbar <- ggproto("GeomErrorbar", Geom, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, width = 0.5, - alpha = NA), + + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + width = 0.9, + alpha = NA + ), draw_key = draw_key_path, @@ -41,20 +76,24 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, extra_params = c("na.rm", "orientation"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) 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) { - data <- check_linewidth(data, snake_class(self)) + 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) @@ -74,3 +113,18 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, rename_size = TRUE ) + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GeomErrorbarh <- ggproto( + "GeomErrorbarh", GeomErrorbar, + setup_params = function(data, params) { + deprecate_soft0( + "3.5.2", "geom_errobarh()", "geom_errorbar(orientation = \"y\")", + id = "no-more-errorbarh" + ) + GeomLinerange$setup_params(data, params) + } +) diff --git a/R/geom-errorbarh.R b/R/geom-errorbarh.R deleted file mode 100644 index b23d125da4..0000000000 --- a/R/geom-errorbarh.R +++ /dev/null @@ -1,85 +0,0 @@ -#' Horizontal error bars -#' -#' A rotated version of [geom_errorbar()]. -#' -#' @eval rd_aesthetics("geom", "errorbarh") -#' @inheritParams layer -#' @inheritParams geom_point -#' @export -#' @examples -#' df <- data.frame( -#' trt = factor(c(1, 1, 2, 2)), -#' resp = c(1, 5, 3, 4), -#' group = factor(c(1, 2, 1, 2)), -#' se = c(0.1, 0.3, 0.3, 0.2) -#' ) -#' -#' # Define the top and bottom of the errorbars -#' -#' p <- ggplot(df, aes(resp, trt, colour = group)) -#' p + -#' geom_point() + -#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se)) -#' -#' p + -#' geom_point() + -#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) -geom_errorbarh <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomErrorbarh, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - - -#' @rdname ggplot2-ggproto -#' @format NULL -#' @usage NULL -#' @export -GeomErrorbarh <- ggproto("GeomErrorbarh", Geom, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, height = 0.5, - alpha = NA), - - draw_key = draw_key_path, - - required_aes = c("xmin", "xmax", "y"), - - setup_data = function(data, params) { - data$height <- data$height %||% - params$height %||% (resolution(data$y, FALSE, TRUE) * 0.9) - - transform(data, - ymin = y - height / 2, ymax = y + height / 2, height = NULL - ) - }, - - draw_panel = function(self, data, panel_params, coord, height = NULL, lineend = "butt") { - data <- check_linewidth(data, snake_class(self)) - GeomPath$draw_panel(data_frame0( - x = vec_interleave(data$xmax, data$xmax, NA, data$xmax, data$xmin, NA, data$xmin, data$xmin), - y = vec_interleave(data$ymin, data$ymax, NA, data$y, data$y, NA, data$ymin, data$ymax), - colour = rep(data$colour, each = 8), - alpha = rep(data$alpha, each = 8), - linewidth = rep(data$linewidth, each = 8), - linetype = rep(data$linetype, each = 8), - group = rep(1:(nrow(data)), each = 8), - .size = nrow(data) * 8 - ), panel_params, coord, lineend = lineend) - }, - - rename_size = TRUE -) diff --git a/R/geom-function.R b/R/geom-function.R index 47ce54a627..c566731996 100644 --- a/R/geom-function.R +++ b/R/geom-function.R @@ -90,7 +90,7 @@ geom_function <- function(mapping = NULL, data = NULL, stat = "function", #' @export #' @include geom-path.R GeomFunction <- ggproto("GeomFunction", GeomPath, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, + 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) @@ -102,7 +102,7 @@ GeomFunction <- ggproto("GeomFunction", GeomPath, } ggproto_parent(GeomPath, self)$draw_panel( - data, panel_params, coord, arrow, lineend, linejoin, linemitre, na.rm + data, panel_params, coord, arrow, arrow.fill, lineend, linejoin, linemitre, na.rm ) } ) diff --git a/R/geom-hex.R b/R/geom-hex.R index a220e12140..27db70f1d5 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -6,6 +6,7 @@ #' the very regular alignment of [geom_bin_2d()]. #' #' @eval rd_aesthetics("geom", "hex") +#' @eval rd_aesthetics("stat", "binhex") #' @seealso [stat_bin_2d()] for rectangular binning #' @param geom,stat Override the default connection between `geom_hex()` and #' `stat_bin_hex()`. For more information about overriding these connections, @@ -57,7 +58,7 @@ geom_hex <- function(mapping = NULL, data = NULL, GeomHex <- ggproto("GeomHex", Geom, draw_group = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre", linemitre = 10) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (empty(data)) { return(zeroGrob()) } @@ -89,10 +90,10 @@ GeomHex <- ggproto("GeomHex", Geom, ggname("geom_hex", polygonGrob( coords$x, coords$y, - gp = gpar( + gp = gg_par( col = data$colour, fill = fill_alpha(data$fill, data$alpha), - lwd = data$linewidth * .pt, + lwd = data$linewidth, lty = data$linetype, lineend = lineend, linejoin = linejoin, @@ -106,10 +107,10 @@ GeomHex <- ggproto("GeomHex", Geom, required_aes = c("x", "y"), default_aes = aes( - colour = NA, - fill = "grey50", - linewidth = 0.5, - linetype = 1, + colour = from_theme(colour %||% NA), + fill = from_theme(fill %||% col_mix(ink, paper)), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), alpha = NA ), @@ -117,34 +118,3 @@ GeomHex <- ggproto("GeomHex", Geom, rename_size = TRUE ) - - -# Draw hexagon grob -# Modified from code by Nicholas Lewin-Koh and Martin Maechler -# -# @param x positions of hex centres -# @param y positions -# @param size vector of hex sizes -# @param gp graphical parameters -# @keyword internal -# -# THIS IS NO LONGER USED BUT LEFT IF CODE SOMEWHERE ELSE RELIES ON IT -hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) { - if (length(y) != length(x)) { - cli::cli_abort("{.arg x} and {.arg y} must have the same length") - } - - dx <- resolution(x, FALSE) - dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15 - - hexC <- hexbin::hexcoords(dx, dy, n = 1) - - n <- length(x) - - polygonGrob( - x = rep.int(hexC$x, n) * rep(size, each = 6) + rep(x, each = 6), - y = rep.int(hexC$y, n) * rep(size, each = 6) + rep(y, each = 6), - default.units = "native", - id.lengths = rep(6, n), gp = gp - ) -} diff --git a/R/geom-histogram.R b/R/geom-histogram.R index dafc181f15..7bd832b611 100644 --- a/R/geom-histogram.R +++ b/R/geom-histogram.R @@ -17,6 +17,12 @@ #' one change at a time. You may need to look at a few options to uncover #' the full story behind your data. #' +#' By default, the _height_ of the bars represent the counts within each bin. +#' However, there are situations where this behavior might produce misleading +#' plots (e.g., when non-equal-width bins are used), in which case it might be +#' preferable to have the _area_ of the bars represent the counts (by setting +#' `aes(y = after_stat(count / width))`). See example below. +#' #' In addition to `geom_histogram()`, you can create a histogram plot by using #' `scale_x_binned()` with [geom_bar()]. This method by default plots tick marks #' in between each bar. @@ -63,6 +69,18 @@ #' ggplot(diamonds, aes(price, after_stat(density), colour = cut)) + #' geom_freqpoly(binwidth = 500) #' +#' +#' # When using the non-equal-width bins, we should set the area of the bars to +#' # represent the counts (not the height). +#' # Here we're using 10 equi-probable bins: +#' price_bins <- quantile(diamonds$price, probs = seq(0, 1, length = 11)) +#' +#' ggplot(diamonds, aes(price)) + +#' geom_histogram(breaks = price_bins, color = "black") # misleading (height = count) +#' +#' ggplot(diamonds, aes(price, after_stat(count / width))) + +#' geom_histogram(breaks = price_bins, color = "black") # area = count +#' #' if (require("ggplot2movies")) { #' # Often we don't want the height of the bar to represent the #' # count of observations, but the sum of some other variable. diff --git a/R/geom-hline.R b/R/geom-hline.R index 924b41f40a..0ebf2436fc 100644 --- a/R/geom-hline.R +++ b/R/geom-hline.R @@ -4,6 +4,7 @@ NULL #' @export #' @rdname geom_abline geom_hline <- function(mapping = NULL, data = NULL, + position = "identity", ..., yintercept, na.rm = FALSE, @@ -29,7 +30,7 @@ geom_hline <- function(mapping = NULL, data = NULL, mapping = mapping, stat = StatIdentity, geom = GeomHline, - position = PositionIdentity, + position = position, show.legend = show.legend, inherit.aes = FALSE, params = list2( @@ -55,7 +56,12 @@ GeomHline <- ggproto("GeomHline", Geom, GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) }, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), required_aes = "yintercept", draw_key = draw_key_path, diff --git a/R/geom-label.R b/R/geom-label.R index c292fa1a66..a9d288996f 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -2,29 +2,34 @@ #' @rdname geom_text #' @param label.padding Amount of padding around label. Defaults to 0.25 lines. #' @param label.r Radius of rounded corners. Defaults to 0.15 lines. -#' @param label.size Size of label border, in mm. +#' @param label.size `r lifecycle::badge("deprecated")` Replaced by the +#' `linewidth` aesthetic. Size of label border, in mm. +#' @param border.colour,border.color Colour of label border. When `NULL` +#' (default), the `colour` aesthetic determines the colour of the label border. +#' `border.color` is an alias for `border.colour`. +#' @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 = "identity", + stat = "identity", position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, label.padding = unit(0.25, "lines"), label.r = unit(0.15, "lines"), - label.size = 0.25, + 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) { - if (!missing(nudge_x) || !missing(nudge_y)) { - if (!missing(position)) { - cli::cli_abort(c( - "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.", - "i" = "Choose one approach to alter the position." - )) - } - position <- position_nudge(nudge_x, nudge_y) + extra_args <- list2(...) + if (lifecycle::is_present(label.size)) { + deprecate_warn0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)") + extra_args$linewidth <- extra_args$linewidth %||% label.size } layer( @@ -39,10 +44,11 @@ geom_label <- function(mapping = NULL, data = NULL, parse = parse, label.padding = label.padding, label.r = label.r, - label.size = label.size, size.unit = size.unit, + border.colour = border.color %||% border.colour, + text.colour = text.color %||% text.colour, na.rm = na.rm, - ... + !!!extra_args ) ) } @@ -56,16 +62,23 @@ GeomLabel <- ggproto("GeomLabel", Geom, required_aes = c("x", "y", "label"), default_aes = aes( - colour = "black", fill = "white", size = 3.88, angle = 0, - hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1, - lineheight = 1.2 + colour = from_theme(colour %||% ink), + fill = from_theme(fill %||% paper), + family = from_theme(family), + size = from_theme(fontsize), + angle = 0, + hjust = 0.5, vjust = 0.5, alpha = NA, fontface = 1, + lineheight = 1.2, + linewidth = from_theme(borderwidth * 0.5), + 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"), - label.size = 0.25, + border.colour = NULL, + text.colour = NULL, size.unit = "mm") { lab <- data$label if (parse) { @@ -75,13 +88,19 @@ GeomLabel <- ggproto("GeomLabel", Geom, data <- coord$transform(data, panel_params) data$vjust <- compute_just(data$vjust, data$y, data$x, data$angle) data$hjust <- compute_just(data$hjust, data$x, data$y, data$angle) - if (!inherits(label.padding, "margin")) { + if (!is_margin("margin")) { label.padding <- rep(label.padding, length.out = 4) } size.unit <- resolve_text_unit(size.unit) + 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(1:nrow(data), function(i) { + grobs <- lapply(seq_len(nrow(data)), function(i) { row <- data[i, , drop = FALSE] labelGrob(lab[i], x = unit(row$x, "native"), @@ -90,17 +109,18 @@ GeomLabel <- ggproto("GeomLabel", Geom, padding = label.padding, r = label.r, angle = row$angle, - text.gp = gpar( - col = row$colour, - fontsize = row$size * size.unit, + text.gp = gg_par( + col = row$text.colour, + fontsize = row$size, fontfamily = row$family, fontface = row$fontface, lineheight = row$lineheight ), - rect.gp = gpar( - col = if (isTRUE(all.equal(label.size, 0))) NA else row$colour, - fill = fill_alpha(row$fill, row$alpha), - lwd = label.size * .pt + rect.gp = gg_par( + col = row$border.colour, + fill = row$fill, + lwd = row$linewidth, + lty = row$linetype ) ) }) @@ -115,7 +135,7 @@ GeomLabel <- ggproto("GeomLabel", Geom, 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 = gpar(fill = "white"), vp = 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.") @@ -130,7 +150,7 @@ labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), vp <- viewport( angle = angle, x = x, y = y, width = unit(0, "cm"), height = unit(0, "cm"), - gp = gpar(fontsize = text.gp$fontsize) + gp = gg_par(fontsize = text.gp$fontsize) ) x <- unit(rep(0.5, length(x)), "npc") y <- unit(rep(0.5, length(y)), "npc") diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 7144d0084a..acaefbc9b2 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -6,13 +6,12 @@ #' @eval rd_orientation() #' #' @eval rd_aesthetics("geom", "linerange", "Note that `geom_pointrange()` also understands `size` for the size of the points.") -#' @param fatten A multiplicative factor used to increase the size of the -#' middle bar in `geom_crossbar()` and the middle point in -#' `geom_pointrange()`. +#' @param fatten `r lifecycle::badge("deprecated")` A multiplicative factor +#' used to increase the size of the middle bar in `geom_crossbar()` and the +#' middle point in `geom_pointrange()`. #' @seealso #' [stat_summary()] for examples of these guys in use, -#' [geom_smooth()] for continuous analogue, -#' [geom_errorbarh()] for a horizontal error bar. +#' [geom_smooth()] for continuous analogue #' @export #' @inheritParams layer #' @inheritParams geom_bar @@ -91,7 +90,8 @@ geom_linerange <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomLinerange <- ggproto("GeomLinerange", Geom, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + + default_aes = GeomPath$default_aes, draw_key = draw_key_linerange, diff --git a/R/geom-map.R b/R/geom-map.R index 01024ebeff..0632ba36ee 100644 --- a/R/geom-map.R +++ b/R/geom-map.R @@ -22,7 +22,7 @@ NULL #' # how `geom_map()` works. It requires two data frames: #' # One contains the coordinates of each polygon (`positions`), and is #' # provided via the `map` argument. The other contains the -#' # other the values associated with each polygon (`values`). An id +#' # values associated with each polygon (`values`). An id #' # variable links the two together. #' #' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3")) @@ -144,10 +144,10 @@ GeomMap <- ggproto("GeomMap", GeomPolygon, data <- data[data_rows, , drop = FALSE] polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id, - gp = gpar( + gp = gg_par( col = data$colour, fill = fill_alpha(data$fill, data$alpha), - lwd = data$linewidth * .pt, + lwd = data$linewidth, lineend = lineend, linejoin = linejoin, linemitre = linemitre diff --git a/R/geom-path.R b/R/geom-path.R index ad7589a028..fe930363a6 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -18,6 +18,8 @@ #' @param linejoin Line join style (round, mitre, bevel). #' @param linemitre Line mitre limit (number greater than 1). #' @param arrow Arrow specification, as created by [grid::arrow()]. +#' @param arrow.fill fill colour to use for the arrow head (if closed). `NULL` +#' means use `colour` aesthetic. #' @seealso #' [geom_polygon()]: Filled paths (polygons); #' [geom_segment()]: Line segments @@ -34,8 +36,9 @@ #' @examples #' # geom_line() is suitable for time series #' ggplot(economics, aes(date, unemploy)) + geom_line() +#' # separate by colour and use "timeseries" legend key glyph #' ggplot(economics_long, aes(date, value01, colour = variable)) + -#' geom_line() +#' geom_line(key_glyph = "timeseries") #' #' # You can get a timeseries that run vertically by setting the orientation #' ggplot(economics, aes(unemploy, date)) + geom_line(orientation = "y") @@ -101,6 +104,7 @@ geom_path <- function(mapping = NULL, data = NULL, linejoin = "round", linemitre = 10, arrow = NULL, + arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) { @@ -117,6 +121,7 @@ geom_path <- function(mapping = NULL, data = NULL, linejoin = linejoin, linemitre = linemitre, arrow = arrow, + arrow.fill = arrow.fill, na.rm = na.rm, ... ) @@ -130,7 +135,12 @@ geom_path <- function(mapping = NULL, data = NULL, GeomPath <- ggproto("GeomPath", Geom, required_aes = c("x", "y"), - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + default_aes = aes( + colour = from_theme(ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), non_missing_aes = c("linewidth", "colour", "linetype"), @@ -152,10 +162,10 @@ GeomPath <- ggproto("GeomPath", Geom, data }, - draw_panel = function(self, data, panel_params, coord, arrow = NULL, + draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = FALSE) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (!anyDuplicated(data$group)) { cli::cli_inform(c( "{.fn {snake_class(self)}}: Each group consists of only one observation.", @@ -176,7 +186,7 @@ GeomPath <- ggproto("GeomPath", Geom, attr <- dapply(munched, "group", function(df) { linetype <- unique0(df$linetype) data_frame0( - solid = identical(linetype, 1) || identical(linetype, "solid"), + solid = length(linetype) == 1 && (identical(linetype, "solid") || linetype == 1), constant = nrow(unique0(df[, names(df) %in% c("alpha", "colour", "linewidth", "linetype")])) == 1, .size = 1 ) @@ -193,6 +203,8 @@ GeomPath <- ggproto("GeomPath", Geom, start <- c(TRUE, group_diff) end <- c(group_diff, TRUE) + munched$fill <- arrow.fill %||% munched$colour + if (!constant) { arrow <- repair_segment_arrow(arrow, munched$group) @@ -200,10 +212,10 @@ GeomPath <- ggproto("GeomPath", Geom, segmentsGrob( munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start], default.units = "native", arrow = arrow, - gp = gpar( + gp = gg_par( col = alpha(munched$colour, munched$alpha)[!end], - fill = alpha(munched$colour, munched$alpha)[!end], - lwd = munched$linewidth[!end] * .pt, + fill = alpha(munched$fill, munched$alpha)[!end], + lwd = munched$linewidth[!end], lty = munched$linetype[!end], lineend = lineend, linejoin = linejoin, @@ -215,10 +227,10 @@ GeomPath <- ggproto("GeomPath", Geom, polylineGrob( munched$x, munched$y, id = id, default.units = "native", arrow = arrow, - gp = gpar( + gp = gg_par( col = alpha(munched$colour, munched$alpha)[start], - fill = alpha(munched$colour, munched$alpha)[start], - lwd = munched$linewidth[start] * .pt, + fill = alpha(munched$fill, munched$alpha)[start], + lwd = munched$linewidth[start], lty = munched$linetype[start], lineend = lineend, linejoin = linejoin, @@ -299,7 +311,8 @@ GeomLine <- ggproto("GeomLine", GeomPath, #' @rdname geom_path geom_step <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", direction = "hv", - na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) { + na.rm = FALSE, orientation = NA, show.legend = NA, + inherit.aes = TRUE, ...) { layer( data = data, mapping = mapping, @@ -310,6 +323,7 @@ geom_step <- function(mapping = NULL, data = NULL, stat = "identity", inherit.aes = inherit.aes, params = list2( direction = direction, + orientation = orientation, na.rm = na.rm, ... ) @@ -322,13 +336,25 @@ geom_step <- function(mapping = NULL, data = NULL, stat = "identity", #' @export #' @include geom-path.R GeomStep <- ggproto("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, - direction = "hv") { + 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) + } 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 + lineend = lineend, linejoin = linejoin, linemitre = linemitre, + arrow = arrow, arrow.fill = arrow.fill ) } ) diff --git a/R/geom-point.R b/R/geom-point.R index 20a7f46b58..a46a3a3245 100644 --- a/R/geom-point.R +++ b/R/geom-point.R @@ -27,7 +27,7 @@ #' `geom_point(alpha = 0.05)`) or very small (e.g. #' `geom_point(shape = ".")`). #' -#' @eval rd_aesthetics("geom", "point") +#' @eval rd_aesthetics("geom", "point", "The `fill` aesthetic only applies to shapes 21-25.") #' @inheritParams layer #' @param na.rm If `FALSE`, the default, missing values are removed with #' a warning. If `TRUE`, missing values are silently removed. @@ -85,6 +85,13 @@ #' ggplot(mtcars, aes(wt, mpg)) + #' geom_point(shape = 21, colour = "black", fill = "white", size = 5, stroke = 5) #' +#' # The default shape in legends is not filled, but you can override the shape +#' # in the guide to reflect the fill in the legend +#' ggplot(mtcars, aes(wt, mpg, fill = factor(carb), shape = factor(cyl))) + +#' geom_point(size = 5, stroke = 1) + +#' scale_shape_manual(values = 21:25) + +#' scale_fill_ordinal(guide = guide_legend(override.aes = list(shape = 21))) +#' #' \donttest{ #' # You can create interesting shapes by layering multiple points of #' # different sizes @@ -135,28 +142,26 @@ GeomPoint <- ggproto("GeomPoint", Geom, required_aes = c("x", "y"), non_missing_aes = c("size", "shape", "colour"), default_aes = aes( - shape = 19, colour = "black", size = 1.5, fill = NA, - alpha = NA, stroke = 0.5 + shape = from_theme(pointshape), + colour = from_theme(colour %||% ink), + fill = from_theme(fill %||% NA), + size = from_theme(pointsize), + alpha = NA, + stroke = from_theme(borderwidth) ), draw_panel = function(self, data, panel_params, coord, na.rm = FALSE) { - if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } - + data$shape <- translate_shape_string(data$shape) coords <- coord$transform(data, panel_params) - stroke_size <- coords$stroke - stroke_size[is.na(stroke_size)] <- 0 ggname("geom_point", pointsGrob( coords$x, coords$y, pch = coords$shape, - gp = gpar( + gp = gg_par( col = alpha(coords$colour, coords$alpha), fill = fill_alpha(coords$fill, coords$alpha), - # Stroke is added around the outside of the point - fontsize = coords$size * .pt + stroke_size * .stroke / 2, - lwd = coords$stroke * .stroke / 2 + pointsize = coords$size, + stroke = coords$stroke ) ) ) @@ -171,7 +176,8 @@ GeomPoint <- ggproto("GeomPoint", Geom, #' given as a character vector into integers that are interpreted by the #' grid system. #' -#' @param shape_string A character vector giving point shapes. +#' @param shape_string A character vector giving point shapes. Non-character +#' input will be returned. #' #' @return An integer vector with translated shapes. #' @export @@ -183,6 +189,9 @@ GeomPoint <- ggproto("GeomPoint", Geom, #' # Strings with 1 or less characters are interpreted as symbols #' translate_shape_string(c("a", "b", "?")) translate_shape_string <- function(shape_string) { + if (!is.character(shape_string)) { + return(shape_string) + } # strings of length 0 or 1 are interpreted as symbols by grid if (nchar(shape_string[1]) <= 1) { return(shape_string) diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index ccecfc0d95..0ffa1bf51f 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -3,7 +3,7 @@ geom_pointrange <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., - fatten = 4, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -30,14 +30,24 @@ geom_pointrange <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomPointrange <- ggproto("GeomPointrange", Geom, - default_aes = aes(colour = "black", size = 0.5, linewidth = 0.5, linetype = 1, - shape = 19, fill = NA, alpha = NA, stroke = 1), + 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, + stroke = from_theme(borderwidth * 2) + ), draw_key = draw_key_pointrange, required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"), setup_params = function(data, params) { + if (lifecycle::is_present(params$fatten %||% deprecated())) { + deprecate_soft0("3.6.0", "geom_pointrange(fatten)", I("the `size` aesthetic")) + } else { + # For backward compatibility reasons + params$fatten <- 4 + } GeomLinerange$setup_params(data, params) }, diff --git a/R/geom-polygon.R b/R/geom-polygon.R index c644d9daad..8ffdd05e58 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -109,7 +109,7 @@ geom_polygon <- function(mapping = NULL, data = NULL, GeomPolygon <- ggproto("GeomPolygon", Geom, draw_panel = function(self, data, panel_params, coord, rule = "evenodd", lineend = "butt", linejoin = "round", linemitre = 10) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) n <- nrow(data) if (n == 1) return(zeroGrob()) @@ -130,10 +130,10 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, polygonGrob( munched$x, munched$y, default.units = "native", id = munched$group, - gp = gpar( + gp = gg_par( col = first_rows$colour, fill = fill_alpha(first_rows$fill, first_rows$alpha), - lwd = first_rows$linewidth * .pt, + lwd = first_rows$linewidth, lty = first_rows$linetype, lineend = lineend, linejoin = linejoin, @@ -161,10 +161,10 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, munched$x, munched$y, default.units = "native", id = id, pathId = munched$group, rule = rule, - gp = gpar( + gp = gg_par( col = first_rows$colour, fill = fill_alpha(first_rows$fill, first_rows$alpha), - lwd = first_rows$linewidth * .pt, + lwd = first_rows$linewidth, lty = first_rows$linetype, lineend = lineend, linejoin = linejoin, @@ -175,8 +175,13 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, } }, - default_aes = aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, - alpha = NA, subgroup = NULL), + default_aes = aes( + colour = from_theme(colour %||% NA), + fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), + alpha = NA, subgroup = NULL + ), handle_na = function(data, params) { data diff --git a/R/geom-quantile.R b/R/geom-quantile.R index bb3ff581ab..ecdf7f69fb 100644 --- a/R/geom-quantile.R +++ b/R/geom-quantile.R @@ -65,8 +65,8 @@ geom_quantile <- function(mapping = NULL, data = NULL, #' @export #' @include geom-path.R GeomQuantile <- ggproto("GeomQuantile", GeomPath, - default_aes = defaults( - aes(weight = 1, colour = "#3366FF", linewidth = 0.5), + default_aes = aes(!!!defaults( + aes(weight = 1, colour = from_theme(colour %||% accent)), GeomPath$default_aes - ) + )) ) diff --git a/R/geom-raster.R b/R/geom-raster.R index 2cd591d879..819692cea5 100644 --- a/R/geom-raster.R +++ b/R/geom-raster.R @@ -44,7 +44,10 @@ geom_raster <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomRaster <- ggproto("GeomRaster", Geom, - default_aes = aes(fill = "grey20", alpha = NA), + default_aes = aes( + fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), + alpha = NA + ), non_missing_aes = c("fill", "xmin", "xmax", "ymin", "ymax"), required_aes = c("x", "y"), @@ -88,9 +91,14 @@ GeomRaster <- ggproto("GeomRaster", Geom, draw_panel = function(self, data, panel_params, coord, interpolate = FALSE, hjust = 0.5, vjust = 0.5) { if (!inherits(coord, "CoordCartesian")) { - cli::cli_abort(c( - "{.fn {snake_class(self)}} only works with {.fn coord_cartesian}." + cli::cli_inform(c( + "{.fn {snake_class(self)}} only works with {.fn coord_cartesian}.", + i = "Falling back to drawing as {.fn {snake_class(GeomRect)}}." )) + data$linewidth <- 0.3 # preventing anti-aliasing artefacts + data$colour <- data$fill + grob <- GeomRect$draw_panel(data, panel_params, coord) + return(grob) } # Convert vector of data to raster @@ -119,5 +127,5 @@ GeomRaster <- ggproto("GeomRaster", Geom, default.units = "native", interpolate = interpolate ) }, - draw_key = draw_key_rect + draw_key = draw_key_polygon ) diff --git a/R/geom-rect.R b/R/geom-rect.R index d39978897a..9799f82cf2 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -28,13 +28,49 @@ geom_rect <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomRect <- ggproto("GeomRect", Geom, - default_aes = aes(colour = NA, fill = "grey35", linewidth = 0.5, linetype = 1, - alpha = NA), + 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), + alpha = NA + ), - required_aes = c("xmin", "xmax", "ymin", "ymax"), + required_aes = c("x|width|xmin|xmax", "y|height|ymin|ymax"), + + setup_data = function(self, data, params) { + if (all(c("xmin", "xmax", "ymin", "ymax") %in% names(data))) { + return(data) + } + + # Fill in missing aesthetics from parameters + required <- strsplit(self$required_aes, "|", fixed = TRUE) + 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" + ) + 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" + ) + i <- lengths(y) > 1 + data[c("ymin", "ymax")[i]] <- y[i] + } + data + }, draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (!coord$is_linear()) { aesthetics <- setdiff( names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax") @@ -57,10 +93,10 @@ GeomRect <- ggproto("GeomRect", Geom, height = coords$ymax - coords$ymin, default.units = "native", just = c("left", "top"), - gp = gpar( + gp = gg_par( col = coords$colour, fill = fill_alpha(coords$fill, coords$alpha), - lwd = coords$linewidth * .pt, + lwd = coords$linewidth, lty = coords$linetype, linejoin = linejoin, lineend = lineend @@ -73,3 +109,41 @@ GeomRect <- ggproto("GeomRect", Geom, rename_size = TRUE ) + +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( + type, + x = c("xmin", "xmax", "x", "width"), + y = c("ymin", "ymax", "y", "height") + ) + cli::cli_abort(c( + "{.fn {fun}} requires two of the following aesthetics: \\ + {.or {.field {missing}}}.", + i = "Currently, {.field {missing[!absent]}} is present." + )) + } + + if (absent[1] && absent[2]) { + min <- center - 0.5 * length + max <- center + 0.5 * length + return(list(min = min, max = max)) + } + if (absent[1]) { + if (is.null(center)) { + min <- max - length + } else { + min <- max - 2 * (max - center) + } + } + if (absent[2]) { + if (is.null(center)) { + max <- min + length + } else { + max <- min + 2 * (center - min) + } + } + list(min = min, max = max) +} diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index d93df77850..20e01d36c4 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -96,8 +96,14 @@ geom_ribbon <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export GeomRibbon <- ggproto("GeomRibbon", Geom, - default_aes = aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, - alpha = NA), + + default_aes = aes( + colour = from_theme(colour %||% NA), + fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), + alpha = NA + ), required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), @@ -122,24 +128,80 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, draw_key = draw_key_polygon, - handle_na = function(data, params) { + handle_na = function(self, data, params) { + + vars <- vapply( + strsplit(self$required_aes, "|", fixed = TRUE), + `[[`, i = 1, character(1) + ) + if (isTRUE(params$flipped_aes || any(data$flipped_aes) %||% FALSE)) { + vars <- switch_orientation(vars) + } + vars <- c(vars, self$non_missing_aes) + + missing <- detect_missing(data, vars, finite = FALSE) + if (!any(missing)) { + return(data) + } + # We're rearranging groups to account for missing values + data$group <- vec_identify_runs(data_frame0(missing, data$group)) + data <- vec_slice(data, !missing) + + if (!params$na.rm) { + cli::cli_warn( + "Removed {sum(missing)} row{?s} containing missing values or values \\ + outside the scale range ({.fn {snake_class(self)}})." + ) + } data }, draw_group = function(self, data, panel_params, coord, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) - if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ] data <- data[order(data$group), ] # Check that aesthetics are constant - aes <- unique0(data[names(data) %in% c("colour", "fill", "linewidth", "linetype", "alpha")]) - if (nrow(aes) > 1) { - cli::cli_abort("Aesthetics can not vary along a ribbon.") + aes <- lapply( + data[names(data) %in% c("colour", "fill", "linewidth", "linetype", "alpha")], + unique0 + ) + non_constant <- names(aes)[lengths(aes) > 1] + if (coord$is_linear()) { + if (any(c("fill", "alpha") %in% non_constant)) { + check_device("gradients", action = "abort", maybe = TRUE) + } + # For linear coords, we can make a fill/alpha gradient, so we allow + # these to vary + non_constant <- setdiff(non_constant, c("fill", "alpha")) + } + if (length(non_constant) > 0) { + cli::cli_abort( + "Aesthetics can not vary along a ribbon: {.and {.field {non_constant}}}." + ) + } + if ((length(aes$fill) > 1 || length(aes$alpha) > 1)) { + transformed <- coord$transform(flip_data(data, flipped_aes), panel_params) + if (flipped_aes) { + keep <- is.finite(transformed$y) + args <- list( + colours = alpha(data$fill, data$alpha)[keep], + stops = rescale(transformed$y)[keep], + 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 + ) + } + aes$fill <- inject(linearGradient(!!!args)) + aes$alpha <- NA } - aes <- as.list(aes) # Instead of removing NA values from the data and plotting a single # polygon, we want to "stop" plotting the polygon whenever we're @@ -182,10 +244,10 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, g_poly <- polygonGrob( munched_poly$x, munched_poly$y, id = munched_poly$id, default.units = "native", - gp = gpar( + gp = gg_par( fill = fill_alpha(aes$fill, aes$alpha), col = if (is_full_outline) aes$colour else NA, - lwd = if (is_full_outline) aes$linewidth * .pt else 0, + lwd = if (is_full_outline) aes$linewidth else 0, lty = if (is_full_outline) aes$linetype else 1, lineend = lineend, linejoin = linejoin, @@ -213,9 +275,9 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, g_lines <- polylineGrob( munched_lines$x, munched_lines$y, id = munched_lines$id, default.units = "native", - gp = gpar( + gp = gg_par( col = aes$colour, - lwd = aes$linewidth * .pt, + lwd = aes$linewidth, lty = aes$linetype, lineend = lineend, linejoin = linejoin, @@ -259,8 +321,6 @@ geom_area <- function(mapping = NULL, data = NULL, stat = "align", #' @usage NULL #' @export GeomArea <- ggproto("GeomArea", GeomRibbon, - default_aes = aes(colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, - alpha = NA), required_aes = c("x", "y"), diff --git a/R/geom-rug.R b/R/geom-rug.R index 0fe393bb95..bcc7adca7a 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -45,7 +45,7 @@ #' p + #' geom_rug(outside = TRUE, sides = "tr") + #' coord_cartesian(clip = "off") + -#' theme(plot.margin = margin(1, 1, 1, 1, "cm")) +#' theme(plot.margin = margin_auto(1, unit = "cm")) #' #' # increase the line length and #' # expand axis to avoid overplotting @@ -90,7 +90,7 @@ GeomRug <- ggproto("GeomRug", Geom, draw_panel = function(self, data, panel_params, coord, lineend = "butt", sides = "bl", outside = FALSE, length = unit(0.03, "npc")) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) check_inherits(length, "unit") rugs <- list() data <- coord$transform(data, panel_params) @@ -108,10 +108,10 @@ GeomRug <- ggproto("GeomRug", Geom, list(min = -1 * length, max = unit(1, "npc") + length) } - gp <- gpar( + gp <- gg_par( col = alpha(data$colour, data$alpha), lty = data$linetype, - lwd = data$linewidth * .pt, + lwd = data$linewidth, lineend = lineend ) if (!is.null(data$x)) { @@ -153,9 +153,53 @@ GeomRug <- ggproto("GeomRug", Geom, gTree(children = inject(gList(!!!rugs))) }, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + default_aes = GeomPath$default_aes, draw_key = draw_key_path, - rename_size = TRUE + rename_size = TRUE, + + setup_params = function(data, params) { + params$sides <- params$sides %||% "bl" + params + }, + + handle_na = function(self, data, params) { + sides_aes <- character() + + if (grepl("b|t", params$sides)) { + sides_aes <- c(sides_aes, "x") + } + + if (grepl("l|r", params$sides)) { + sides_aes <- c(sides_aes, "y") + } + + if (length(sides_aes) > 0) { + df_list <- lapply( + sides_aes, + function(axis) { + remove_missing( + data, params$na.rm, + c(axis, self$required_aes, self$non_missing_aes), + snake_class(self) + ) + } + ) + data <- switch( + paste0(sides_aes, collapse = ""), + "x" = , + "y" = df_list[[1]], + "xy" = vctrs::vec_set_union(df_list[[1]], df_list[[2]]) + ) + } else { + data <- remove_missing( + data, params$na.rm, + c(self$required_aes, self$non_missing_aes), + snake_class(self) + ) + } + + data + } ) diff --git a/R/geom-segment.R b/R/geom-segment.R index f32b61f876..fb00f0481d 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -104,12 +104,14 @@ geom_segment <- function(mapping = NULL, data = NULL, GeomSegment <- ggproto("GeomSegment", Geom, required_aes = c("x", "y", "xend|yend"), non_missing_aes = c("linetype", "linewidth"), - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + + 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) { data$xend <- data$xend %||% data$x data$yend <- data$yend %||% data$y - data <- check_linewidth(data, snake_class(self)) + 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" @@ -122,10 +124,10 @@ GeomSegment <- ggproto("GeomSegment", Geom, arrow.fill <- arrow.fill %||% coord$colour return(segmentsGrob(coord$x, coord$y, coord$xend, coord$yend, default.units = "native", - gp = gpar( + gp = gg_par( col = alpha(coord$colour, coord$alpha), fill = alpha(arrow.fill, coord$alpha), - lwd = coord$linewidth * .pt, + lwd = coord$linewidth, lty = coord$linetype, lineend = lineend, linejoin = linejoin @@ -134,7 +136,7 @@ GeomSegment <- ggproto("GeomSegment", Geom, )) } - data$group <- 1:nrow(data) + 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")) diff --git a/R/geom-sf.R b/R/geom-sf.R index a8f70d7f4e..448329dd79 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -126,105 +126,162 @@ GeomSf <- ggproto("GeomSf", Geom, fill = NULL, size = NULL, linewidth = NULL, - linetype = 1, + linetype = from_theme(linetype), alpha = NA, stroke = 0.5 ), + 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, ... + ) + # Early exit for e.g. legend data that don't have geometry columns + if (!"geometry" %in% names(data)) { + return(data) + } + + # geometry column is a character if we're populating legend keys + type <- if (is.character(data$geometry)) { + data$geometry + } else { + sf_types[sf::st_geometry_type(data$geometry)] + } + + # Devise splitting index for geometry types + type <- factor(type, c("point", "line", "other", "collection")) + index <- split(seq_len(nrow(data)), type) + + # Initialise parts of the data + points <- lines <- others <- collections <- NULL + + # Go through every part, applying different defaults + if (length(index$point) > 0) { + points <- GeomPoint$use_defaults( + vec_slice(data, index$point), + params, modifiers, theme = theme + ) + } + if (length(index$line) > 0) { + lines <- GeomLine$use_defaults( + vec_slice(data, index$line), + params, modifiers, theme = theme + ) + } + other_default <- modify_list( + GeomPolygon$default_aes, + aes( + fill = from_theme(fill %||% col_mix(ink, paper, 0.9)), + colour = from_theme(colour %||% col_mix(ink, paper, 0.35)), + linewidth = from_theme(0.4 * borderwidth) + ) + ) + if (length(index$other) > 0) { + others <- GeomPolygon$use_defaults( + vec_slice(data, index$other), + params, modifiers, + default_aes = other_default, + theme = theme + ) + } + if (length(index$collection) > 0) { + modified <- rename( + GeomPoint$default_aes, + c(fill = "point_fill") + ) + modified <- modify_list(other_default, modified) + collections <- Geom$use_defaults( + vec_slice(data, index$collection), + params, modifiers, + default_aes = modified, + theme = theme + ) + } + + # Recombine data in original order + data <- vec_c(points, lines, others, collections) + vec_slice(data, order(unlist(index))) + }, + draw_panel = function(self, data, panel_params, coord, legend = NULL, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, na.rm = TRUE) { + 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}.") } + data$shape <- translate_shape_string(data$shape) + + data <- coord$transform(data, panel_params) + + type <- sf_types[sf::st_geometry_type(data$geometry)] + is_point <- type == "point" + is_line <- type == "line" + is_collection <- type == "collection" + + fill <- fill_alpha(data$fill %||% rep(NA, nrow(data)), data$alpha) + fill[is_line] <- arrow.fill %||% fill[is_line] + + colour <- data$colour + colour[is_point | is_line] <- + alpha(colour[is_point | is_line], data$alpha[is_point | is_line]) + + point_size <- data$size + point_size[!(is_point | is_collection)] <- + data$linewidth[!(is_point | is_collection)] + + stroke <- (data$stroke %||% rep(0.5, nrow(data))) * .stroke / 2 + font_size <- point_size * .pt + stroke - # Need to refactor this to generate one grob per geometry type - coord <- coord$transform(data, panel_params) - sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre, - arrow = arrow, na.rm = na.rm) + linewidth <- data$linewidth * .pt + 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 + ) + + sf::st_as_grob(data$geometry, pch = data$shape, gp = gp, arrow = arrow) }, draw_key = function(data, params, size) { - data <- modify_list(default_aesthetics(params$legend), data) - if (params$legend == "point") { - draw_key_point(data, params, size) - } else if (params$legend == "line") { - draw_key_path(data, params, size) - } else { + switch( + params$legend %||% "other", + point = draw_key_point(data, params, size), + line = draw_key_path(data, params, size), draw_key_polygon(data, params, size) + ) + }, + + handle_na = function(self, data, params) { + remove <- rep(FALSE, nrow(data)) + + types <- sf_types[sf::st_geometry_type(data$geometry)] + types <- split(seq_along(remove), types) + + get_missing <- function(geom) { + detect_missing(data, c(geom$required_aes, geom$non_missing_aes)) } - } -) -default_aesthetics <- function(type) { - if (type == "point") { - GeomPoint$default_aes - } else if (type == "line") { - GeomLine$default_aes - } else { - modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35")) - } -} + remove[types$point] <- get_missing(GeomPoint)[types$point] + remove[types$line] <- get_missing(GeomPath)[types$line] + remove[types$other] <- get_missing(GeomPolygon)[types$other] + + remove <- remove | get_missing(self) -sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10, - arrow = NULL, na.rm = TRUE) { - type <- sf_types[sf::st_geometry_type(x$geometry)] - is_point <- type == "point" - is_line <- type == "line" - is_other <- type == "other" - is_collection <- type == "collection" - type_ind <- match(type, c("point", "line", "other", "collection")) - remove <- rep_len(FALSE, nrow(x)) - remove[is_point] <- detect_missing(x, c(GeomPoint$required_aes, GeomPoint$non_missing_aes))[is_point] - remove[is_line] <- detect_missing(x, c(GeomPath$required_aes, GeomPath$non_missing_aes))[is_line] - remove[is_other] <- detect_missing(x, c(GeomPolygon$required_aes, GeomPolygon$non_missing_aes))[is_other] - if (any(remove)) { - if (!na.rm) { - cli::cli_warn(paste0( - "Removed {sum(remove)} row{?s} containing missing values or values ", - "outside the scale range ({.fn geom_sf})." - )) + if (any(remove)) { + data <- vec_slice(data, !remove) + if (!isTRUE(params$na.rm)) { + cli::cli_warn( + "Removed {sum(remove)} row{?s} containing missing values or values \\ + outside the scale range ({.fn {snake_class(self)}})." + ) + } } - x <- x[!remove, , drop = FALSE] - type_ind <- type_ind[!remove] - is_collection <- is_collection[!remove] + + data } - defaults <- list( - GeomPoint$default_aes, - GeomLine$default_aes, - modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35", linewidth = 0.2)) - ) - defaults[[4]] <- modify_list( - defaults[[3]], - rename(GeomPoint$default_aes, c(size = "point_size", fill = "point_fill")) - ) - default_names <- unique0(unlist(lapply(defaults, names))) - defaults <- lapply(setNames(default_names, default_names), function(n) { - unlist(lapply(defaults, function(def) def[[n]] %||% NA)) - }) - alpha <- x$alpha %||% defaults$alpha[type_ind] - col <- x$colour %||% defaults$colour[type_ind] - col[is_point | is_line] <- alpha(col[is_point | is_line], alpha[is_point | is_line]) - fill <- x$fill %||% defaults$fill[type_ind] - fill <- fill_alpha(fill, alpha) - size <- x$size %||% defaults$size[type_ind] - linewidth <- x$linewidth %||% defaults$linewidth[type_ind] - point_size <- ifelse( - is_collection, - x$size %||% defaults$point_size[type_ind], - ifelse(is_point, size, linewidth) - ) - stroke <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2 - fontsize <- point_size * .pt + stroke - lwd <- ifelse(is_point, stroke, linewidth * .pt) - pch <- x$shape %||% defaults$shape[type_ind] - lty <- x$linetype %||% defaults$linetype[type_ind] - gp <- gpar( - col = col, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty, - lineend = lineend, linejoin = linejoin, linemitre = linemitre - ) - sf::st_as_grob(x$geometry, pch = pch, gp = gp, arrow = arrow) -} +) #' @export #' @rdname ggsf @@ -255,28 +312,25 @@ geom_sf <- function(mapping = aes(), data = NULL, stat = "sf", #' @inheritParams geom_label #' @inheritParams stat_sf_coordinates geom_sf_label <- function(mapping = aes(), data = NULL, - stat = "sf_coordinates", position = "identity", + stat = "sf_coordinates", position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, label.padding = unit(0.25, "lines"), label.r = unit(0.15, "lines"), - label.size = 0.25, + 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) { - if (!missing(nudge_x) || !missing(nudge_y)) { - if (!missing(position)) { - cli::cli_abort(c( - "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.", - "i" = "Only use one approach to alter the position." - )) - } - - position <- position_nudge(nudge_x, nudge_y) + extra_args <- list2(...) + if (lifecycle::is_present(label.size)) { + deprecate_warn0("3.5.0", "geom_label(label.size)", "geom_label(linewidth)") + extra_args$linewidth <- extra_args$linewidth %||% label.size } layer_sf( @@ -291,10 +345,11 @@ geom_sf_label <- function(mapping = aes(), data = NULL, parse = parse, label.padding = label.padding, label.r = label.r, - label.size = label.size, na.rm = na.rm, fun.geometry = fun.geometry, - ... + border.colour = border.color %||% border.colour, + text.colour = text.color %||% text.colour, + !!!extra_args ) ) } @@ -304,28 +359,15 @@ geom_sf_label <- function(mapping = aes(), data = NULL, #' @inheritParams geom_text #' @inheritParams stat_sf_coordinates geom_sf_text <- function(mapping = aes(), data = NULL, - stat = "sf_coordinates", position = "identity", + stat = "sf_coordinates", position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, fun.geometry = NULL) { - if (!missing(nudge_x) || !missing(nudge_y)) { - if (!missing(position)) { - cli::cli_abort(c( - "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.", - "i" = "Only use one approach to alter the position." - )) - } - - position <- position_nudge(nudge_x, nudge_y) - } - layer_sf( data = data, mapping = mapping, diff --git a/R/geom-smooth.R b/R/geom-smooth.R index 535b8965a8..c386504fa8 100644 --- a/R/geom-smooth.R +++ b/R/geom-smooth.R @@ -9,7 +9,7 @@ #' `predictdf()` generic and its methods. For most methods the standard #' error bounds are computed using the [predict()] method -- the #' exceptions are `loess()`, which uses a t-based approximation, and -#' `glm()`, where the normal confidence interval is constructed on the link +#' `glm()`, where the normal confidence band is constructed on the link #' scale and then back-transformed to the response scale. #' #' @eval rd_orientation() @@ -125,6 +125,13 @@ geom_smooth <- function(mapping = NULL, data = NULL, GeomSmooth <- ggproto("GeomSmooth", Geom, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE, ambiguous = TRUE) + params$se <- params$se %||% + if (params$flipped_aes) { + all(c("xmin", "xmax") %in% names(data)) + } else { + all(c("ymin", "ymax") %in% names(data)) + } + params }, @@ -146,8 +153,8 @@ GeomSmooth <- ggproto("GeomSmooth", Geom, ribbon <- transform(data, colour = NA) path <- transform(data, alpha = NA) - ymin = flipped_names(flipped_aes)$ymin - ymax = flipped_names(flipped_aes)$ymax + ymin <- flipped_names(flipped_aes)$ymin + ymax <- flipped_names(flipped_aes)$ymax has_ribbon <- se && !is.null(data[[ymax]]) && !is.null(data[[ymin]]) gList( @@ -161,8 +168,13 @@ GeomSmooth <- ggproto("GeomSmooth", Geom, required_aes = c("x", "y"), optional_aes = c("ymin", "ymax"), - default_aes = aes(colour = "#3366FF", fill = "grey60", linewidth = 1, - linetype = 1, weight = 1, alpha = 0.4), + default_aes = aes( + colour = from_theme(colour %||% accent), + fill = from_theme(fill %||% col_mix(ink, paper, 0.6)), + linewidth = from_theme(2 * linewidth), + linetype = from_theme(linetype), + weight = 1, alpha = 0.4 + ), rename_size = TRUE ) diff --git a/R/geom-spoke.R b/R/geom-spoke.R index 032267b765..9ffbe71144 100644 --- a/R/geom-spoke.R +++ b/R/geom-spoke.R @@ -47,8 +47,7 @@ geom_spoke <- function(mapping = NULL, data = NULL, #' @rdname geom_spoke #' @usage NULL stat_spoke <- function(...) { - deprecate_warn0("2.0.0", "stat_spoke()", "geom_spoke()") - geom_spoke(...) + lifecycle::deprecate_stop("2.0.0", "stat_spoke()", "geom_spoke()") } #' @rdname ggplot2-ggproto diff --git a/R/geom-text.R b/R/geom-text.R index acfbb0337a..7ea074fc60 100644 --- a/R/geom-text.R +++ b/R/geom-text.R @@ -31,8 +31,8 @@ #' #' @section Alignment: #' You can modify text alignment with the `vjust` and `hjust` -#' aesthetics. These can either be a number between 0 (right/bottom) and -#' 1 (top/left) or a character (`"left"`, `"middle"`, `"right"`, `"bottom"`, +#' aesthetics. These can either be a number between 0 (left/bottom) and +#' 1 (right/top) or a character (`"left"`, `"middle"`, `"right"`, `"bottom"`, #' `"center"`, `"top"`). There are two special alignments: `"inward"` and #' `"outward"`. Inward always aligns text towards the center, and outward #' aligns it away from the center. @@ -41,19 +41,6 @@ #' @inheritParams geom_point #' @param parse If `TRUE`, the labels will be parsed into expressions and #' displayed as described in `?plotmath`. -#' @param nudge_x,nudge_y Horizontal and vertical adjustment to nudge labels by. -#' Useful for offsetting text from points, particularly on discrete scales. -#' Cannot be jointly specified with `position`. -#' @param position A position adjustment to use on the data for this layer. -#' Cannot be jointy specified with `nudge_x` or `nudge_y`. This -#' can be used in various ways, including to prevent overplotting and -#' improving the display. The `position` argument accepts the following: -#' * The result of calling a position function, such as `position_jitter()`. -#' * A string nameing the position adjustment. To give the position as a -#' string, strip the function name of the `position_` prefix. For example, -#' to use `position_jitter()`, give the position as `"jitter"`. -#' * For more information and other ways to specify the position, see the -#' [layer position][layer_positions] documentation. #' @param check_overlap If `TRUE`, text that overlaps previous text in the #' same layer will not be plotted. `check_overlap` happens at draw time and in #' the order of the data. Therefore data should be arranged by the label @@ -95,13 +82,14 @@ #' # Add aesthetic mappings #' p + geom_text(aes(colour = factor(cyl))) #' p + geom_text(aes(colour = factor(cyl))) + -#' scale_colour_discrete(l = 40) +#' scale_colour_hue(l = 40) #' p + geom_label(aes(fill = factor(cyl)), colour = "white", fontface = "bold") #' -#' p + geom_text(aes(size = wt)) +#' # Scale size of text, and change legend key glyph from a to point +#' p + geom_text(aes(size = wt), key_glyph = "point") #' # Scale height of text, rather than sqrt(height) #' p + -#' geom_text(aes(size = wt)) + +#' geom_text(aes(size = wt), key_glyph = "point") + #' scale_radius(range = c(3,6)) #' #' # You can display expressions by setting parse = TRUE. The @@ -165,28 +153,15 @@ #' geom_text(aes(label = text), vjust = "inward", hjust = "inward") #' } geom_text <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", + stat = "identity", position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, size.unit = "mm", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) { - if (!missing(nudge_x) || !missing(nudge_y)) { - if (!missing(position)) { - cli::cli_abort(c( - "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.", - "i" = "Only use one approach to alter the position." - )) - } - - position <- position_nudge(nudge_x, nudge_y) - } - layer( data = data, mapping = mapping, @@ -215,8 +190,11 @@ GeomText <- ggproto("GeomText", Geom, non_missing_aes = "angle", default_aes = aes( - colour = "black", size = 3.88, angle = 0, hjust = 0.5, - vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2 + 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 ), draw_panel = function(data, panel_params, coord, parse = FALSE, @@ -239,7 +217,7 @@ GeomText <- ggproto("GeomText", Geom, data$x, data$y, default.units = "native", hjust = data$hjust, vjust = data$vjust, rot = data$angle, - gp = gpar( + gp = gg_par( col = alpha(data$colour, data$alpha), fontsize = data$size * size.unit, fontfamily = data$family, diff --git a/R/geom-tile.R b/R/geom-tile.R index 139d6f733e..fabf70a4a9 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -1,25 +1,26 @@ #' Rectangles #' #' `geom_rect()` and `geom_tile()` do the same thing, but are -#' parameterised differently: `geom_rect()` uses the locations of the four -#' corners (`xmin`, `xmax`, `ymin` and `ymax`), while -#' `geom_tile()` uses the center of the tile and its size (`x`, -#' `y`, `width`, `height`). `geom_raster()` is a high -#' performance special case for when all the tiles are the same size, and no -#' pattern fills are applied. +#' parameterised differently: `geom_tile()` uses the center of the tile and its +#' size (`x`, `y`, `width`, `height`), while `geom_rect()` can use those or the +#' locations of the corners (`xmin`, `xmax`, `ymin` and `ymax`). +#' `geom_raster()` is a high performance special case for when all the tiles +#' are the same size, and no pattern fills are applied. #' -#' @eval rd_aesthetics("geom", "tile", "Note that `geom_raster()` ignores `colour`.") +#' @eval rd_aesthetics( +#' "geom", "rect", +#' "`geom_tile()` understands only the `x`/`width` and `y`/`height` combinations. +#' Note that `geom_raster()` ignores `colour`." +#' ) #' @inheritParams layer #' @inheritParams geom_point #' @inheritParams geom_segment #' @export #' #' @details -#' `geom_rect()` and `geom_tile()`'s respond differently to scale -#' transformations due to their parameterisation. In `geom_rect()`, the scale -#' transformation is applied to the corners of the rectangles. In `geom_tile()`, -#' the transformation is applied only to the centres and its size is determined -#' after transformation. +#' Please note that the `width` and `height` aesthetics are not true position +#' aesthetics and therefore are not subject to scale transformation. It is +#' only after transformation that these aesthetics are applied. #' #' @examples #' # The most common use for rectangles is to draw a surface. You always want @@ -108,18 +109,33 @@ geom_tile <- function(mapping = NULL, data = NULL, GeomTile <- ggproto("GeomTile", GeomRect, extra_params = c("na.rm"), - setup_data = function(data, params) { - data$width <- data$width %||% params$width %||% resolution(data$x, FALSE, TRUE) - data$height <- data$height %||% params$height %||% resolution(data$y, FALSE, TRUE) + setup_data = function(self, data, params) { + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + panels = "by", target = "width", + zero = FALSE, discrete = TRUE + ) + data <- compute_data_size( + data, params$height, + default = self$default_aes$height, + 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 ) }, - default_aes = aes(fill = "grey20", colour = NA, linewidth = 0.1, linetype = 1, - alpha = NA, width = NA, height = NA), + default_aes = aes( + fill = from_theme(fill %||% col_mix(ink, paper, 0.2)), + colour = from_theme(colour %||% NA), + linewidth = from_theme(0.4 * borderwidth), + linetype = from_theme(bordertype), + alpha = NA, width = 1, height = 1 + ), required_aes = c("x", "y"), diff --git a/R/geom-violin.R b/R/geom-violin.R index 0ac6cd29df..24d8fd07d9 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -10,8 +10,6 @@ #' @eval rd_aesthetics("geom", "violin") #' @inheritParams layer #' @inheritParams geom_bar -#' @param draw_quantiles If `not(NULL)` (default), draw horizontal lines -#' at the given quantiles of the density estimate. #' @param trim If `TRUE` (default), trim the tails of the violins #' to the range of the data. If `FALSE`, don't trim the tails. #' @param geom,stat Use to override the default connection between @@ -23,6 +21,12 @@ #' finite, boundary effect of default density estimation will be corrected by #' reflecting tails outside `bounds` around their closest edge. Data points #' outside of bounds are removed with a warning. +#' @param quantile.colour,quantile.color,quantile.linewidth,quantile.linetype +#' Default aesthetics for the quantile lines. Set to `NULL` to inherit from +#' the data's aesthetics. By default, quantile lines are hidden and can be +#' turned on by changing `quantile.linetype`. +#' @param draw_quantiles `r lifecycle::badge("deprecated")` Previous +#' specification of drawing quantiles. #' @export #' @references Hintze, J. L., Nelson, R. D. (1998) Violin Plots: A Box #' Plot-Density Trace Synergism. The American Statistician 52, 181-184. @@ -91,14 +95,46 @@ geom_violin <- function(mapping = NULL, data = NULL, stat = "ydensity", position = "dodge", ..., - draw_quantiles = NULL, 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( + "3.6.0", + what = "geom_violin(draw_quantiles)", + with = "geom_violin(quantiles.linetype)" + ) + check_numeric(draw_quantiles) + + # Pass on to stat when stat accepts 'quantiles' + stat <- validate_subclass(stat, "Stat", current_call(), caller_env()) + if ("quantiles" %in% stat$parameters()) { + extra$quantiles <- draw_quantiles + } + + # Turn on quantile lines + if (!is.null(quantile.linetype)) { + quantile.linetype <- max(quantile.linetype, 1) + } + } + + quantile_gp <- list( + colour = quantile.color %||% quantile.colour, + linetype = quantile.linetype, + linewidth = quantile.linewidth + ) + layer( data = data, mapping = mapping, @@ -110,10 +146,11 @@ geom_violin <- function(mapping = NULL, data = NULL, params = list2( trim = trim, scale = scale, - draw_quantiles = draw_quantiles, na.rm = na.rm, orientation = orientation, bounds = bounds, + quantile_gp = quantile_gp, + !!!extra, ... ) ) @@ -131,11 +168,13 @@ GeomViolin <- ggproto("GeomViolin", Geom, extra_params = c("na.rm", "orientation", "lineend", "linejoin", "linemitre"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + data <- compute_data_size( + 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, xmin = x - width / 2, @@ -144,7 +183,7 @@ GeomViolin <- ggproto("GeomViolin", Geom, flip_data(data, params$flipped_aes) }, - draw_group = function(self, data, ..., draw_quantiles = NULL, 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, @@ -163,42 +202,41 @@ GeomViolin <- ggproto("GeomViolin", Geom, newdata <- vec_rbind0(newdata, newdata[1,]) newdata <- flip_data(newdata, flipped_aes) + violin_grob <- GeomPolygon$draw_panel(newdata, ...) + + if (!"quantile" %in% names(newdata) || + all(quantile_gp$linetype == 0) || + all(quantile_gp$linetype == "blank")) { + return(ggname("geom_violin", violin_grob)) + } + # Draw quantiles if requested, so long as there is non-zero y range - if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) { - if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) { - cli::cli_abort("{.arg draw_quantiles} must be between 0 and 1.") - } - - # Compute the quantile segments and combine with existing aesthetics - quantiles <- create_quantile_segment_frame(data, draw_quantiles) - aesthetics <- data[ - rep(1, nrow(quantiles)), - setdiff(names(data), c("x", "y", "group")), - drop = FALSE - ] - aesthetics$alpha <- rep(1, nrow(quantiles)) - both <- vec_cbind(quantiles, aesthetics) - both <- both[!is.na(both$group), , drop = FALSE] - both <- flip_data(both, flipped_aes) - quantile_grob <- if (nrow(both) == 0) { - zeroGrob() - } else { - GeomPath$draw_panel(both, ...) - } - - ggname("geom_violin", grobTree( - GeomPolygon$draw_panel(newdata, ...), - quantile_grob) - ) + quantiles <- newdata[!is.na(newdata$quantile),] + quantiles$group <- match(quantiles$quantile, unique(quantiles$quantile)) + quantiles$linetype <- quantile_gp$linetype %||% quantiles$linetype + quantiles$linewidth <- quantile_gp$linewidth %||% quantiles$linewidth + quantiles$colour <- quantile_gp$colour %||% quantiles$colour + + quantile_grob <- if (nrow(quantiles) == 0) { + zeroGrob() } else { - ggname("geom_violin", GeomPolygon$draw_panel(newdata, ...)) + GeomPath$draw_panel(quantiles, ...) } + + ggname("geom_violin", grobTree(violin_grob, quantile_grob)) }, draw_key = draw_key_polygon, - default_aes = aes(weight = 1, colour = "grey20", fill = "white", linewidth = 0.5, - alpha = NA, linetype = "solid"), + default_aes = aes( + weight = 1, + colour = from_theme(colour %||% col_mix(ink, paper, 0.2)), + fill = from_theme(fill %||% paper), + linewidth = from_theme(borderwidth), + linetype = from_theme(bordertype), + alpha = NA, + width = 0.9 + ), required_aes = c("x", "y"), @@ -217,7 +255,7 @@ create_quantile_segment_frame <- function(data, draw_quantiles) { # We have two rows per segment drawn. Each segment gets its own group. data_frame0( - x = interleave(violin.xminvs, violin.xmaxvs), + x = vec_interleave(violin.xminvs, violin.xmaxvs), y = rep(ys, each = 2), group = rep(ys, each = 2) ) diff --git a/R/geom-vline.R b/R/geom-vline.R index 2705093f05..23093fcbcd 100644 --- a/R/geom-vline.R +++ b/R/geom-vline.R @@ -4,6 +4,7 @@ NULL #' @export #' @rdname geom_abline geom_vline <- function(mapping = NULL, data = NULL, + position = "identity", ..., xintercept, na.rm = FALSE, @@ -29,7 +30,7 @@ geom_vline <- function(mapping = NULL, data = NULL, mapping = mapping, stat = StatIdentity, geom = GeomVline, - position = PositionIdentity, + position = position, show.legend = show.legend, inherit.aes = FALSE, params = list2( @@ -55,7 +56,8 @@ GeomVline <- ggproto("GeomVline", Geom, GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) }, - default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), + default_aes = GeomPath$default_aes, + required_aes = "xintercept", draw_key = draw_key_vline, diff --git a/R/ggplot2-package.R b/R/ggplot2-package.R index 539f03db97..46c1b334f0 100644 --- a/R/ggplot2-package.R +++ b/R/ggplot2-package.R @@ -3,7 +3,6 @@ ## usethis namespace: start #' @import scales grid gtable rlang vctrs -#' @importFrom glue glue glue_collapse #' @importFrom lifecycle deprecated #' @importFrom stats setNames #' @importFrom utils head tail diff --git a/R/ggproto.R b/R/ggproto.R index 4fbd7c5284..853a440f9f 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -98,7 +98,6 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { e } - #' @export #' @rdname ggproto #' @param parent,self Access parent class `parent` of object `self`. @@ -366,3 +365,38 @@ format.ggproto_method <- function(x, ...) { # proto2 TODO: better way of getting formals for self$draw ggproto_formals <- function(x) formals(environment(x)$f) + +#' Debug wrapper for ggproto methods +#' +#' @param method A ggproto method or function to debug. +#' @param debug One of the following: +#' * `"once"` for invoking `debugonce()` (default). +#' * `"always"` for invoking `debug()`. +#' * `"never"` for invoking `undebug()`. +#' @param ... Arguments passed to the function invoked by the `debug` argument. +#' +#' @return `NULL`, this function is called for its side-effects. +#' @noRd +#' +#' @examples +#' p <- ggplot(mpg, aes(displ, hwy)) + +#' geom_point() +#' +#' if (interactive()) { +#' ggproto_debug(GeomPoint$draw_panel) +#' } +#' +#' p +ggproto_debug <- function(method, debug = c("once", "always", "never"), ...) { + if (inherits(method, "ggproto_method")) { + method <- environment(method)$f + } + check_function(method) + switch( + arg_match0(debug, c("once", "always", "never")), + once = debugonce(method, ...), + always = debug(method, ...), + never = undebug(method, ...) + ) +} + diff --git a/R/grob-dotstack.R b/R/grob-dotstack.R index 75ca9e81ed..d3463c18bd 100644 --- a/R/grob-dotstack.R +++ b/R/grob-dotstack.R @@ -14,15 +14,13 @@ dotstackGrob <- function( y <- unit(y, default.units) if (!is.unit(dotdia)) dotdia <- unit(dotdia, default.units) - if (!is_npc(dotdia)) + if (!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") } -# Only cross-version reliable way to check the unit of a unit object -is_npc <- function(x) isTRUE(grepl('^[^+^-^\\*]*[^s]npc$', as.character(x))) #' @export makeContext.dotstackGrob <- function(x) { diff --git a/R/guide-.R b/R/guide-.R index 1019cd2691..8d26a95628 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -19,7 +19,7 @@ NULL new_guide <- function(..., available_aes = "any", super) { pf <- parent.frame() - super <- check_subclass(super, "Guide", env = pf) + super <- validate_subclass(super, "Guide", env = pf) args <- list2(...) @@ -51,7 +51,7 @@ new_guide <- function(..., available_aes = "any", super) { # Validate theme settings if (!is.null(params$theme)) { check_object(params$theme, is_theme, what = "a {.cls theme} object") - validate_theme(params$theme, call = caller_env()) + check_theme(params$theme, call = caller_env()) params$direction <- params$direction %||% params$theme$legend.direction } @@ -225,13 +225,8 @@ Guide <- ggproto( mapped <- scale$map(breaks) labels <- scale$get_labels(breaks) - # {vctrs} doesn't play nice with expressions, convert to list. - # see also https://github.com/r-lib/vctrs/issues/559 - if (is.expression(labels)) { - labels <- as.list(labels) - } - key <- data_frame(mapped, .name_repair = ~ aesthetic) + key <- data_frame(!!aesthetic := mapped) key$.value <- breaks key$.label <- labels @@ -269,11 +264,11 @@ Guide <- ggproto( # Function for extracting information from the layers. # Mostly applies to `guide_legend()` and `guide_binned()` - process_layers = function(self, params, layers, data = NULL) { - self$get_layer_key(params, layers, data) + process_layers = function(self, params, layers, data = NULL, theme = NULL) { + self$get_layer_key(params, layers, data, theme) }, - get_layer_key = function(params, layers, data = NULL) { + get_layer_key = function(params, layers, data = NULL, theme = NULL) { return(params) }, @@ -491,7 +486,7 @@ Guide <- ggproto( # Helper function that may facilitate flipping theme elements by # swapping x/y related arguments to `element_grob()` -flip_element_grob = function(..., flip = FALSE) { +flip_element_grob <- function(..., flip = FALSE) { if (!flip) { ans <- element_grob(...) return(ans) @@ -503,7 +498,7 @@ flip_element_grob = function(..., flip = FALSE) { } # The flippable arguments for `flip_element_grob()`. -flip_names = c( +flip_names <- c( "x" = "y", "y" = "x", "width" = "height", @@ -523,17 +518,19 @@ opposite_position <- function(position) { top = "bottom", bottom = "top", left = "right", - right = "left" + right = "left", + position ) } # Ensure that labels aren't a list of expressions, but proper expressions validate_labels <- function(labels) { - if (!is.list(labels)) { + if (!obj_is_list(labels)) { return(labels) } + labels[lengths(labels) == 0L] <- "" if (any(vapply(labels, is.language, logical(1)))) { - do.call(expression, labels) + inject(expression(!!!labels)) } else { unlist(labels) } diff --git a/R/guide-axis-stack.R b/R/guide-axis-stack.R index c645c29d99..a58a4344cc 100644 --- a/R/guide-axis-stack.R +++ b/R/guide-axis-stack.R @@ -22,7 +22,7 @@ NULL #' @export #' #' @examples -#' #' # A standard plot +#' # A standard plot #' p <- ggplot(mpg, aes(displ, hwy)) + #' geom_point() + #' theme(axis.line = element_line()) @@ -41,7 +41,7 @@ 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)) - if (all(!available)) { + if (!any(available)) { cli::cli_abort(paste0( "{.fn guide_axis_stack} can only use guides that handle {.field x} and ", "{.field y} aesthetics." @@ -49,7 +49,7 @@ guide_axis_stack <- function(first = "axis", ..., title = waiver(), theme = NULL } # Remove guides that don't support x/y aesthetics - if (any(!available)) { + if (!all(available)) { remove <- which(!available) removed <- vapply(axes[remove], snake_class, character(1)) axes[remove] <- NULL @@ -134,7 +134,7 @@ GuideAxisStack <- ggproto( }, # Just loops through guides - get_layer_key = function(params, layers) { + get_layer_key = function(params, layers, ...) { for (i in seq_along(params$guides)) { params$guide_params[[i]] <- params$guides[[i]]$get_layer_key( params = params$guide_params[[i]], diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index 567cf08020..af96a337b6 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -61,30 +61,31 @@ guide_axis_theta <- function(title = waiver(), theme = NULL, angle = waiver(), GuideAxisTheta <- ggproto( "GuideAxisTheta", GuideAxis, - extract_decor = function(scale, aesthetic, key, cap = "none", position, ...) { - # For theta position, we pretend we're left/right because that will put - # the correct opposite aesthetic as the line coordinates. - position <- switch(position, theta = "left", theta.sec = "right", position) - - GuideAxis$extract_decor( - scale = scale, aesthetic = aesthetic, - position = position, key = key, cap = cap - ) - }, - transform = function(params, coord, panel_params) { - opposite <- setdiff(c("x", "y"), params$aesthetic) - params$key[[opposite]] <- switch(params$position, - theta.sec = -Inf, - top = -Inf, - right = -Inf, - Inf) + 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) + if (is.unsorted(panel_params$inner_radius %||% NA)) { + opposite_value <- -opposite_value + } + if (nrow(params$key) > 0) { + params$key[[opposite_var]] <- opposite_value + } + if (nrow(params$decor) > 0) { + params$decor[[opposite_var]] <- opposite_value + } + } params <- GuideAxis$transform(params, coord, panel_params) key <- params$key - n <- nrow(key) + n <- vec_size(key) + if (n < 1) { + return(params) + } if (!("theta" %in% names(key))) { # We likely have a linear coord, so we match the text angles to @@ -105,7 +106,7 @@ GuideAxisTheta <- ggproto( # labels of these positions ends_apart <- (key$theta[n] - key$theta[1]) %% (2 * pi) if (n > 0 && ends_apart < 0.05 && !is.null(key$.label)) { - if (is.expression(key$.label)) { + if (is.expression(key$.label[[1]])) { combined <- substitute( paste(a, "/", b), list(a = key$.label[[1]], b = key$.label[[n]]) @@ -195,7 +196,7 @@ GuideAxisTheta <- ggproto( } # Resolve text angle - if (is.waive(params$angle) || is.null(params$angle)) { + if (is.waiver(params$angle) || is.null(params$angle)) { angle <- elements$text$angle } else { angle <- flip_text_angle(params$angle - rad2deg(key$theta)) @@ -242,6 +243,12 @@ GuideAxisTheta <- ggproto( grobTree(major, minor, name = "ticks") }, + draw_early_exit = function(self, params, elements) { + line <- self$build_decor(decor = params$decor, elements = elements, + params = params) + gTree(children = gList(line), offset = unit(0, "cm")) + }, + measure_grobs = function(grobs, params, elements) { # As this guide is expected to be placed in the interior of coord_radial, # we don't need to measure grob sizes nor arrange the layout. @@ -265,7 +272,7 @@ GuideAxisTheta <- ggproto( } # Resolve text angle - if (is.waive(params$angle %||% waiver())) { + if (is.waiver(params$angle %||% waiver())) { angle <- elements$text$angle } else { angle <- flip_text_angle(params$angle - rad2deg(key$theta)) diff --git a/R/guide-axis.R b/R/guide-axis.R index 84ba39a205..c94473d081 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -6,6 +6,9 @@ #' [scale_(x|y)_discrete()][scale_x_discrete()]. #' #' @inheritParams guide_legend +#' @param theme A [`theme`][theme()] object to style the guide individually or +#' differently from the plot's theme settings. The `theme` argument in the +#' guide partially overrides, and is combined with, the plot's theme. #' @param check.overlap silently remove overlapping labels, #' (recursively) prioritizing the first, last, and middle labels. #' @param angle Compared to setting the angle in [theme()] / [element_text()], @@ -115,6 +118,9 @@ GuideAxis <- ggproto( extract_key = function(scale, aesthetic, minor.ticks = FALSE, ...) { major <- Guide$extract_key(scale, aesthetic, ...) + if (is.null(major) && is.null(scale$scale$get_breaks())) { + major <- data_frame0() + } if (!minor.ticks) { return(major) } @@ -133,6 +139,11 @@ GuideAxis <- ggproto( if (nrow(major) > 0) { major$.type <- "major" + if (!vec_is(minor$.value, major$.value)) { + # If we have mixed types of values, which may happen in discrete scales, + # discard minor values in favour of the major values. + minor$.value <- NULL + } vec_rbind(major, minor) } else { minor @@ -147,10 +158,11 @@ GuideAxis <- ggproto( extract_decor = function(scale, aesthetic, position, key, cap = "none", ...) { value <- c(-Inf, Inf) - if (cap %in% c("both", "upper")) { + has_key <- !(is.null(key) || nrow(key) < 1) + if (cap %in% c("both", "upper") && has_key) { value[2] <- max(key[[aesthetic]]) } - if (cap %in% c("both", "lower")) { + if (cap %in% c("both", "lower") && has_key) { value[1] <- min(key[[aesthetic]]) } @@ -166,26 +178,32 @@ GuideAxis <- ggproto( transform = function(self, params, coord, panel_params) { key <- params$key position <- params$position - - if (is.null(position) || nrow(key) == 0) { - return(params) + check <- FALSE + + if (!(is.null(position) || nrow(key) == 0)) { + check <- TRUE + aesthetics <- names(key)[!grepl("^\\.", names(key))] + if (!all(c("x", "y") %in% aesthetics)) { + other_aesthetic <- setdiff(c("x", "y"), aesthetics) + override_value <- if (position %in% c("bottom", "left")) -Inf else Inf + key[[other_aesthetic]] <- override_value + } + key <- coord$transform(key, panel_params) + params$key <- key } - aesthetics <- names(key)[!grepl("^\\.", names(key))] - if (!all(c("x", "y") %in% aesthetics)) { - other_aesthetic <- setdiff(c("x", "y"), aesthetics) - override_value <- if (position %in% c("bottom", "left")) -Inf else Inf - key[[other_aesthetic]] <- override_value - } - key <- coord$transform(key, panel_params) - params$key <- key + if (!is.null(params$decor)) { + params$decor <- coord_munch(coord, params$decor, panel_params) - params$decor <- coord_munch(coord, params$decor, panel_params) + if (!coord$is_linear()) { + # For non-linear coords, we hardcode the opposite position + params$decor$x <- switch(position, left = 1, right = 0, params$decor$x) + params$decor$y <- switch(position, top = 0, bottom = 1, params$decor$y) + } + } - if (!coord$is_linear()) { - # For non-linear coords, we hardcode the opposite position - params$decor$x <- switch(position, left = 1, right = 0, params$decor$x) - params$decor$y <- switch(position, top = 0, bottom = 1, params$decor$y) + if (!check) { + return(params) } # Ported over from `warn_for_position_guide` @@ -239,21 +257,14 @@ GuideAxis <- ggproto( }, override_elements = function(params, elements, theme) { - label <- elements$text - if (!is_theme_element(label, "text")) { - return(elements) + elements$text <- + label_angle_heuristic(elements$text, params$position, params$angle) + if (is_theme_element(elements$ticks, "blank")) { + elements$major_length <- unit(0, "cm") + } + if (is_theme_element(elements$minor, "blank") || isFALSE(params$minor.ticks)) { + elements$minor_length <- unit(0, "cm") } - label_overrides <- axis_label_element_overrides( - params$position, params$angle - ) - # label_overrides is an element_text, but label_element may not be; - # to merge the two elements, we just copy angle, hjust, and vjust - # unless their values are NULL - label$angle <- label_overrides$angle %||% label$angle - label$hjust <- label_overrides$hjust %||% label$hjust - label$vjust <- label_overrides$vjust %||% label$vjust - - elements$text <- label return(elements) }, @@ -409,6 +420,7 @@ GuideAxis <- ggproto( # 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)) # Initialise empty gtable @@ -430,10 +442,25 @@ GuideAxis <- ggproto( vp <- exec( viewport, !!params$orth_aes := unit(params$orth_side, "npc"), - !!params$orth_size := params$measure_gtable(gt), + !!params$orth_size := max(params$measure_gtable(gt), unit(1, "npc")), just = params$opposite ) + # Add null-unit padding to justify based on eventual gtable cell shape + # rather than dimensions of this axis alone. + if (has_labels && params$position %in% c("left", "right")) { + where <- layout$l[-c(1, length(layout$l))] + just <- with(elements$text, rotate_just(angle, hjust, vjust))$hjust %||% 0.5 + gt <- gtable_add_cols(gt, unit(just, "null"), pos = min(where) - 1) + gt <- gtable_add_cols(gt, unit(1 - just, "null"), pos = max(where) + 1) + } + if (has_labels && params$position %in% c("top", "bottom")) { + where <- layout$t[-c(1, length(layout$t))] + just <- with(elements$text, rotate_just(angle, hjust, vjust))$vjust %||% 0.5 + gt <- gtable_add_rows(gt, unit(1 - just, "null"), pos = min(where) - 1) + gt <- gtable_add_rows(gt, unit(just, "null"), pos = max(where) + 1) + } + # Assemble with axis line absoluteGrob( gList(axis_line, gt), @@ -553,49 +580,40 @@ axis_label_priority_between <- function(x, y) { ) } -#' Override axis text angle and alignment +#' Override text angle and alignment #' +#' @param element An `element_text()` #' @param axis_position One of bottom, left, top, or right #' @param angle The text angle, or NULL to override nothing #' #' @return An [element_text()] that contains parameters that should be #' overridden from the user- or theme-supplied element. #' @noRd -#' -axis_label_element_overrides <- function(axis_position, angle = NULL) { - - if (is.null(angle) || is.waive(angle)) { - return(element_text(angle = NULL, hjust = NULL, vjust = NULL)) +label_angle_heuristic <- function(element, position, angle) { + if (!inherits(element, "element_text") + || is.null(position) + || is.null(angle %|W|% NULL)) { + return(element) } + arg_match0(position, .trbl) check_number_decimal(angle) - angle <- angle %% 360 - arg_match0( - axis_position, - c("bottom", "left", "top", "right") - ) - - if (axis_position == "bottom") { - - hjust = if (angle %in% c(0, 180)) 0.5 else if (angle < 180) 1 else 0 - vjust = if (angle %in% c(90, 270)) 0.5 else if (angle > 90 & angle < 270) 0 else 1 - - } else if (axis_position == "left") { - - hjust = if (angle %in% c(90, 270)) 0.5 else if (angle > 90 & angle < 270) 0 else 1 - vjust = if (angle %in% c(0, 180)) 0.5 else if (angle < 180) 0 else 1 - - } else if (axis_position == "top") { - - hjust = if (angle %in% c(0, 180)) 0.5 else if (angle < 180) 0 else 1 - vjust = if (angle %in% c(90, 270)) 0.5 else if (angle > 90 & angle < 270) 1 else 0 - - } else if (axis_position == "right") { - - hjust = if (angle %in% c(90, 270)) 0.5 else if (angle > 90 & angle < 270) 1 else 0 - vjust = if (angle %in% c(0, 180)) 0.5 else if (angle < 180) 1 else 0 - - } - - element_text(angle = angle, hjust = hjust, vjust = vjust) + radian <- deg2rad(angle) + digits <- 3 + + # Taking the sign of the (co)sine snaps the value to c(-1, 0, 1) + # Doing `x / 2 + 0.5` rescales it to c(0, 0.5, 1), which are good values for justification + # 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 + + # 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) + + element$angle <- angle %||% element$angle + element$hjust <- hjust %||% element$hjust + element$vjust <- vjust %||% element$vjust + element } diff --git a/R/guide-bins.R b/R/guide-bins.R index 571a461d4b..b83494fb77 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -11,6 +11,10 @@ NULL #' guide if they are mapped in the same way. #' #' @inheritParams guide_legend +#' @param angle Overrules the theme settings to automatically apply appropriate +#' `hjust` and `vjust` for angled legend text. Can be a single number +#' representing the text angle in degrees, or `NULL` to not overrule the +#' settings (default). #' @param show.limits Logical. Should the limits of the scale be shown with #' labels and ticks. Default is `NULL` meaning it will take the value from the #' scale. This argument is ignored if `labels` is given as a vector of @@ -65,6 +69,7 @@ guide_bins <- function( theme = NULL, # general + angle = NULL, position = NULL, direction = NULL, override.aes = list(), @@ -85,6 +90,7 @@ guide_bins <- function( theme = theme, # general + angle = angle, position = position, direction = direction, override.aes = rename_aes(override.aes), @@ -115,6 +121,7 @@ GuideBins <- ggproto( default_axis = element_line("black", linewidth = (0.5 / .pt)), default_ticks = element_line(inherit.blank = TRUE), + angle = NULL, direction = NULL, override.aes = list(), reverse = FALSE, @@ -154,7 +161,10 @@ GuideBins <- ggproto( key$.show <- NA labels <- scale$get_labels(breaks) - if (is.character(scale$labels) || is.numeric(scale$labels)) { + labels <- labels[!is.na(breaks)] + breaks <- breaks[!is.na(breaks)] + + 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) @@ -201,11 +211,14 @@ GuideBins <- ggproto( params$show.limits <- show.limits if (params$reverse) { - key <- key[rev(seq_len(nrow(key))), , drop = FALSE] + 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$.value <- 1 - key$.value } - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$key <- key params }, @@ -258,7 +271,7 @@ GuideBins <- ggproto( list(labels = flip_element_grob( elements$text, - label = key$.label, + label = validate_labels(key$.label), x = unit(key$.value, "npc"), margin_x = FALSE, margin_y = TRUE, @@ -326,20 +339,24 @@ GuideBins <- ggproto( } ) -parse_binned_breaks = function(scale, breaks = scale$get_breaks()) { +parse_binned_breaks <- function(scale, breaks = scale$get_breaks()) { - breaks <- breaks[!is.na(breaks)] + if (is.waiver(scale$labels) || is.function(scale$labels)) { + breaks <- breaks[!is.na(breaks)] + } if (length(breaks) == 0) { return(NULL) } if (is.numeric(breaks)) { - breaks <- sort(breaks) limits <- scale$get_limits() if (!is.numeric(scale$breaks)) { - breaks <- breaks[!breaks %in% limits] + breaks[breaks %in% limits] <- NA } + breaks <- oob_censor(breaks, limits) all_breaks <- unique0(c(limits[1], breaks, limits[2])) + # Sorting drops NAs on purpose here + all_breaks <- sort(all_breaks, na.last = NA) bin_at <- all_breaks[-1] - diff(all_breaks) / 2 } else { bin_at <- breaks diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index ed00db1d5f..096901e9a8 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -30,6 +30,10 @@ NULL #' @param alpha A numeric between 0 and 1 setting the colour transparency of #' the bar. Use `NA` to preserve the alpha encoded in the colour itself #' (default). +#' @param angle Overrules the theme settings to automatically apply appropriate +#' `hjust` and `vjust` for angled legend text. Can be a single number +#' representing the text angle in degrees, or `NULL` to not overrule the +#' settings (default). #' @param draw.ulim A logical specifying if the upper limit tick marks should #' be visible. #' @param draw.llim A logical specifying if the lower limit tick marks should @@ -122,6 +126,7 @@ guide_colourbar <- function( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + angle = NULL, position = NULL, direction = NULL, reverse = FALSE, @@ -149,6 +154,7 @@ guide_colourbar <- function( nbin = nbin, display = display, alpha = alpha, + angle = angle, draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)), position = position, direction = direction, @@ -191,6 +197,7 @@ GuideColourbar <- ggproto( direction = NULL, reverse = FALSE, order = 0, + angle = NULL, # parameter name = "colourbar", @@ -250,7 +257,7 @@ GuideColourbar <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) limits <- params$decor$value[c(1L, nrow(params$decor))] to <- switch( params$display, @@ -268,7 +275,7 @@ GuideColourbar <- ggproto( return(list(guide = self, params = params)) }, - get_layer_key = function(params, layers, data = NULL) { + get_layer_key = function(params, layers, data = NULL, theme = NULL) { params }, @@ -284,10 +291,10 @@ GuideColourbar <- ggproto( # We set the defaults in `theme` so that the `params$theme` can still # overrule defaults given here if (params$direction == "horizontal") { - theme$legend.key.width <- theme$legend.key.width * 5 + theme$legend.key.width <- rel(5) valid_position <- c("bottom", "top") } else { - theme$legend.key.height <- theme$legend.key.height * 5 + theme$legend.key.height <- rel(5) valid_position <- c("right", "left") } @@ -365,12 +372,12 @@ GuideColourbar <- ggproto( if (params$direction == "horizontal") { width <- 1 / nrow(decor) height <- 1 - x <- (seq(nrow(decor)) - 1) * width + x <- (seq_len(nrow(decor)) - 1) * width y <- 0 } else { width <- 1 height <- 1 / nrow(decor) - y <- (seq(nrow(decor)) - 1) * height + y <- (seq_len(nrow(decor)) - 1) * height x <- 0 } grob <- rectGrob( @@ -378,7 +385,7 @@ GuideColourbar <- ggproto( vjust = 0, hjust = 0, width = width, height = height, default.units = "npc", - gp = gpar(col = NA, fill = decor$colour) + gp = gg_par(col = NA, fill = decor$colour) ) } else if (params$display == "gradient") { check_device("gradients", call = expr(guide_colourbar())) @@ -393,7 +400,7 @@ GuideColourbar <- ggproto( vertical = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc")) ) gradient <- inject(linearGradient(decor$colour, value, !!!position)) - grob <- rectGrob(gp = gpar(fill = gradient, col = NA)) + grob <- rectGrob(gp = gg_par(fill = gradient, col = NA)) } frame <- element_grob(elements$frame, fill = NA) diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index d85421bbc9..14cca8563d 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -49,9 +49,11 @@ guide_coloursteps <- function( title = waiver(), theme = NULL, alpha = NA, + angle = NULL, even.steps = TRUE, show.limits = NULL, direction = NULL, + position = NULL, reverse = FALSE, order = 0, available_aes = c("colour", "color", "fill"), @@ -65,11 +67,14 @@ guide_coloursteps <- function( title = title, theme = theme, alpha = alpha, + angle = angle, even.steps = even.steps, show.limits = show.limits, + position = position, direction = direction, reverse = reverse, order = order, + available_aes = available_aes, super = GuideColoursteps ) } @@ -107,11 +112,13 @@ GuideColoursteps <- ggproto( key <- data_frame0(!!aesthetic := scale$map(breaks)) if (even.steps) { - key$.value <- seq_along(breaks) + key$.value <- NA_integer_ + key$.value[!is.na(breaks)] <- seq_along(breaks[!is.na(breaks)]) } else { key$.value <- breaks } key$.label <- scale$get_labels(breaks) + key <- vec_slice(key, !is.na(breaks)) if (breaks[1] %in% limits) { key$.value <- key$.value - 1L @@ -184,9 +191,7 @@ GuideColoursteps <- ggproto( params$key <- key } - params$title <- scale$make_title( - params$title %|W|% scale$name %|W|% title - ) + params$title <- scale$make_title(params$title, scale$name, title) limits <- c(params$decor$min[1], params$decor$max[nrow(params$decor)]) if (params$reverse) { @@ -204,7 +209,7 @@ GuideColoursteps <- ggproto( size <- abs(decor$max - decor$min) just <- as.numeric(decor$min > decor$max) - gp <- gpar(col = NA, fill = decor$colour) + gp <- gg_par(col = NA, fill = decor$colour) if (params$direction == "vertical") { grob <- rectGrob( x = 0, y = decor$min, diff --git a/R/guide-custom.R b/R/guide-custom.R index 16a737d3fd..f602bfc843 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -96,7 +96,7 @@ GuideCustom <- ggproto( # Render title params <- replace_null(params, position = position, direction = direction) elems <- GuideLegend$setup_elements(params, self$elements, theme) - if (!is.waive(params$title) && !is.null(params$title)) { + if (!is.waiver(params$title) && !is.null(params$title)) { title <- self$build_title(params$title, elems, params) } else { title <- zeroGrob() @@ -117,7 +117,7 @@ GuideCustom <- ggproto( ) # Add padding and background - gt <- gtable_add_padding(gt, elems$margin) + gt <- gtable_add_padding(gt, elems$margin %||% margin()) gt <- gtable_add_grob( gt, element_grob(elems$background), diff --git a/R/guide-legend.R b/R/guide-legend.R index 6581c31556..b728752518 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -15,11 +15,15 @@ #' specified in [labs()] is used for the title. #' @param theme A [`theme`][theme()] object to style the guide individually or #' differently from the plot's theme settings. The `theme` argument in the -#' guide overrides, and is combined with, the plot's theme. +#' guide partially overrides, and is combined with, the plot's theme. +#' Arguments that apply to a single legend are respected, most of which have +#' the `legend`-prefix. Arguments that apply to combined legends +#' (the legend box) are ignored, including `legend.position`, +#' `legend.justification.*`, `legend.location` and `legend.box.*`. #' @param position A character string indicating where the legend should be #' placed relative to the plot panels. #' @param direction A character string indicating the direction of the guide. -#' One of "horizontal" or "vertical." +#' One of "horizontal" or "vertical". #' @param override.aes A list specifying aesthetic parameters of legend key. #' See details and examples. #' @param nrow,ncol The desired number of rows and column of legends @@ -174,6 +178,7 @@ GuideLegend <- ggproto( 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", @@ -185,7 +190,7 @@ GuideLegend <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + 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] } @@ -210,7 +215,7 @@ GuideLegend <- ggproto( }, # Arrange common data for vertical and horizontal legends - process_layers = function(self, params, layers, data = NULL) { + process_layers = function(self, params, layers, data = NULL, theme = NULL) { include <- vapply(layers, function(layer) { aes <- matched_aes(layer, params) @@ -221,46 +226,41 @@ GuideLegend <- ggproto( return(NULL) } - self$get_layer_key(params, layers[include], data[include]) + self$get_layer_key(params, layers[include], data[include], theme) }, - get_layer_key = function(params, layers, data) { + 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] + key$.id <- seq_len(nrow(key)) + + # Filter static aesthetics to those with single values + single_params <- lengths(layer$aes_params) == 1L + single_params <- layer$aes_params[single_params] + # Use layer to populate defaults + key <- layer$compute_geom_2(key, single_params, theme) + + # Filter non-existing levels if (length(matched_aes) > 0) { - # Filter out aesthetics that can't be applied to the legend - n <- lengths(layer$aes_params, use.names = FALSE) - layer_params <- layer$aes_params[n == 1] - - aesthetics <- layer$computed_mapping - is_modified <- is_scaled_aes(aesthetics) | is_staged_aes(aesthetics) - modifiers <- aesthetics[is_modified] - - data <- try_fetch( - layer$geom$use_defaults(params$key[matched_aes], - layer_params, modifiers), - error = function(cnd) { - cli::cli_warn( - "Failed to apply {.fn after_scale} modifications to legend", - parent = cnd - ) - layer$geom$use_defaults(params$key[matched_aes], layer_params, list()) - } - ) - data$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend) - } else { - reps <- rep(1, nrow(params$key)) - data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ] + key$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend) } - data <- modify_list(data, params$override.aes) + # Apply overrides + key <- modify_list(key, params$override.aes) list( draw_key = layer$geom$draw_key, - data = data, + data = key, params = c(layer$computed_geom_params, layer$computed_stat_params) ) }) @@ -276,7 +276,6 @@ GuideLegend <- ggproto( c("horizontal", "vertical"), arg_nm = "direction" ) params$n_breaks <- n_breaks <- nrow(params$key) - params$n_key_layers <- length(params$decor) + 1 # +1 is key background # Resolve shape if (!is.null(params$nrow) && !is.null(params$ncol) && @@ -314,8 +313,8 @@ GuideLegend <- ggproto( arg_match0(title_position, .trbl, arg_nm = "legend.title.position") # Set default spacing - theme$legend.key.spacing <- theme$legend.key.spacing %||% unit(5.5, "pt") - gap <- calc_element("legend.key.spacing", theme) + theme$legend.key.spacing <- calc_element("legend.key.spacing", theme) + gap <- theme$legend.key.spacing # For backward compatibility, default vertical spacing is no spacing if (params$direction == "vertical") { @@ -379,6 +378,12 @@ GuideLegend <- ggproto( elements$key <- ggname("legend.key", element_grob(elements$key)) } + if (!is.null(elements$key_just)) { + elements$key_just <- valid.just(elements$key_just) + } + + elements$text <- + label_angle_heuristic(elements$text, elements$text_position, params$angle) elements }, @@ -389,22 +394,39 @@ GuideLegend <- ggproto( build_decor = function(decor, grobs, elements, params) { - key_size <- c(elements$width_cm, elements$height_cm) * 10 - - draw <- function(i) { - bg <- elements$key - keys <- lapply(decor, function(g) { - data <- vec_slice(g$data, i) - if (data$.draw %||% TRUE) { - key <- g$draw_key(data, g$params, key_size) - set_key_size(key, data$linewidth, data$size, key_size / 10) - } else { - zeroGrob() + key_size <- c(elements$width_cm, elements$height_cm) + just <- elements$key_just + idx <- seq_len(params$n_breaks) + + key_glyphs <- lapply(idx, function(i) { + glyph <- lapply(decor, function(dec) { + data <- vec_slice(dec$data, i) + if (!(data$.draw %||% TRUE)) { + return(zeroGrob()) } + key <- dec$draw_key(data, dec$params, key_size * 10) + set_key_size(key, data$linewidth, data$size, key_size) }) - c(list(bg), keys) - } - unlist(lapply(seq_len(params$n_breaks), draw), FALSE) + + 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") + ) + } + + grob <- gTree(children = inject(gList(elements$key, !!!glyph)), vp = vp) + attr(grob, "width") <- width + attr(grob, "height") <- height + grob + }) + key_glyphs }, build_labels = function(key, elements, params) { @@ -637,7 +659,7 @@ keep_key_data <- function(key, data, aes, show) { if (isTRUE(any(show)) || length(show) == 0) { return(TRUE) } - if (isTRUE(all(!show))) { + if (isTRUE(!any(show))) { return(FALSE) } # Second, we go find if the value is actually present in the data. @@ -694,6 +716,7 @@ deprecated_guide_args <- function( default.unit = "line", ..., .call = caller_call()) { + warn_dots_used(call = .call) args <- names(formals(deprecated_guide_args)) args <- setdiff(args, c("theme", "default.unit", "...", ".call")) @@ -792,3 +815,7 @@ deprecated_guide_args <- function( } theme } + +get_attr <- function(x, which, exact = TRUE, default = NULL) { + attr(x, which = which, exact = exact) %||% default +} diff --git a/R/guide-old.R b/R/guide-old.R index b2a137fffd..d20fec0e3e 100644 --- a/R/guide-old.R +++ b/R/guide-old.R @@ -89,7 +89,7 @@ GuideOld <- ggproto( train = function(self, params, scale, aesthetic = NULL, title = waiver(), direction = NULL) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$direction <- params$direction %||% direction %||% "vertical" params <- guide_train(params, scale, aesthetic) params @@ -103,7 +103,7 @@ GuideOld <- ggproto( guide_transform(params, coord, panel_params) }, - process_layers = function(self, params, layers, data = NULL) { + process_layers = function(self, params, layers, data = NULL, theme = NULL) { guide_geom(params, layers, default_mapping = NULL) }, diff --git a/R/guides-.R b/R/guides-.R index bd91989216..d96ef16074 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -68,11 +68,14 @@ NULL #' } guides <- function(...) { args <- list2(...) - if (length(args) > 0) { - if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]] - args <- rename_aes(args) + # If there are no guides do nothing + if (length(args) == 0) { + return(NULL) } + 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')") @@ -84,11 +87,6 @@ guides <- function(...) { return(guides_list(guides = args)) } - # If there are no guides, do nothing - if (length(args) == 0) { - return(NULL) - } - # Raise warning about unnamed guides nms <- names(args) if (is.null(nms)) { @@ -113,19 +111,6 @@ guides <- function(...) { #' @rdname is_tests is_guides <- function(x) inherits(x, "Guides") -update_guides <- function(p, guides) { - p <- plot_clone(p) - if (is_guides(p$guides)) { - old <- p$guides - new <- ggproto(NULL, old) - new$add(guides) - p$guides <- new - } else { - p$guides <- guides - } - p -} - # Class ------------------------------------------------------------------- # Guides object encapsulates multiple guides and their state. @@ -198,7 +183,7 @@ Guides <- ggproto( if (is.character(index)) { index <- match(index, self$aesthetics) } - if (any(is.na(index)) || length(index) == 0) { + if (anyNA(index) || length(index) == 0) { return(NULL) } if (length(index) == 1) { @@ -213,7 +198,7 @@ Guides <- ggproto( if (is.character(index)) { index <- match(index, self$aesthetics) } - if (any(is.na(index)) || length(index) == 0) { + if (anyNA(index) || length(index) == 0) { return(NULL) } if (length(index) == 1) { @@ -289,7 +274,7 @@ Guides <- ggproto( # # The resulting guide is then drawn in ggplot_gtable - build = function(self, scales, layers, labels, layer_data) { + build = function(self, scales, layers, labels, layer_data, theme = theme()) { # Empty guides list custom <- self$get_custom() @@ -316,13 +301,14 @@ Guides <- ggproto( # Merge and process layers guides$merge() - guides$process_layers(layers, layer_data) + guides$process_layers(layers, layer_data, theme) if (length(guides$guides) == 0) { return(no_guides) } - guides$guides <- c(guides$guides, custom$guides) - guides$params <- c(guides$params, custom$params) + ord <- order(c(names(guides$guides), names(custom$guides))) + guides$guides <- c(guides$guides, custom$guides)[ord] + guides$params <- c(guides$params, custom$params)[ord] guides }, @@ -354,13 +340,8 @@ Guides <- ggproto( # Find guide for aesthetic-scale combination # Hierarchy is in the order: # plot + guides(XXX) + scale_ZZZ(guide = XXX) > default(i.e., legend) - guide <- resolve_guide( - aesthetic = aesthetics[idx], - scale = scales[[idx]], - guides = guides, - default = default, - null = 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"')) @@ -464,9 +445,9 @@ Guides <- ggproto( }, # Loop over guides to let them extract information from layers - process_layers = function(self, layers, data = NULL) { + process_layers = function(self, layers, data = NULL, theme = NULL) { self$params <- Map( - function(guide, param) guide$process_layers(param, layers, data), + function(guide, param) guide$process_layers(param, layers, data, theme), guide = self$guides, param = self$params ) @@ -489,7 +470,7 @@ Guides <- ggproto( # for every position, collect all individual guides and arrange them # into a guide box which will be inserted into the main gtable # Combining multiple guides in a guide box - assemble = function(self, theme) { + assemble = function(self, theme, params = self$params, guides = self$guides) { if (length(self$guides) < 1) { return(zeroGrob()) @@ -499,46 +480,96 @@ Guides <- ggproto( if (length(default_position) == 2) { default_position <- "inside" } - if (default_position == "none") { + if (!default_position %in% c(.trbl, "inside")) { return(zeroGrob()) } - # Populate key sizes - theme$legend.key.width <- calc_element("legend.key.width", theme) - theme$legend.key.height <- calc_element("legend.key.height", theme) + # extract the guide position + positions <- vapply( + params, + function(p) p$position[1] %||% default_position, + character(1), USE.NAMES = FALSE + ) - grobs <- self$draw(theme, default_position, theme$legend.direction) + grobs <- self$draw(theme, positions, theme$legend.direction) + keep <- !vapply(grobs, is.zero, logical(1), USE.NAMES = FALSE) + grobs <- grobs[keep] if (length(grobs) < 1) { return(zeroGrob()) } - grobs <- grobs[order(names(grobs))] + + # prepare the position of inside legends + default_inside_just <- calc_element("legend.justification.inside", theme) + default_inside_position <- calc_element("legend.position.inside", theme) + + groups <- data_frame0( + positions = positions, + justs = list(NULL), + coords = list(NULL) + ) + + # we grouped the legends by the positions, for inside legends, they'll be + # splitted by the actual inside coordinate + for (i in which(positions == "inside")) { + # the actual inside position and justification can be set in each guide + # by `theme` argument, here, we won't use `calc_element()` which will + # use inherits from `legend.justification` or `legend.position`, we only + # follow the inside elements from the guide theme + just <- params[[i]]$theme[["legend.justification.inside"]] + just <- valid.just(just %||% default_inside_just) + coord <- params[[i]]$theme[["legend.position.inside"]] + coord <- coord %||% default_inside_position %||% just + + groups$justs[[i]] <- just + groups$coords[[i]] <- coord + } + + groups <- vec_group_loc(vec_slice(groups, keep)) + grobs <- vec_chop(grobs, indices = groups$loc) + names(grobs) <- groups$key$positions # Set spacing 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) - Map( - grobs = grobs, - position = names(grobs), - self$package_box, - MoreArgs = list(theme = theme) - ) + # prepare output + for (i in vec_seq_along(groups)) { + adjust <- NULL + position <- groups$key$positions[i] + if (position == "inside") { + adjust <- theme( + legend.position.inside = groups$key$coords[[i]], + legend.justification.inside = groups$key$justs[[i]] + ) + } + adjust <- add_theme(theme, adjust, "internal theme settings") + grobs[[i]] <- self$package_box(grobs[[i]], position, adjust) + } + + # merge inside grobs into single gtable + is_inside <- names(grobs) == "inside" + 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", + name = paste0("guide-box-inside-", seq_len(sum(is_inside))) + ) + grobs <- grobs[!is_inside] + grobs$inside <- inside + } + + # fill in missing guides + grobs[setdiff(c(.trbl, "inside"), names(grobs))] <- list(zeroGrob()) + + grobs }, # Render the guides into grobs - draw = function(self, theme, - default_position = "right", - direction = NULL, + draw = function(self, theme, positions, direction = NULL, params = self$params, guides = self$guides) { - positions <- vapply( - params, - function(p) p$position[1] %||% default_position, - character(1) - ) - positions <- factor(positions, levels = c(.trbl, "inside")) - directions <- rep(direction %||% "vertical", length(positions)) if (is.null(direction)) { directions[positions %in% c("top", "bottom")] <- "horizontal" @@ -547,14 +578,16 @@ Guides <- ggproto( grobs <- vector("list", length(guides)) for (i in seq_along(grobs)) { grobs[[i]] <- guides[[i]]$draw( - theme = theme, position = as.character(positions[i]), + theme = theme, position = positions[i], direction = directions[i], params = params[[i]] ) } - keep <- !vapply(grobs, is.zero, logical(1)) - split(grobs[keep], positions[keep]) + grobs }, + # here, we put `inside_position` and `inside_just` in the last, so that it + # 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) { @@ -562,11 +595,7 @@ Guides <- ggproto( } # Determine default direction - direction <- switch( - position, - inside = , left = , right = "vertical", - top = , bottom = "horizontal" - ) + direction <- switch(position, top = , bottom = "horizontal", "vertical") # Populate missing theme arguments theme$legend.box <- theme$legend.box %||% direction @@ -612,7 +641,7 @@ Guides <- ggproto( box_xjust <- box_just[1] box_yjust <- box_just[2] - margin <- theme$legend.box.margin %||% margin() + margin <- calc_element("legend.box.margin", theme) %||% margin() # setting that is different for vertical and horizontal guide-boxes. if (identical(theme$legend.box, "horizontal")) { @@ -717,7 +746,6 @@ Guides <- ggproto( guides$name <- "guide-box" guides }, - ## Utilities ----------------------------------------------------------------- print = function(self) { @@ -791,7 +819,7 @@ Guides <- ggproto( #' # Coord polar doesn't support proper guides, so we get a list #' polar <- p + coord_polar() #' get_guide_data(polar, "theta", panel = 2) -get_guide_data <- function(plot = last_plot(), aesthetic, panel = 1L) { +get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { check_string(aesthetic, allow_empty = FALSE) aesthetic <- standardise_aes_names(aesthetic) @@ -874,24 +902,6 @@ include_layer_in_guide <- function(layer, matched) { isTRUE(layer$show.legend) } -# Simplify legend position to one of horizontal/vertical/inside -legend_position <- function(position) { - if (length(position) == 1) { - if (position %in% c("top", "bottom")) { - "horizontal" - } else { - "vertical" - } - } else { - "inside" - } -} - -# resolve the guide from the scale and guides -resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { - guides[[aesthetic]] %||% scale$guide %|W|% default %||% null -} - # validate guide object validate_guide <- function(guide) { # if guide is specified by character, then find the corresponding guide diff --git a/R/guides-grid.R b/R/guides-grid.R index 9ae79a19a9..1b2f1a4a99 100644 --- a/R/guides-grid.R +++ b/R/guides-grid.R @@ -3,32 +3,58 @@ # be converted to `'native'` units by polylineGrob() downstream # # Any minor lines coinciding with major lines will be removed -guide_grid <- function(theme, x.minor, x.major, y.minor, y.major) { +guide_grid <- function(theme, panel_params, coord, square = TRUE) { - x.minor <- setdiff(x.minor, x.major) - y.minor <- setdiff(y.minor, y.major) + x_major <- panel_params$x$mapped_breaks() + x_minor <- setdiff(panel_params$x$mapped_breaks_minor(), x_major) - ggname("grill", grobTree( - element_render(theme, "panel.background"), - if (length(y.minor) > 0) element_render( - theme, "panel.grid.minor.y", - x = rep(0:1, length(y.minor)), y = rep(y.minor, each = 2), - id.lengths = rep(2, length(y.minor)) - ), - if (length(x.minor) > 0) element_render( - theme, "panel.grid.minor.x", - x = rep(x.minor, each = 2), y = rep(0:1, length(x.minor)), - id.lengths = rep(2, length(x.minor)) - ), - if (length(y.major) > 0) element_render( - theme, "panel.grid.major.y", - x = rep(0:1, length(y.major)), y = rep(y.major, each = 2), - id.lengths = rep(2, length(y.major)) - ), - if (length(x.major) > 0) element_render( - theme, "panel.grid.major.x", - x = rep(x.major, each = 2), y = rep(0:1, length(x.major)), - id.lengths = rep(2, length(x.major)) - ) - )) + y_major <- panel_params$y$mapped_breaks() + y_minor <- setdiff(panel_params$y$mapped_breaks_minor(), y_major) + + transform <- if (isTRUE(square)) { + if (inherits(coord, "CoordFlip")) { + function(x) coord$transform(flip_axis_labels(x), panel_params) + } else { + function(x) coord$transform(x, panel_params) + } + } else { + function(x) coord_munch(coord, x, panel_params) + } + + grill <- Map( + f = breaks_as_grid, + var = list(y_minor, x_minor, y_major, x_major), + type = c("minor.y", "minor.x", "major.y", "major.x"), + MoreArgs = list(theme = theme, transform = transform) + ) + grill <- compact(grill) + + background <- element_render(theme, "panel.background") + if (!isTRUE(square) && !is.zero(background)) { + gp <- background$gp + background <- data_frame0(x = c(1, 1, -1, -1), y = c(1, -1, -1, 1)) * Inf + background <- coord_munch(coord, background, panel_params, is_closed = TRUE) + background <- polygonGrob(x = background$x, y = background$y, gp = gp) + } + + ggname("grill", inject(grobTree(background, !!!grill))) +} + +breaks_as_grid <- function(var, type, transform, theme) { + n <- length(var) + if (n < 1) { + return(NULL) + } + df <- data_frame0( + 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, + id.lengths = vec_unrep(df$group)$times + ) } diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R index 72cfe37dc2..47268d620d 100644 --- a/R/import-standalone-obj-type.R +++ b/R/import-standalone-obj-type.R @@ -1,17 +1,27 @@ # Standalone file: do not edit by hand -# Source: +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R +# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") # ---------------------------------------------------------------------- # # --- # repo: r-lib/rlang # file: standalone-obj-type.R -# last-updated: 2022-10-04 +# last-updated: 2024-02-14 # license: https://unlicense.org # imports: rlang (>= 1.1.0) # --- # # ## Changelog # +# 2024-02-14: +# - `obj_type_friendly()` now works for S7 objects. +# +# 2023-05-01: +# - `obj_type_friendly()` now only displays the first class of S3 objects. +# +# 2023-03-30: +# - `stop_input_type()` now handles `I()` input literally in `arg`. +# # 2022-10-04: # - `obj_type_friendly(value = TRUE)` now shows numeric scalars # literally. @@ -65,7 +75,7 @@ obj_type_friendly <- function(x, value = TRUE) { if (inherits(x, "quosure")) { type <- "quosure" } else { - type <- paste(class(x), collapse = "/") + type <- class(x)[[1L]] } return(sprintf("a <%s> object", type)) } @@ -261,19 +271,19 @@ vec_type_friendly <- function(x, length = FALSE) { #' Return OO type #' @param x Any R object. #' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, -#' `"R6"`, or `"R7"`. +#' `"R6"`, or `"S7"`. #' @noRd obj_type_oo <- function(x) { if (!is.object(x)) { return("bare") } - class <- inherits(x, c("R6", "R7_object"), which = TRUE) + class <- inherits(x, c("R6", "S7_object"), which = TRUE) if (class[[1]]) { "R6" } else if (class[[2]]) { - "R7" + "S7" } else if (isS4(x)) { "S4" } else { @@ -315,10 +325,15 @@ stop_input_type <- function(x, if (length(what)) { what <- oxford_comma(what) } + if (inherits(arg, "AsIs")) { + format_arg <- identity + } else { + format_arg <- cli$format_arg + } message <- sprintf( "%s must be %s, not %s.", - cli$format_arg(arg), + format_arg(arg), what, obj_type_friendly(x, value = show_value) ) diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R index 6782d69b10..ef8c5a1d5e 100644 --- a/R/import-standalone-types-check.R +++ b/R/import-standalone-types-check.R @@ -1,5 +1,6 @@ # Standalone file: do not edit by hand -# Source: +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R +# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") # ---------------------------------------------------------------------- # # --- @@ -13,6 +14,9 @@ # # ## Changelog # +# 2024-08-15: +# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) +# # 2023-03-13: # - Improved error messages of number checkers (@teunbrand) # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). @@ -461,15 +465,28 @@ check_formula <- function(x, # Vectors ----------------------------------------------------------------- +# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` + check_character <- function(x, ..., + allow_na = TRUE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { + if (!missing(x)) { if (is_character(x)) { + if (!allow_na && any(is.na(x))) { + abort( + sprintf("`%s` can't contain NA values.", arg), + arg = arg, + call = call + ) + } + return(invisible(NULL)) } + if (allow_null && is_null(x)) { return(invisible(NULL)) } @@ -479,7 +496,6 @@ check_character <- function(x, x, "a character vector", ..., - allow_na = FALSE, allow_null = allow_null, arg = arg, call = call diff --git a/R/labeller.R b/R/labeller.R index 442f05d496..9afd572da0 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -83,6 +83,9 @@ #' # Interpreting the labels as plotmath expressions #' p + facet_grid(. ~ cyl2) #' p + facet_grid(. ~ cyl2, labeller = label_parsed) +#' +#' # Include optional argument in label function +#' p + facet_grid(. ~ cyl, labeller = function(x) label_both(x, sep = "=")) #' } #' @name labellers NULL @@ -111,21 +114,17 @@ label_value <- function(labels, multi_line = TRUE) { # currently needed for Roxygen class(label_value) <- c("function", "labeller") -# Helper for label_both -label_variable <- function(labels, multi_line = TRUE) { - if (multi_line) { - row <- as.list(names(labels)) - } else { - row <- list(paste(names(labels), collapse = ", ")) - } - lapply(row, rep, nrow(labels) %||% length(labels[[1]])) -} - #' @rdname labellers #' @export label_both <- function(labels, multi_line = TRUE, sep = ": ") { value <- label_value(labels, multi_line = multi_line) - variable <- label_variable(labels, multi_line = multi_line) + + if (isTRUE(multi_line)) { + row <- as.list(names(labels)) + } else { + row <- list(paste(names(labels), collapse = ", ")) + } + variable <- lapply(row, rep, nrow(labels) %||% length(labels[[1]])) if (multi_line) { out <- vector("list", length(value)) @@ -173,14 +172,6 @@ label_parsed <- function(labels, multi_line = TRUE) { } class(label_parsed) <- c("function", "labeller") -find_names <- function(expr) { - if (is.call(expr)) { - unlist(lapply(expr[-1], find_names)) - } else if (is.name(expr)) { - as.character(expr) - } -} - #' Label with mathematical expressions #' #' `label_bquote()` offers a flexible way of labelling @@ -320,7 +311,7 @@ as_labeller <- function(x, default = label_value, multi_line = TRUE) { #' #' This function makes it easy to assign different labellers to #' different factors. The labeller can be a function or it can be a -#' named character vectors that will serve as a lookup table. +#' named character vector that will serve as a lookup table. #' #' In case of functions, if the labeller has class `labeller`, it #' is directly applied on the data frame of labels. Otherwise, it is @@ -420,7 +411,7 @@ labeller <- function(..., .rows = NULL, .cols = NULL, keep.as.numeric = deprecated(), .multi_line = TRUE, .default = label_value) { if (lifecycle::is_present(keep.as.numeric)) { - deprecate_warn0("2.0.0", "labeller(keep.as.numeric)") + lifecycle::deprecate_stop("2.0.0", "labeller(keep.as.numeric)") } dots <- list2(...) .default <- as_labeller(.default) @@ -586,22 +577,18 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) { }) } -# Check for old school labeller +# Reject old school labeller check_labeller <- function(labeller) { + labeller <- match.fun(labeller) is_deprecated <- all(c("variable", "value") %in% names(formals(labeller))) - if (is_deprecated) { - old_labeller <- labeller - labeller <- function(labels) { - Map(old_labeller, names(labels), labels) - } - # TODO Update to lifecycle after next lifecycle release - cli::cli_warn(c( - "The {.arg labeller} API has been updated. Labellers taking {.arg variable} and {.arg value} arguments are now deprecated.", - "i" = "See labellers documentation." - )) + if (!is_deprecated) { + return(invisible()) } - labeller + lifecycle::deprecate_stop( + "2.0.0", + what = I("Providing a labeller with `variable` and `value` arguments") + ) } diff --git a/R/labels.R b/R/labels.R index 72c6504732..27c1e96de6 100644 --- a/R/labels.R +++ b/R/labels.R @@ -16,6 +16,101 @@ update_labels <- function(p, labels) { p } +# Called in `ggplot_build()` to set default labels not specified by user. +setup_plot_labels <- function(plot, layers, data) { + # Initiate empty labels + labels <- list() + + # Find labels from every layer + for (i in seq_along(layers)) { + layer <- layers[[i]] + + mapping <- layer$computed_mapping + if (inherits(mapping, "unlabelled_uneval")) { + next + } + + mapping <- strip_stage(mapping) + mapping <- strip_dots(mapping, strip_pronoun = TRUE) + + exclude <- names(layer$aes_params) + mapping <- mapping[setdiff(names(mapping), exclude)] + + # Acquire default labels + mapping_default <- make_labels(mapping) + stat_default <- lapply( + make_labels(layer$stat$default_aes), + function(l) { + attr(l, "fallback") <- TRUE + l + } + ) + default <- defaults(mapping_default, stat_default) + + # Search for label attribute in symbolic mappings + symbolic <- vapply( + mapping, FUN.VALUE = logical(1), + function(x) is_quosure(x) && quo_is_symbol(x) + ) + symbols <- intersect(names(mapping)[symbolic], names(data[[i]])) + attribs <- lapply(setNames(nm = symbols), function(x) { + attr(data[[i]][[x]], "label", exact = TRUE) + }) + attribs <- attribs[lengths(attribs) > 0] + layer_labels <- defaults(attribs, default) + + # Set label priority: + # 1. Existing labels that aren't fallback labels + # 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)) + + labels <- defaults(current[!fallbacks], layer_labels) + if (any(fallbacks)) { + labels <- defaults(labels, current) + } + } + + # 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 + known_labels <- c(names(labels), fn_fmls_names(labs), "x", "y") + extra_labels <- setdiff(names(plot_labels), known_labels) + + if (length(extra_labels) > 0) { + extra_labels <- paste0( + "{.code ", extra_labels, " = \"", plot_labels[extra_labels], "\"}" + ) + names(extra_labels) <- rep("*", length(extra_labels)) + cli::cli_warn(c( + "Ignoring unknown labels:", + extra_labels + )) + } + + # User labels can be functions, so apply these to the default labels + plot_labels <- lapply(setNames(nm = names(plot_labels)), function(nm) { + label <- plot_labels[[nm]] + if (!is.function(label)) { + return(label) + } + label(labels[[nm]] %||% "") + }) + + dict <- plot_labels$dictionary + if (length(dict) > 0) { + labels <- lapply(labels, function(x) { + dict <- dict[names(dict) %in% x] + x[match(names(dict), x)] <- dict + x + }) + } + + defaults(plot_labels, labels) +} + #' Modify axis, legend, and plot labels #' #' Good labels are critical for making your plots accessible to a wider @@ -43,8 +138,14 @@ update_labels <- function(p, labels) { #' bottom-right of the plot by default. #' @param tag The text for the tag label which will be displayed at the #' top-left of the plot by default. +#' @param dictionary A named character vector to serve as dictionary. +#' Automatically derived labels, such as those based on variables will +#' be matched with `names(dictionary)` and replaced by the matching +#' entry in `dictionary`. #' @param alt,alt_insight Text used for the generation of alt-text for the plot. -#' See [get_alt_text] for examples. +#' See [get_alt_text] for examples. `alt` can also be a function that +#' takes the plot as input and returns text as output. `alt` also accepts +#' rlang [lambda][rlang::as_function()] function notation. #' @param ... A list of new name-value pairs. The name should be an aesthetic. #' @export #' @@ -55,6 +156,14 @@ update_labels <- function(p, labels) { #' p + labs(colour = "Cylinders") #' p + labs(x = "New x label") #' +#' # Set labels by variable name instead of aesthetic +#' p + labs(dict = c( +#' disp = "Displacment", # Not in use +#' cyl = "Number of cylinders", +#' mpg = "Miles per gallon", +#' wt = "Weight (1000 lbs)" +#' )) +#' #' # The plot title appears at the top-left, with the subtitle #' # display in smaller text underneath it #' p + labs(title = "New plot title") @@ -73,18 +182,20 @@ update_labels <- function(p, labels) { #' labs(title = "title") + #' labs(title = NULL) labs <- function(..., title = waiver(), subtitle = waiver(), caption = waiver(), - tag = waiver(), alt = waiver(), alt_insight = 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 = alt, alt_insight = alt_insight, .ignore_empty = "all") + tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, + dictionary = dictionary, .ignore_empty = "all") - is_waive <- vapply(args, is.waive, logical(1)) + is_waive <- vapply(args, is.waiver, logical(1)) args <- args[!is_waive] # remove duplicated arguments args <- args[!duplicated(names(args))] args <- rename_aes(args) - structure(args, class = "labels") + structure(args, class = c("labels", "gg")) } #' @rdname labs @@ -110,7 +221,7 @@ ggtitle <- function(label, subtitle = waiver()) { #' @param plot A ggplot object #' @description #' `get_labs()` retrieves completed labels from a plot. -get_labs <- function(plot = last_plot()) { +get_labs <- function(plot = get_last_plot()) { plot <- ggplot_build(plot) labs <- plot$plot$labels @@ -146,7 +257,7 @@ get_labs <- function(plot = last_plot()) { #' text from the information stored in the plot. #' #' @param p a ggplot object -#' @param ... Currently ignored +#' @inheritParams rlang::args_dots_used #' #' @return A text string #' @@ -169,15 +280,25 @@ get_labs <- function(plot = last_plot()) { #' get_alt_text(p) #' get_alt_text <- function(p, ...) { + warn_dots_used() UseMethod("get_alt_text") } #' @export get_alt_text.ggplot <- function(p, ...) { - p$labels[["alt"]] %||% "" + alt <- p$labels[["alt"]] %||% "" + if (!is.function(alt)) { + return(alt) + } + p$labels[["alt"]] <- NULL + build <- ggplot_build(p) + build$plot$labels[["alt"]] <- alt + get_alt_text(build) } #' @export get_alt_text.ggplot_built <- function(p, ...) { - p$plot$labels[["alt"]] %||% "" + alt <- p$plot$labels[["alt"]] %||% "" + p$plot$labels[["alt"]] <- NULL + if (is.function(alt)) alt(p$plot) else alt } #' @export get_alt_text.gtable <- function(p, ...) { @@ -230,36 +351,37 @@ get_alt_text.gtable <- function(p, ...) { #' generate_alt_text <- function(p) { # Combine titles - title <- glue(glue_collapse( - sub("\\.?$", "", c(p$labels$title, p$labels$subtitle)), - last = ": " - ), ". ") - title <- safe_string(title) + if (!is.null(p$label$title %||% p$labels$subtitle)) { + title <- sub("\\.?$", "", c(p$labels$title, p$labels$subtitle)) + if (length(title) == 2) { + title <- paste0(title[1], ": ", title[2]) + } + title <- paste0(title, ". ") + title <- safe_string(title) + } else { + title <- "" + } + # Get axes descriptions - axes <- glue(" showing ", glue_collapse( - c(scale_description(p, "x"), scale_description(p, "y")), - last = " and " - )) + axes <- paste0(" showing ", scale_description(p, "x"), " and ", scale_description(p, "y")) axes <- safe_string(axes) # Get layer types layers <- vapply(p$layers, function(l) snake_class(l$geom), character(1)) layers <- sub("_", " ", sub("^geom_", "", unique0(layers))) - layers <- glue( - " using ", - if (length(layers) == 1) "a " else "", - glue_collapse(layers, sep = ", ", last = " and "), - " layer", - if (length(layers) == 1) "" else "s", - ) + if (length(layers) == 1) { + layers <- paste0(" using a ", layers, " layer") + } else { + layers <- paste0(" using ", oxford_comma(layers), " layers") + } layers <- safe_string(layers) # Combine - alt <- glue_collapse( - c(glue("{title}A plot{axes}{layers}"), p$labels$alt_insight), - last = ". " - ) + alt <- paste0(title, "A plot", axes, layers, ".") + if (!is.null(p$labels$alt_insight)) { + alt <- paste0(alt, " ", p$labels$alt_insight) + } as.character(alt) } safe_string <- function(string) { @@ -279,5 +401,5 @@ scale_description <- function(p, name) { if (is.null(lab)) { return(NULL) } - glue("{lab} on {type} {name}-axis") + paste0(lab, " on ", type, " ", name, "-axis") } diff --git a/R/layer-sf.R b/R/layer-sf.R index 4a1b8e6512..3a282e734f 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -38,10 +38,6 @@ layer_sf <- function(geom = NULL, stat = NULL, LayerSf <- ggproto("LayerSf", Layer, legend_key_type = NULL, - # This field carry state throughout rendering but will always be - # calculated before use - computed_legend_key_type = NULL, - setup_layer = function(self, data, plot) { # process generic layer setup first data <- ggproto_parent(Layer, self)$setup_layer(data, plot) @@ -56,35 +52,29 @@ LayerSf <- ggproto("LayerSf", Layer, self$computed_mapping$geometry <- sym(geometry_col) } } - - # automatically determine the legend type - if (is.null(self$legend_key_type)) { - # first, set default value in case downstream tests fail - self$computed_legend_key_type <- "polygon" - - # now check if the type should not be polygon - if (!is.null(self$computed_mapping$geometry) && quo_is_symbol(self$computed_mapping$geometry)) { - geometry_column <- as_name(self$computed_mapping$geometry) - if (inherits(data[[geometry_column]], "sfc")) { - sf_type <- detect_sf_type(data[[geometry_column]]) - if (sf_type == "point") { - self$computed_legend_key_type <- "point" - } else if (sf_type == "line") { - self$computed_legend_key_type <- "line" - } - } - } - } else { - self$computed_legend_key_type <- self$legend_key_type - } data }, compute_geom_1 = function(self, data) { data <- ggproto_parent(Layer, self)$compute_geom_1(data) + # Determine the legend type + legend_type <- self$legend_key_type + if (is.null(legend_type)) { + legend_type <- switch( + detect_sf_type(data$geometry), + point = "point", line = "line", "other" + ) + } + # Add legend type after computed_geom_params has been calculated - self$computed_geom_params$legend <- self$computed_legend_key_type + self$computed_geom_params$legend <- legend_type data + }, + + compute_geom_2 = function(self, data, params = self$aes_params, ...) { + if (empty(data)) return(data) + data$geometry <- data$geometry %||% self$computed_geom_params$legend + ggproto_parent(Layer, self)$compute_geom_2(data, params, ...) } ) @@ -113,6 +103,9 @@ scale_type.sfc <- function(x) "identity" # helper function to determine the geometry type of sf object detect_sf_type <- function(sf) { + if (is.null(sf)) { + return("other") + } geometry_type <- unique0(as.character(sf::st_geometry_type(sf))) if (length(geometry_type) != 1) geometry_type <- "GEOMETRY" sf_types[geometry_type] diff --git a/R/layer.R b/R/layer.R index 9749f2c1ad..aa2fe997ff 100644 --- a/R/layer.R +++ b/R/layer.R @@ -36,7 +36,7 @@ #' [layer geom][layer_geoms] documentation. #' @param stat The statistical transformation to use on the data for this layer. #' When using a `geom_*()` function to construct a layer, the `stat` -#' argument can be used the override the default coupling between geoms and +#' argument can be used to override the default coupling between geoms and #' stats. The `stat` argument accepts the following: #' * A `Stat` ggproto subclass, for example `StatCount`. #' * A string naming the stat. To give the stat as a string, strip the @@ -58,7 +58,9 @@ #' `NA`, the default, includes if any aesthetics are mapped. #' `FALSE` never includes, and `TRUE` always includes. #' It can also be a named logical vector to finely select the aesthetics to -#' display. +#' display. To include legend keys for all levels, even +#' when no data exists, use `TRUE`. If `NA`, all levels are shown in legend, +#' but unobserved levels are omitted. #' @param inherit.aes If `FALSE`, overrides the default aesthetics, #' rather than combining with them. This is most useful for helper functions #' that define both data and aesthetics and shouldn't inherit behaviour from @@ -69,6 +71,8 @@ #' @param params Additional parameters to the `geom` and `stat`. #' @param key_glyph A legend key drawing function or a string providing the #' function name minus the `draw_key_` prefix. See [draw_key] for details. +#' @param layout Argument to control layout at the layer level. Consult the +#' faceting documentation to view appropriate values. #' @param layer_class The type of layer object to be constructed. This is #' intended for ggplot2 internal use only. #' @keywords internal @@ -96,21 +100,15 @@ 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, layer_class = Layer) { + show.legend = NA, key_glyph = NULL, layout = NULL, layer_class = Layer) { call_env <- caller_env() user_env <- caller_env(2) - if (is.null(geom)) - cli::cli_abort("Can't create layer without a geom.", call = call_env) - if (is.null(stat)) - cli::cli_abort("Can't create layer without a stat.", call = call_env) - if (is.null(position)) - cli::cli_abort("Can't create layer without a position.", call = call_env) # Handle show_guide/show.legend if (!is.null(params$show_guide)) { - deprecate_warn0("2.0.0", "layer(show_guide)", "layer(show.legend)", user_env = user_env) - show.legend <- params$show_guide - params$show_guide <- NULL + lifecycle::deprecate_stop( + "2.0.0", "layer(show_guide)", "layer(show.legend)" + ) } # we validate mapping before data because in geoms and stats @@ -123,35 +121,36 @@ layer <- function(geom = NULL, stat = NULL, data <- fortify(data) - geom <- check_subclass(geom, "Geom", env = parent.frame(), call = call_env) - stat <- check_subclass(stat, "Stat", env = parent.frame(), call = call_env) - position <- check_subclass(position, "Position", env = parent.frame(), call = call_env) + 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) # Special case for na.rm parameter needed by all layers - if (is.null(params$na.rm)) { - params$na.rm <- FALSE - } - - # Special case for key_glyph parameter which is handed in through - # params since all geoms/stats forward ... to params - if (!is.null(params$key_glyph)) { - key_glyph <- params$key_glyph - params$key_glyph <- NULL # remove to avoid warning about unknown parameter - } + 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), geom$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))] - all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics()) + ignore <- c("key_glyph", "name", "layout") + 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)) if (any(pattern)) { aes_params[pattern] <- lapply(aes_params[pattern], list) } + # Drop empty aesthetics + empty_aes <- names(aes_params)[lengths(aes_params) == 0] + if (length(empty_aes) > 0) { + cli::cli_warn( + "Ignoring empty aesthetic{?s}: {.arg {empty_aes}}.", + call = call_env + ) + aes_params <- aes_params[setdiff(names(aes_params), empty_aes)] + } # Warn about extra params and aesthetics extra_param <- setdiff(names(params), all) @@ -159,7 +158,7 @@ layer <- function(geom = NULL, stat = NULL, 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_soft0("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) @@ -167,21 +166,21 @@ layer <- function(geom = NULL, stat = NULL, extra_aes <- setdiff( mapped_aesthetics(mapping), - c(geom$aesthetics(), stat$aesthetics()) + 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)) { extra_aes <- setdiff(extra_aes, "size") - deprecate_soft0("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) } # adjust the legend draw key if requested - geom <- set_draw_key(geom, key_glyph) + geom <- set_draw_key(geom, key_glyph %||% params$key_glyph) - fr_call <- layer_class$constructor %||% frame_call(call_env) + fr_call <- layer_class$constructor %||% frame_call(call_env) %||% current_call() ggproto("LayerInstance", layer_class, constructor = fr_call, @@ -194,7 +193,9 @@ layer <- function(geom = NULL, stat = NULL, aes_params = aes_params, position = position, inherit.aes = inherit.aes, - show.legend = show.legend + show.legend = show.legend, + name = params$name, + layout = layout %||% params$layout ) } @@ -208,6 +209,8 @@ validate_mapping <- function(mapping, call = caller_env()) { } cli::cli_abort(msg, call = call) + } else { + return(mapping) } # For backward compatibility with pre-tidy-eval layers @@ -245,7 +248,7 @@ Layer <- ggproto("Layer", NULL, }, layer_data = function(self, plot_data) { - if (is.waive(self$data)) { + if (is.waiver(self$data)) { data <- plot_data } else if (is.function(self$data)) { data <- self$data(plot_data) @@ -255,7 +258,7 @@ Layer <- ggproto("Layer", NULL, } else { data <- self$data } - if (is.null(data) || is.waive(data)) data else unrowname(data) + if (is.null(data) || is.waiver(data)) data else unrowname(data) }, # hook to allow a layer access to the final layer data @@ -271,13 +274,14 @@ Layer <- ggproto("Layer", NULL, !"linewidth" %in% names(self$computed_mapping) && "linewidth" %in% self$geom$aesthetics()) { self$computed_mapping$size <- plot$mapping$size - deprecate_soft0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`")) + deprecate_warn0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`")) } # defaults() strips class, but it needs to be preserved for now class(self$computed_mapping) <- "uneval" } else { self$computed_mapping <- self$mapping } + attr(data, "layout") <- self$layout data }, @@ -289,8 +293,9 @@ Layer <- ggproto("Layer", NULL, set <- names(aesthetics) %in% names(self$aes_params) calculated <- is_calculated_aes(aesthetics, warn = TRUE) modifiers <- is_scaled_aes(aesthetics) + themed <- is_themed_aes(aesthetics) - aesthetics <- aesthetics[!set & !calculated & !modifiers] + aesthetics <- aesthetics[!set & !calculated & !modifiers & !themed] # Override grouping if set in layer if (!is.null(self$geom_params$group)) { @@ -298,30 +303,21 @@ Layer <- ggproto("Layer", NULL, } # Evaluate aesthetics - env <- child_env(baseenv(), stage = stage) - evaled <- lapply(aesthetics, eval_tidy, data = data, env = env) - evaled <- compact(evaled) - + evaled <- eval_aesthetics(aesthetics, data) plot$scales$add_defaults(evaled, plot$plot_env) # Check for discouraged usage in mapping warn_for_aes_extract_usage(aesthetics, data[setdiff(names(data), "PANEL")]) # Check aesthetic values - nondata_cols <- check_nondata_cols(evaled) - if (length(nondata_cols) > 0) { - issues <- paste0("{.code ", nondata_cols, " = ", as_label(aesthetics[[nondata_cols]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetics are not valid data columns.", - "x" = "The following aesthetics are invalid:", - issues, - "i" = "Did you mistype the name of a data column or forget to add {.fn after_stat}?" - )) - } + check_nondata_cols( + 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}?" + ) n <- nrow(data) - aes_n <- lengths(evaled) + aes_n <- list_sizes(evaled) if (n == 0) { # No data, so look at longest evaluated aesthetic if (length(evaled) == 0) { @@ -346,19 +342,20 @@ Layer <- ggproto("Layer", NULL, } else { evaled$PANEL <- data$PANEL } - evaled <- lapply(evaled, unname) + evaled <- lapply(evaled, vec_set_names, names = NULL) evaled <- as_gg_data_frame(evaled) evaled <- add_group(evaled) evaled }, 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) data <- self$stat$setup_data(data, self$computed_stat_params) - self$stat$compute_layer(data, self$computed_stat_params, layout) + data <- self$stat$compute_layer(data, self$computed_stat_params, layout) + merge_attrs(data, ptype) }, map_statistic = function(self, data, plot) { @@ -381,29 +378,18 @@ Layer <- ggproto("Layer", NULL, data_orig <- plot$scales$backtransform_df(data) # Add map stat output to aesthetics - env <- child_env(baseenv(), stat = stat, after_stat = after_stat) - stage_mask <- child_env(emptyenv(), stage = stage_calculated) - mask <- new_data_mask(as_environment(data_orig, stage_mask), stage_mask) - mask$.data <- as_data_pronoun(mask) - - new <- substitute_aes(new) - stat_data <- lapply(new, eval_tidy, mask, env) - + stat_data <- eval_aesthetics( + substitute_aes(new), data_orig, + mask = list(stage = stage_calculated) + ) # Check that all columns in aesthetic stats are valid data - nondata_stat_cols <- check_nondata_cols(stat_data) - if (length(nondata_stat_cols) > 0) { - issues <- paste0("{.code ", nondata_stat_cols, " = ", as_label(aesthetics[[nondata_stat_cols]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetics must be valid computed stats.", - "x" = "The following aesthetics are invalid:", - issues, - "i" = "Did you map your stat in the wrong layer?" - )) - } + check_nondata_cols( + stat_data, aesthetics, + problem = "Aesthetics must be valid computed stats.", + hint = "Did you map your stat in the wrong layer?" + ) - names(stat_data) <- names(new) - stat_data <- data_frame0(!!!compact(stat_data)) + stat_data <- data_frame0(!!!stat_data) # Add any new scales, if needed plot$scales$add_defaults(stat_data, plot$plot_env) @@ -412,12 +398,14 @@ Layer <- ggproto("Layer", NULL, if (self$stat$retransform) { stat_data <- plot$scales$transform_df(stat_data) } - - cunion(stat_data, data) + stat_data <- cleanup_mismatched_data(stat_data, nrow(data), "after_stat") + data[names(stat_data)] <- stat_data + data }, compute_geom_1 = function(self, data) { if (empty(data)) return(data_frame0()) + ptype <- vec_ptype(data) check_required_aesthetics( self$geom$required_aes, @@ -425,26 +413,28 @@ Layer <- ggproto("Layer", NULL, snake_class(self$geom) ) self$computed_geom_params <- self$geom$setup_params(data, c(self$geom_params, self$aes_params)) - self$geom$setup_data(data, self$computed_geom_params) + data <- self$geom$setup_data(data, self$computed_geom_params) + merge_attrs(data, ptype) }, compute_position = function(self, data, layout) { 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) data <- self$position$setup_data(data, params) - - self$position$compute_layer(data, params, layout) + data <- self$position$compute_layer(data, params, layout) + merge_attrs(data, ptype) }, - compute_geom_2 = function(self, data) { + compute_geom_2 = function(self, data, params = self$aes_params, theme = NULL, ...) { # Combine aesthetics, defaults, & params if (empty(data)) return(data) aesthetics <- self$computed_mapping - modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] + modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics) | is_themed_aes(aesthetics)] - self$geom$use_defaults(data, self$aes_params, modifiers) + self$geom$use_defaults(data, params, modifiers, theme = theme, ...) }, finish_statistics = function(self, data) { @@ -467,24 +457,58 @@ Layer <- ggproto("Layer", NULL, is_layer <- function(x) inherits(x, "Layer") is.layer <- function(x) lifecycle::deprecate_stop("3.5.2", "is.layer()", "is_layer()") -check_subclass <- function(x, subclass, - argname = to_lower_ascii(subclass), - env = parent.frame(), - call = caller_env()) { +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)) { - x - } else if (is_scalar_character(x)) { - name <- paste0(subclass, camelize(x, first = TRUE)) - obj <- find_global(name, env = env) + return(x) + } + if (!is_scalar_character(x)) { + stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object"), arg = x_arg) + } - if (is.null(obj) || !inherits(obj, subclass)) { - cli::cli_abort("Can't find {argname} called {.val {x}}.", call = call) - } else { - obj - } - } else { - stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object")) + # Try getting class object directly + name <- paste0(subclass, camelize(x, first = TRUE)) + obj <- find_global(name, env = env) + if (inherits(obj, subclass)) { + return(obj) + } + + # Try retrieving class via constructors + name <- snakeize(name) + obj <- find_global(name, env = env, mode = "function") + if (is.function(obj)) { + obj <- try_fetch( + obj(), + error = function(cnd) { + # replace `obj()` call with name of actual constructor + cnd$call <- call(name) + cli::cli_abort( + "Failed to retrieve a {.cls {subclass}} object from {.fn {name}}.", + parent = cnd, call = call + ) + }) } + # Position constructors return classes directly + if (inherits(obj, subclass)) { + return(obj) + } + # Try prying the class from a layer + if (inherits(obj, "Layer")) { + obj <- switch( + subclass, + Geom = obj$geom, + Stat = obj$stat, + NULL + ) + } + if (inherits(obj, subclass)) { + return(obj) + } + cli::cli_abort("Can't find {argname} called {.val {x}}.", call = call) } # helper function to adjust the draw_key slot of a geom @@ -501,3 +525,22 @@ set_draw_key <- function(geom, draw_key = NULL) { ggproto("", geom, draw_key = draw_key) } +cleanup_mismatched_data <- function(data, n, fun) { + if (vec_duplicate_any(names(data))) { + data <- data[unique0(names(data))] + } + + failed <- !lengths(data) %in% c(0, 1, n) + if (!any(failed)) { + return(data) + } + + failed <- names(data)[failed] + cli::cli_warn( + "Failed to apply {.fn {fun}} for the following \\ + aesthetic{?s}: {.field {failed}}." + ) + + data[failed] <- NULL + data +} diff --git a/R/layout.R b/R/layout.R index 41efa7e828..23048609dc 100644 --- a/R/layout.R +++ b/R/layout.R @@ -80,19 +80,8 @@ Layout <- ggproto("Layout", NULL, panels <- lapply(seq_along(panels[[1]]), function(i) { panel <- lapply(panels, `[[`, i) panel <- c(facet_bg[i], panel, facet_fg[i]) - - coord_fg <- self$coord$render_fg(self$panel_params[[i]], theme) - coord_bg <- self$coord$render_bg(self$panel_params[[i]], theme) - if (isTRUE(theme$panel.ontop)) { - panel <- c(panel, list(coord_bg), list(coord_fg)) - } else { - panel <- c(list(coord_bg), panel, list(coord_fg)) - } - - ggname( - paste("panel", i, sep = "-"), - gTree(children = inject(gList(!!!panel))) - ) + panel <- self$coord$draw_panel(panel, self$panel_params[[i]], theme) + ggname(paste("panel", i, sep = "-"), panel) }) plot_table <- self$facet$draw_panels( panels, @@ -105,6 +94,7 @@ Layout <- ggproto("Layout", NULL, theme, self$facet_params ) + plot_table <- self$facet$set_panel_size(plot_table, theme) # Draw individual labels, then add to gtable labels <- self$coord$labels( @@ -212,20 +202,35 @@ Layout <- ggproto("Layout", NULL, # scales is not elegant, but it is pragmatic self$coord$modify_scales(self$panel_scales_x, self$panel_scales_y) - scales_x <- self$panel_scales_x[self$layout$SCALE_X] - scales_y <- self$panel_scales_y[self$layout$SCALE_Y] + # We only need to setup panel params once for unique combinations of x/y + # scales. These will be repeated for duplicated combinations. + index <- vec_unique_loc(self$layout$COORD) + order <- vec_match(self$layout$COORD, self$layout$COORD[index]) - setup_panel_params <- function(scale_x, scale_y) { - self$coord$setup_panel_params(scale_x, scale_y, params = self$coord_params) - } - self$panel_params <- Map(setup_panel_params, scales_x, scales_y) + scales_x <- self$panel_scales_x[self$layout$SCALE_X[index]] + scales_y <- self$panel_scales_y[self$layout$SCALE_Y[index]] + + panel_params <- Map( + self$coord$setup_panel_params, + scales_x, scales_y, + MoreArgs = list(params = self$coord_params) + )[order] # `[order]` does the repeating + + # Let Facet modify `panel_params` for each panel + self$panel_params <- self$facet$setup_panel_params(panel_params, self$coord) invisible() }, 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) + order <- vec_match(self$layout$COORD, self$layout$COORD[index]) + self$panel_params <- lapply( - self$panel_params, + self$panel_params[index], self$coord$setup_panel_guides, guides, self$coord_params @@ -236,41 +241,45 @@ Layout <- ggproto("Layout", NULL, self$coord$train_panel_guides, layers, self$coord_params - ) + )[order] invisible() }, resolve_label = function(self, scale, labels) { - # General order is: guide title > scale name > labels - aes <- scale$aesthetics[[1]] - primary <- scale$name %|W|% labels[[aes]] - secondary <- if (is.null(scale$secondary.axis)) { - waiver() - } else { - scale$sec_name() - } %|W|% labels[[paste0("sec.", aes)]] - if (is.derived(secondary)) secondary <- primary + aes <- scale$aesthetics[[1]] + + prim_scale <- scale$name + seco_scale <- (scale$sec_name %||% waiver)() + + prim_label <- labels[[aes]] + seco_label <- labels[[paste0("sec. aes")]] + + prim_guide <- seco_guide <- waiver() + order <- scale$axis_order() - if (!is.null(self$panel_params[[1]]$guides)) { - if ((scale$position) %in% c("left", "right")) { - guides <- c("y", "y.sec") - } else { - guides <- c("x", "x.sec") - } - params <- self$panel_params[[1]]$guides$get_params(guides) + panel <- self$panel_params[[1]]$guides + if (!is.null(panel)) { + position <- scale$position + aes <- switch(position, left = , right = "y", "x") + params <- panel$get_params(paste0(aes, c("", ".sec"))) if (!is.null(params)) { - primary <- params[[1]]$title %|W|% primary - secondary <- params[[2]]$title %|W|% secondary - position <- params[[1]]$position %||% scale$position - if (position != scale$position) { + prim_guide <- params[[1]]$title + seco_guide <- params[[2]]$title + position <- scale$position + if ((params[[1]]$position %||% position) != position) { order <- rev(order) } } } - primary <- scale$make_title(primary) - secondary <- scale$make_sec_title(secondary) + + 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 + } + list(primary = primary, secondary = secondary)[order] }, @@ -282,7 +291,7 @@ Layout <- ggproto("Layout", NULL, } else { switch(label, x = ".bottom", y = ".right") } - if (is.null(labels[[label]][[i]]) || is.waive(labels[[label]][[i]])) + if (is.null(labels[[label]][[i]]) || is.waiver(labels[[label]][[i]])) return(zeroGrob()) element_render( @@ -299,7 +308,6 @@ Layout <- ggproto("Layout", NULL, } ) - # Helpers ----------------------------------------------------------------- # Function for applying scale method to multiple variables in a given @@ -317,7 +325,7 @@ scale_apply <- function(data, vars, method, scale_id, scales) { lapply(vars, function(var) { pieces <- lapply(seq_along(scales), function(i) { - scales[[i]][[method]](data[[var]][scale_index[[i]]]) + scales[[i]][[method]](vec_slice(data[[var]], scale_index[[i]])) }) # Remove empty vectors to avoid coercion issues with vctrs pieces[lengths(pieces) == 0] <- NULL diff --git a/R/legend-draw.R b/R/legend-draw.R index f1de0b80e5..04276dd471 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -24,23 +24,16 @@ NULL #' @export #' @rdname draw_key draw_key_point <- function(data, params, size) { - if (is.null(data$shape)) { - data$shape <- 19 - } else if (is.character(data$shape)) { - data$shape <- translate_shape_string(data$shape) - } + data$shape <- translate_shape_string(data$shape %||% 19) # NULL means the default stroke size, and NA means no stroke. - stroke_size <- data$stroke %||% 0.5 - stroke_size[is.na(stroke_size)] <- 0 - pointsGrob(0.5, 0.5, pch = data$shape, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% "black", data$alpha), fill = fill_alpha(data$fill %||% "black", data$alpha), - fontsize = (data$size %||% 1.5) * .pt + stroke_size * .stroke / 2, - lwd = stroke_size * .stroke / 2 + pointsize = data$size %||% 1.5, + stroke = data$stroke %||% 0.5 ) ) } @@ -49,9 +42,9 @@ draw_key_point <- function(data, params, size) { #' @rdname draw_key draw_key_abline <- function(data, params, size) { segmentsGrob(0, 0, 1, 1, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt" ) @@ -61,32 +54,36 @@ draw_key_abline <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_rect <- function(data, params, size) { - rectGrob(gp = gpar( + colour <- if (is.na(data$fill %||% NA)) data$colour + rectGrob(gp = gg_par( col = NA, - fill = fill_alpha(data$fill %||% data$colour %||% "grey20", data$alpha), + fill = fill_alpha(colour %||% "grey20", data$alpha), lty = data$linetype %||% 1 )) } #' @export #' @rdname draw_key draw_key_polygon <- function(data, params, size) { - if (is.null(data$linewidth)) { - data$linewidth <- 0.5 - } - lwd <- min(data$linewidth, min(size) / 4) + lwd <- data$linewidth %||% 0 - rectGrob( + grob <- rectGrob( width = unit(1, "npc") - unit(lwd, "mm"), height = unit(1, "npc") - unit(lwd, "mm"), - gp = gpar( + gp = gg_par( col = data$colour %||% NA, fill = fill_alpha(data$fill %||% "grey20", data$alpha), lty = data$linetype %||% 1, - lwd = lwd * .pt, + 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, "height") <- lwd / 5 + grob } #' @export @@ -98,29 +95,58 @@ draw_key_blank <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_boxplot <- function(data, params, size) { - gp <- gpar( + gp <- gg_par( col = data$colour %||% "grey20", fill = fill_alpha(data$fill %||% "white", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt", linejoin = params$linejoin %||% "mitre" ) + whisker <- gg_par( + col = params$whisker_gp$colour, + lty = params$whisker_gp$linetype, + lwd = params$whisker_gp$linewidth + ) + + median <- gg_par( + col = params$median_gp$colour, + lty = params$median_gp$linetype, + lwd = params$median_gp$linewidth + ) + + box <- gg_par( + col = params$box_gp$colour, + lty = params$box_gp$linetype, + lwd = params$box_gp$linewidth + ) + + staple_size <- 0.5 + c(0.375, -0.375) * (params$staplewidth %||% 0) + staple <- gg_par( + col = params$staple_gp$colour, + lty = params$staple_gp$linetype, + lwd = params$staple_gp$linewidth + ) + if (isTRUE(params$flipped_aes)) { grobTree( - linesGrob(c(0.1, 0.25), 0.5), - linesGrob(c(0.75, 0.9), 0.5), - rectGrob(width = 0.5, height = 0.75), - linesGrob(0.5, c(0.125, 0.875)), + linesGrob(c(0.1, 0.25), 0.5, gp = whisker), + linesGrob(c(0.75, 0.9), 0.5, gp = whisker), + rectGrob(width = 0.5, height = 0.75, gp = box), + linesGrob(0.5, c(0.125, 0.875), gp = median), + linesGrob(0.1, staple_size, gp = staple), + linesGrob(0.9, staple_size, gp = staple), gp = gp ) } else { grobTree( - linesGrob(0.5, c(0.1, 0.25)), - linesGrob(0.5, c(0.75, 0.9)), - rectGrob(height = 0.5, width = 0.75), - linesGrob(c(0.125, 0.875), 0.5), + linesGrob(0.5, c(0.1, 0.25), gp = whisker), + linesGrob(0.5, c(0.75, 0.9), gp = whisker), + rectGrob(height = 0.5, width = 0.75, gp = box), + linesGrob(c(0.125, 0.875), 0.5, gp = median), + linesGrob(staple_size, 0.1, gp = staple), + linesGrob(staple_size, 0.9, gp = staple), gp = gp ) } @@ -129,24 +155,38 @@ draw_key_boxplot <- function(data, params, size) { #' @export #' @rdname draw_key draw_key_crossbar <- function(data, params, size) { - gp <- gpar( + gp <- gg_par( col = data$colour %||% "grey20", fill = fill_alpha(data$fill %||% "white", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt", linejoin = params$linejoin %||% "mitre" ) + + middle <- gg_par( + col = params$middle_gp$colour, + lty = params$middle_gp$linetype, + lwd = params$middle_gp$linewidth + ) + + box <- gg_par( + col = params$box_gp$colour, + lty = params$box_gp$linetype, + lwd = params$box_gp$linewidth + ) + + if (isTRUE(params$flipped_aes)) { grobTree( - rectGrob(height = 0.75, width = 0.5), - linesGrob(0.5, c(0.125, 0.875)), + rectGrob(height = 0.75, width = 0.5, gp = box), + linesGrob(0.5, c(0.125, 0.875), gp = middle), gp = gp ) } else { grobTree( - rectGrob(height = 0.5, width = 0.75), - linesGrob(c(0.125, 0.875), 0.5), + rectGrob(height = 0.5, width = 0.75, gp = box), + linesGrob(c(0.125, 0.875), 0.5, gp = middle), gp = gp ) } @@ -157,15 +197,13 @@ draw_key_crossbar <- function(data, params, size) { draw_key_path <- function(data, params, size) { if (is.null(data$linetype)) { data$linetype <- 0 - } else { - data$linetype[is.na(data$linetype)] <- 0 } grob <- segmentsGrob(0.1, 0.5, 0.9, 0.5, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), fill = alpha(params$arrow.fill %||% data$colour %||% data$fill %||% "black", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt" ), @@ -184,9 +222,9 @@ draw_key_path <- function(data, params, size) { #' @rdname draw_key draw_key_vpath <- function(data, params, size) { grob <- segmentsGrob(0.5, 0.1, 0.5, 0.9, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt" ), @@ -204,9 +242,9 @@ 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(.5, "npc"), + pointsGrob(0.5, 0.5, size = unit(0.5, "npc"), pch = 21, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% "black", data$alpha), fill = fill_alpha(data$fill %||% "black", data$alpha), lty = data$linetype %||% 1, @@ -247,7 +285,7 @@ draw_key_smooth <- function(data, params, size) { path <- draw_key_path(data, params, size) grob <- grobTree( - if (isTRUE(params$se)) rectGrob(gp = gpar(col = NA, fill = data$fill)), + if (isTRUE(params$se)) rectGrob(gp = gg_par(col = NA, fill = data$fill)), path ) attr(grob, "width") <- attr(path, "width") @@ -268,13 +306,13 @@ draw_key_text <- function(data, params, size) { angle = data$angle, hjust = hjust, vjust = vjust, - gp = gpar( + 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 ), - margin = margin(0.1, 0.1, 0.1, 0.1, unit = "lines"), + margin = margin_auto(0.1, unit = "lines"), margin_x = TRUE, margin_y = TRUE ) attr(grob, "width") <- convertWidth(grobWidth(grob), "cm", valueOnly = TRUE) @@ -286,7 +324,6 @@ draw_key_text <- function(data, params, size) { #' @rdname draw_key draw_key_label <- function(data, params, size) { data <- replace_null(unclass(data), label = "a", angle = 0) - params$label.size <- params$label.size %||% 0.25 hjust <- compute_just(data$hjust %||% 0.5) vjust <- compute_just(data$vjust %||% 0.5) just <- rotate_just(data$angle, hjust, vjust) @@ -296,6 +333,7 @@ draw_key_label <- function(data, params, size) { face = data$fontface %||% 1, size = data$size %||% 3.88 ) + lwd <- data$linewidth %||% 0.25 grob <- labelGrob( data$label, x = unit(just$hjust, "npc"), @@ -304,16 +342,17 @@ draw_key_label <- function(data, params, size) { just = c(hjust, vjust), padding = padding, r = params$label.r %||% unit(0.15, "lines"), - text.gp = gpar( - col = data$colour %||% "black", + text.gp = gg_par( + col = params$text.colour %||% data$colour %||% "black", fontfamily = data$family %||% "", fontface = data$fontface %||% 1, fontsize = (data$size %||% 3.88) * .pt ), - rect.gp = gpar( - col = if (isTRUE(all.equal(params$label.size, 0))) NA else data$colour, + rect.gp = gg_par( + col = if (isTRUE(all.equal(lwd, 0))) NA else params$border.colour %||% data$colour %||% "black", fill = alpha(data$fill %||% "white", data$alpha), - lwd = params$label.size * .pt + lwd = lwd, + lty = data$linetype %||% 1L ) ) angle <- deg2rad(data$angle %||% 0) @@ -331,9 +370,9 @@ draw_key_label <- function(data, params, size) { #' @rdname draw_key draw_key_vline <- function(data, params, size) { segmentsGrob(0.5, 0, 0.5, 1, - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt" ) @@ -345,16 +384,14 @@ draw_key_vline <- function(data, params, size) { draw_key_timeseries <- function(data, params, size) { if (is.null(data$linetype)) { data$linetype <- 0 - } else { - data$linetype[is.na(data$linetype)] <- 0 } grid::linesGrob( x = c(0, 0.4, 0.6, 1), y = c(0.1, 0.6, 0.4, 0.9), - gp = gpar( + gp = gg_par( col = alpha(data$colour %||% data$fill %||% "black", data$alpha), - lwd = (data$linewidth %||% 0.5) * .pt, + lwd = data$linewidth %||% 0.5, lty = data$linetype %||% 1, lineend = params$lineend %||% "butt", linejoin = params$linejoin %||% "round" diff --git a/R/limits.R b/R/limits.R index 26528ee7ff..57f2465018 100644 --- a/R/limits.R +++ b/R/limits.R @@ -4,7 +4,9 @@ #' scales. By default, any values outside the limits specified are replaced with #' `NA`. Be warned that this will remove data outside the limits and this can #' produce unintended results. For changing x or y axis limits \strong{without} -#' dropping data observations, see [coord_cartesian()]. +#' dropping data observations, see +#' [`coord_cartesian(xlim, ylim)`][coord_cartesian], or use a full scale with +#' [`oob = scales::oob_keep`][scales::oob_keep]. #' #' @param ... For `xlim()` and `ylim()`: Two numeric values, specifying the left/lower #' limit and the right/upper limit of the scale. If the larger value is given first, @@ -80,7 +82,7 @@ lims <- function(...) { args <- list2(...) - if (!all(has_name(args))) { + if (!is_named2(args)) { cli::cli_abort("All arguments must be named.") } env <- current_env() @@ -113,10 +115,8 @@ ylim <- function(...) { limits <- function(lims, var, call = caller_env()) UseMethod("limits") #' @export limits.numeric <- function(lims, var, call = caller_env()) { - if (length(lims) != 2) { - cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call) - } - if (!any(is.na(lims)) && lims[1] > lims[2]) { + check_length(lims, 2L, arg = var, call = call) + if (!anyNA(lims) && lims[1] > lims[2]) { trans <- "reverse" } else { trans <- "identity" @@ -143,23 +143,17 @@ limits.factor <- function(lims, var, call = caller_env()) { } #' @export limits.Date <- function(lims, var, call = caller_env()) { - if (length(lims) != 2) { - cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call) - } + check_length(lims, 2L, arg = var, call = call) make_scale("date", var, limits = lims, call = call) } #' @export limits.POSIXct <- function(lims, var, call = caller_env()) { - if (length(lims) != 2) { - cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call) - } + check_length(lims, 2L, arg = var, call = call) make_scale("datetime", var, limits = lims, call = call) } #' @export limits.POSIXlt <- function(lims, var, call = caller_env()) { - if (length(lims) != 2) { - cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call) - } + check_length(lims, 2L, arg = var, call = call) make_scale("datetime", var, limits = as.POSIXct(lims), call = call) } diff --git a/R/margins.R b/R/margins.R index 916c691a61..8eb99bb691 100644 --- a/R/margins.R +++ b/R/margins.R @@ -11,11 +11,23 @@ margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { #' @export #' @rdname is_tests -is_margin <- function(x) { - inherits(x, "margin") -} +is_margin <- function(x) inherits(x, "margin") + is.margin <- function(x) lifecycle::deprecate_stop("3.5.2", "is.margin()", "is_margin()") +#' @rdname element +#' @export +margin_part <- function(t = NA, r = NA, b = NA, l = NA, unit = "pt") { + margin(t = t, r = r, b = b, l = l, unit = unit) +} + + +#' @rdname element +#' @export +margin_auto <- function(t = 0, r = t, b = t, l = r, unit = "pt") { + margin(t = t, r = r, b = b, l = l, unit) +} + #' Create a text grob with the proper location and margins #' #' `titleGrob()` is called when creating titles and labels for axes, legends, @@ -128,9 +140,9 @@ titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), rectGrob( x = x, y = y, width = width, height = height, hjust = just$hjust, vjust = just$vjust, - gp = gpar(fill = "cornsilk", col = NA) + gp = gg_par(fill = "cornsilk", col = NA) ), - pointsGrob(x, y, pch = 20, gp = gpar(col = "gold")), + pointsGrob(x, y, pch = 20, gp = gg_par(col = "gold")), grob ) } else { @@ -155,82 +167,6 @@ heightDetails.titleGrob <- function(x) { sum(x$heights) } -#' Justifies a grob within a larger drawing area -#' -#' `justify_grobs()` can be used to take one or more grobs and draw them justified inside a larger -#' drawing area, such as the cell in a gtable. It is needed to correctly place [`titleGrob`]s -#' with margins. -#' -#' @param grobs The single grob or list of grobs to justify. -#' @param x,y x and y location of the reference point relative to which justification -#' should be performed. If `NULL`, justification will be done relative to the -#' enclosing drawing area (i.e., `x = hjust` and `y = vjust`). -#' @param hjust,vjust Horizontal and vertical justification of the grob relative to `x` and `y`. -#' @param int_angle Internal angle of the grob to be justified. When justifying a text -#' grob with rotated text, this argument can be used to make `hjust` and `vjust` operate -#' relative to the direction of the text. -#' @param debug If `TRUE`, aids visual debugging by drawing a solid -#' rectangle behind the complete grob area. -#' -#' @noRd -justify_grobs <- function(grobs, x = NULL, y = NULL, hjust = 0.5, vjust = 0.5, - int_angle = 0, debug = FALSE) { - if (!inherits(grobs, "grob")) { - if (is.list(grobs)) { - return(lapply(grobs, justify_grobs, x, y, hjust, vjust, int_angle, debug)) - } - else { - stop_input_type(grobs, as_cli("an individual {.cls grob} or list of {.cls grob} objects")) - } - } - - if (inherits(grobs, "zeroGrob")) { - return(grobs) - } - - # adjust hjust and vjust according to internal angle - just <- rotate_just(int_angle, hjust, vjust) - - x <- x %||% unit(just$hjust, "npc") - y <- y %||% unit(just$vjust, "npc") - - - if (isTRUE(debug)) { - children <- gList( - rectGrob(gp = gpar(fill = "lightcyan", col = NA)), - grobs - ) - } - else { - children = gList(grobs) - } - - - result_grob <- gTree( - children = children, - vp = viewport( - x = x, - y = y, - width = grobWidth(grobs), - height = grobHeight(grobs), - just = unlist(just) - ) - ) - - - if (isTRUE(debug)) { - #cat("x, y:", c(x, y), "\n") - #cat("E - hjust, vjust:", c(hjust, vjust), "\n") - grobTree( - result_grob, - pointsGrob(x, y, pch = 20, gp = gpar(col = "mediumturquoise")) - ) - } else { - result_grob - } -} - - #' Rotate justification parameters counter-clockwise #' #' @param angle angle of rotation, in degrees @@ -311,7 +247,7 @@ font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { if (is.null(descent)) { descent <- convertHeight(grobDescent(textGrob( label = "gjpqyQ", - gp = gpar( + gp = gg_par( fontsize = size, cex = cex, fontfamily = family, diff --git a/R/performance.R b/R/performance.R index b26b1a7072..7676ed31d6 100644 --- a/R/performance.R +++ b/R/performance.R @@ -10,13 +10,6 @@ mat_2_df <- function(x, col_names = colnames(x)) { data_frame0(!!!cols, .size = nrow(x)) } -df_col <- function(x, name) .subset2(x, name) - -df_rows <- function(x, i) { - cols <- lapply(x, `[`, i = i) - data_frame0(!!!cols, .size = length(i)) -} - # More performant modifyList without recursion modify_list <- function(old, new) { for (i in names(new)) old[[i]] <- new[[i]] diff --git a/R/plot-build.R b/R/plot-build.R index 6222c6e114..24644951c2 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -5,15 +5,15 @@ #' a list of data frames (one for each layer), and a panel object, which #' contain all information about axis limits, breaks etc. #' -#' `layer_data()`, `layer_grob()`, and `layer_scales()` are helper +#' `get_layer_data()`, `get_layer_grob()`, and `get_panel_scales()` are helper #' functions that return the data, grob, or scales associated with a given #' layer. These are useful for tests. #' #' @param plot ggplot object -#' @param i An integer. In `layer_data()`, the data to return (in the order added to the -#' plot). In `layer_grob()`, the grob to return (in the order added to the -#' plot). In `layer_scales()`, the row of a facet to return scales for. -#' @param j An integer. In `layer_scales()`, the column of a facet to return +#' @param i An integer. In `get_layer_data()`, the data to return (in the order added to the +#' plot). In `get_layer_grob()`, the grob to return (in the order added to the +#' plot). In `get_panel_scales()`, the row of a facet to return scales for. +#' @param j An integer. In `get_panel_scales()`, the column of a facet to return #' scales for. #' @seealso #' [print.ggplot()] and [benchplot()] for @@ -60,6 +60,7 @@ ggplot_build.ggplot <- function(plot) { # Compute aesthetics to produce data with generalised variable names 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) # Transform all scales @@ -99,11 +100,15 @@ ggplot_build.ggplot <- function(plot) { # Hand off position guides to layout layout$setup_panel_guides(plot$guides, plot$layers) + # Complete the plot's theme + plot$theme <- plot_theme(plot) + # Train and map non-position scales and guides npscales <- scales$non_position_scales() 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$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 @@ -112,7 +117,10 @@ ggplot_build.ggplot <- function(plot) { data <- .expose_data(data) # Fill in defaults etc. - data <- by_layer(function(l, d) l$compute_geom_2(d), layers, data, "setting up geom aesthetics") + data <- by_layer( + function(l, d) l$compute_geom_2(d, theme = plot$theme), + 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") @@ -131,13 +139,16 @@ ggplot_build.ggplot <- function(plot) { #' @export #' @rdname ggplot_build -layer_data <- function(plot = last_plot(), i = 1L) { +get_layer_data <- function(plot = get_last_plot(), i = 1L) { ggplot_build(plot)$data[[i]] } +#' @export +#' @rdname ggplot_build +layer_data <- get_layer_data #' @export #' @rdname ggplot_build -layer_scales <- function(plot = last_plot(), i = 1L, j = 1L) { +get_panel_scales <- function(plot = get_last_plot(), i = 1L, j = 1L) { b <- ggplot_build(plot) layout <- b$layout$layout @@ -151,12 +162,20 @@ layer_scales <- function(plot = last_plot(), i = 1L, j = 1L) { #' @export #' @rdname ggplot_build -layer_grob <- function(plot = last_plot(), i = 1L) { +layer_scales <- get_panel_scales + +#' @export +#' @rdname ggplot_build +get_layer_grob <- function(plot = get_last_plot(), i = 1L) { b <- ggplot_build(plot) b$plot$layers[[i]]$draw_geom(b$data[[i]], b$layout) } +#' @export +#' @rdname ggplot_build +layer_grob <- get_layer_grob + #' Build a plot with all the usual bits and pieces. #' #' This function builds all grobs necessary for displaying the plot, and @@ -187,7 +206,7 @@ ggplot_gtable.ggplot_built <- function(data) { plot <- data$plot layout <- data$layout data <- data$data - theme <- plot_theme(plot) + theme <- plot$theme geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot$layers, data, "converting geom to grob") @@ -238,18 +257,18 @@ ggplot_gtable.ggplot_built <- function(data) { 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) + title_l <- min(pans$l) + title_r <- max(pans$r) } else { - title_l = 1 - title_r = ncol(plot_table) + title_l <- 1 + title_r <- ncol(plot_table) } if (caption_pos == "panel") { - caption_l = min(pans$l) - caption_r = max(pans$r) + caption_l <- min(pans$l) + caption_r <- max(pans$r) } else { - caption_l = 1 - caption_r = ncol(plot_table) + caption_l <- 1 + caption_r <- ncol(plot_table) } plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0) @@ -267,10 +286,8 @@ ggplot_gtable.ggplot_built <- function(data) { plot_table <- table_add_tag(plot_table, plot$labels$tag, theme) # Margins - plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0) - plot_table <- gtable_add_cols(plot_table, theme$plot.margin[2]) - plot_table <- gtable_add_rows(plot_table, theme$plot.margin[3]) - plot_table <- gtable_add_cols(plot_table, theme$plot.margin[4], pos = 0) + plot_margin <- calc_element("plot.margin", theme) %||% margin() + plot_table <- gtable_add_padding(plot_table, plot_margin) if (is_theme_element(theme$plot.background)) { plot_table <- gtable_add_grob(plot_table, @@ -295,6 +312,12 @@ ggplotGrob <- function(x) { ggplot_gtable(ggplot_build(x)) } +#' @export +as.gtable.ggplot <- function(x, ...) ggplotGrob(x) + +#' @export +as.gtable.ggplot_built <- function(x, ...) ggplot_gtable(x) + # Apply function to layer and matching data by_layer <- function(f, layers, data, step = NULL) { ordinal <- label_ordinal() @@ -342,13 +365,10 @@ table_add_tag <- function(table, label, theme) { ), call = expr(theme())) } - if (length(position) != 2) { - cli::cli_abort(paste0( - "A {.cls numeric} {.arg plot.tag.position} ", - "theme setting must have length 2." - ), - call = expr(theme())) - } + check_length( + position, 2L, call = expr(theme()), + arg = I("A {.cls numeric} {.arg plot.tag.position}") + ) top <- left <- right <- bottom <- FALSE } else { # Break position into top/left/right/bottom @@ -392,11 +412,10 @@ table_add_tag <- function(table, label, theme) { x <- unit(position[1], "npc") y <- unit(position[2], "npc") } - # Do manual placement of tag - tag <- justify_grobs( - tag, x = x, y = y, - hjust = element$hjust, vjust = element$vjust, - int_angle = element$angle, debug = element$debug + # Re-render with manual positions + tag <- element_grob( + element, x = x, y = y, label = label, + margin_y = TRUE, margin_x = TRUE ) if (location == "plot") { table <- gtable_add_grob( @@ -449,7 +468,7 @@ table_add_legends <- function(table, legends, theme) { empty <- vapply(legends, is.zero, logical(1)) widths[!empty] <- lapply(legends[!empty], gtable_width) heights[!empty] <- lapply(legends[!empty], gtable_height) - spacing <- theme$legend.box.spacing %||% unit(0.2, "cm") + 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") diff --git a/R/plot-construction.R b/R/plot-construction.R index 535b2e9563..b10a9f4387 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -84,9 +84,32 @@ add_ggplot <- function(p, object, objectname) { #' @param object_name The name of the object to add #' #' @return A modified ggplot object +#' @details +#' Custom methods for `ggplot_add()` are intended to update the `plot` variable +#' using information from a custom `object`. This can become convenient when +#' writing extensions that don't build on the pre-existing grammar like +#' layers, facets, coords and themes. The `ggplot_add()` function is never +#' intended to be used directly, but it is triggered when an object is added +#' to a plot via the `+` operator. Please note that the full `plot` object is +#' exposed at this point, which comes with the responsibility of returning +#' the plot intact. #' #' @keywords internal #' @export +#' @examples +#' # making a new method for the generic +#' # in this example, we apply a text element to the text theme setting +#' ggplot_add.element_text <- function(object, plot, object_name) { +#' plot + theme(text = object) +#' } +#' +#' # we can now use `+` to add our object to a plot +#' ggplot(mpg, aes(displ, cty)) + +#' geom_point() + +#' element_text(colour = "red") +#' +#' # clean-up +#' rm(ggplot_add.element_text) ggplot_add <- function(object, plot, object_name) { UseMethod("ggplot_add") } @@ -126,17 +149,23 @@ ggplot_add.labels <- function(object, plot, object_name) { } #' @export ggplot_add.Guides <- function(object, plot, object_name) { - update_guides(plot, object) + if (is_guides(plot$guides)) { + # We clone the guides object to prevent modify-in-place of guides + old <- plot$guides + new <- ggproto(NULL, old) + new$add(object) + plot$guides <- new + } else { + plot$guides <- object + } + plot } #' @export ggplot_add.uneval <- function(object, plot, object_name) { plot$mapping <- defaults(object, plot$mapping) # defaults() doesn't copy class, so copy it. class(plot$mapping) <- class(object) - - labels <- make_labels(object) - names(labels) <- names(object) - update_labels(plot, labels) + plot } #' @export ggplot_add.Coord <- function(object, plot, object_name) { @@ -155,7 +184,7 @@ ggplot_add.Facet <- function(object, plot, object_name) { #' @export ggplot_add.list <- function(object, plot, object_name) { for (o in object) { - plot <- plot %+% o + plot <- ggplot_add(o, plot, object_name) } plot } @@ -166,20 +195,32 @@ ggplot_add.by <- function(object, plot, object_name) { #' @export ggplot_add.Layer <- function(object, plot, object_name) { + layers_names <- new_layer_names(object, names2(plot$layers)) plot$layers <- append(plot$layers, object) + names(plot$layers) <- layers_names + plot +} + +new_layer_names <- function(layer, existing) { - # Add any new labels - mapping <- make_labels(object$mapping) - default <- lapply(make_labels(object$stat$default_aes), function(l) { - attr(l, "fallback") <- TRUE - l - }) - new_labels <- defaults(mapping, default) - current_labels <- plot$labels - current_fallbacks <- vapply(current_labels, function(l) isTRUE(attr(l, "fallback")), logical(1)) - plot$labels <- defaults(current_labels[!current_fallbacks], new_labels) - if (any(current_fallbacks)) { - plot$labels <- defaults(plot$labels, current_labels) + empty <- !nzchar(existing) + if (any(empty)) { + existing[empty] <- "unknown" + existing <- vec_as_names(existing, repair = "unique", quiet = TRUE) } - plot + + new_name <- layer$name + if (is.null(new_name)) { + # Construct a name from the layer's call + new_name <- call_name(layer$constructor) %||% snake_class(layer$geom) + + if (new_name %in% existing) { + names <- c(existing, new_name) + names <- vec_as_names(names, repair = "unique", quiet = TRUE) + new_name <- names[length(names)] + } + } + + names <- c(existing, new_name) + vec_as_names(names, repair = "check_unique") } diff --git a/R/plot-last.R b/R/plot-last.R index 81f15d57aa..3a67f978ba 100644 --- a/R/plot-last.R +++ b/R/plot-last.R @@ -21,4 +21,8 @@ set_last_plot <- function(value) .store$set(value) #' @seealso [ggsave()] #' @export #' @keywords internal -last_plot <- function() .store$get() +get_last_plot <- function() .store$get() + +#' @export +#' @rdname get_last_plot +last_plot <- get_last_plot diff --git a/R/plot.R b/R/plot.R index f586311836..5f38f63116 100644 --- a/R/plot.R +++ b/R/plot.R @@ -130,11 +130,10 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., coordinates = coord_cartesian(default = TRUE), facet = facet_null(), plot_env = environment, - layout = ggproto(NULL, Layout) + layout = ggproto(NULL, Layout), + labels = list() ), class = c("gg", "ggplot")) - p$labels <- make_labels(mapping) - set_last_plot(p) p } @@ -187,18 +186,17 @@ is.ggplot <- function(x) { #' @export #' @method print ggplot #' @examples -#' colours <- list(~class, ~drv, ~fl) +#' colours <- c("class", "drv", "fl") #' #' # Doesn't seem to do anything! #' for (colour in colours) { -#' ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + +#' ggplot(mpg, aes(displ, hwy, colour = .data[[colour]])) + #' geom_point() #' } #' -#' # Works when we explicitly print the plots #' for (colour in colours) { -#' print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + -#' geom_point()) +#' print(ggplot(mpg, aes(displ, hwy, colour = .data[[colour]])) + +#' geom_point()) #' } print.ggplot <- function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) diff --git a/R/position-.R b/R/position-.R index c731f2b3cc..fb339b6660 100644 --- a/R/position-.R +++ b/R/position-.R @@ -46,6 +46,8 @@ Position <- ggproto("Position", required_aes = character(), + default_aes = aes(), + setup_params = function(self, data) { list() }, @@ -66,6 +68,36 @@ Position <- ggproto("Position", compute_panel = function(self, data, params, scales) { cli::cli_abort("Not implemented.") + }, + + aesthetics = function(self) { + required_aes <- self$required_aes + if (!is.null(required_aes)) { + required_aes <- unlist(strsplit(self$required_aes, "|", fixed = TRUE)) + } + c(union(required_aes, names(self$default_aes))) + }, + + 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)))] + + if ((length(params) + length(defaults)) < 1) { + return(data) + } + + new <- compact(lapply(defaults, eval_tidy, data = data)) + new[names(params)] <- params + check_aesthetics(new, nrow(data)) + + data[names(new)] <- new + data + } ) diff --git a/R/position-dodge.R b/R/position-dodge.R index ef24531207..bd816eecc9 100644 --- a/R/position-dodge.R +++ b/R/position-dodge.R @@ -13,7 +13,14 @@ #' geoms. See the examples. #' @param preserve Should dodging preserve the `"total"` width of all elements #' at a position, or the width of a `"single"` element? +#' @param orientation Fallback orientation when the layer or the data does not +#' indicate an explicit orientation, like `geom_point()`. Can be `"x"` +#' (default) or `"y"`. +#' @param reverse If `TRUE`, will reverse the default stacking order. +#' This is useful if you're rotating both the plot and legend. #' @family position adjustments +#' @eval rd_aesthetics("position", "dodge") +#' #' @export #' @examples #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + @@ -79,10 +86,14 @@ #' #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + #' geom_bar(position = position_dodge2(preserve = "total")) -position_dodge <- function(width = NULL, preserve = "total") { +position_dodge <- function(width = NULL, preserve = "total", orientation = "x", + reverse = FALSE) { + check_bool(reverse) ggproto(NULL, PositionDodge, width = width, - preserve = arg_match0(preserve, c("total", "single")) + preserve = arg_match0(preserve, c("total", "single")), + orientation = arg_match0(orientation, c("x", "y")), + reverse = reverse ) } @@ -93,8 +104,18 @@ position_dodge <- function(width = NULL, preserve = "total") { PositionDodge <- ggproto("PositionDodge", Position, width = NULL, preserve = "total", + orientation = "x", + reverse = NULL, + default_aes = aes(order = NULL), + setup_params = function(self, data) { - flipped_aes <- has_flipped_aes(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) + ) + data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { cli::cli_warn(c( @@ -106,23 +127,39 @@ PositionDodge <- ggproto("PositionDodge", Position, if (identical(self$preserve, "total")) { n <- NULL } else { - panels <- unname(split(data, data$PANEL)) - ns <- vapply(panels, function(panel) max(table(panel$xmin)), double(1)) - n <- max(ns) + data$xmin <- data$xmin %||% data$x + cols <- intersect(colnames(data), c("group", "PANEL", "xmin")) + n <- vec_unique(data[cols]) + n <- vec_group_id(n[setdiff(cols, "group")]) + n <- max(tabulate(n, attr(n, "n"))) } list( width = self$width, n = n, - flipped_aes = flipped_aes + flipped_aes = flipped_aes, + reverse = self$reverse %||% FALSE ) }, setup_data = function(self, data, params) { data <- flip_data(data, params$flipped_aes) + if (!"x" %in% names(data) && all(c("xmin", "xmax") %in% names(data))) { data$x <- (data$xmin + data$xmax) / 2 } + + data$order <- xtfrm( # xtfrm makes anything 'sortable' + data$order %||% ave(data$group, data$x, data$PANEL, FUN = match_sorted) + ) + if (params$reverse) { + data$order <- -data$order + } + if (is.null(params$n)) { # preserve = "total" + data$order <- ave(data$order, data$x, data$PANEL, FUN = match_sorted) + } else { # preserve = "single" + data$order <- match_sorted(data$order) + } flip_data(data, params$flipped_aes) }, @@ -134,7 +171,8 @@ PositionDodge <- ggproto("PositionDodge", Position, name = "position_dodge", strategy = pos_dodge, n = params$n, - check.width = FALSE + check.width = FALSE, + reverse = !params$reverse # for consistency with `position_dodge2()` ) flip_data(collided, params$flipped_aes) } @@ -159,12 +197,16 @@ pos_dodge <- function(df, width, n = NULL) { # Have a new group index from 1 to number of groups. # This might be needed if the group numbers in this set don't include all of 1:n - groupidx <- match(df$group, sort(unique0(df$group))) + groupidx <- df$order %||% match_sorted(df$group) # Find the center for each group, then use that to calculate xmin and xmax - df$x <- df$x + width * ((groupidx - 0.5) / n - .5) + df$x <- df$x + width * ((groupidx - 0.5) / n - 0.5) df$xmin <- df$x - d_width / n / 2 df$xmax <- df$x + d_width / n / 2 df } + +match_sorted <- function(x, y = x, ...) { + vec_match(x, vec_sort(unique0(y), ...)) +} diff --git a/R/position-dodge2.R b/R/position-dodge2.R index a4c5fdc8ba..a670ffc349 100644 --- a/R/position-dodge2.R +++ b/R/position-dodge2.R @@ -2,8 +2,6 @@ #' @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. -#' @param reverse If `TRUE`, will reverse the default stacking order. -#' This is useful if you're rotating both the plot and legend. position_dodge2 <- function(width = NULL, preserve = "total", padding = 0.1, reverse = FALSE) { ggproto(NULL, PositionDodge2, @@ -115,7 +113,7 @@ pos_dodge2 <- function(df, width, n = NULL, padding = 0.1) { df$x <- (df$xmin + df$xmax) / 2 # If no elements occupy the same position, there is no need to add padding - if (!any(duplicated(df$xid))) { + if (!anyDuplicated(df$xid) > 0) { return(df) } @@ -134,14 +132,19 @@ 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) { - overlaps <- numeric(nrow(df)) - overlaps[1] <- counter <- 1 - for (i in seq_asc(2, nrow(df))) { - if (is.na(df$xmin[i]) || is.na(df$xmax[i - 1]) || df$xmin[i] >= df$xmax[i - 1]) { - counter <- counter + 1 - } - overlaps[i] <- counter - } - overlaps + 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") + + # For end we take largest end seen so far of previous observation + end <- cummax(c(end[1], end[-nrow(df)])) + # Start new group when 'start >= end' for non zero-width ranges + # For zero-width ranges, start must be strictly larger than end + overlaps <- cumsum(start > end | (start == end & nonzero)) + # Missing ranges always get separate group + overlaps[missing] <- seq_len(sum(missing)) + max(overlaps, na.rm = TRUE) + match(overlaps, unique0(overlaps)) } diff --git a/R/position-jitter.R b/R/position-jitter.R index 99d807fbe3..1dfcc422eb 100644 --- a/R/position-jitter.R +++ b/R/position-jitter.R @@ -41,7 +41,7 @@ #' geom_jitter(position = position_jitter(width = 0.1, height = 0.1)) #' #' # Create a jitter object for reproducible jitter: -#' jitter <- position_jitter(width = 0.1, height = 0.1) +#' jitter <- position_jitter(width = 0.1, height = 0.1, seed = 0) #' ggplot(mtcars, aes(am, vs)) + #' geom_point(position = jitter) + #' geom_point(position = jitter, color = "red", aes(am + 0.2, vs + 0.2)) @@ -68,30 +68,39 @@ PositionJitter <- ggproto("PositionJitter", Position, seed <- self$seed } list( - width = self$width %||% (resolution(data$x, zero = FALSE, TRUE) * 0.4), - height = self$height %||% (resolution(data$y, zero = FALSE, TRUE) * 0.4), + width = self$width, + height = self$height, seed = seed ) }, - compute_layer = function(self, data, params, layout) { - trans_x <- if (params$width > 0) function(x) jitter(x, amount = params$width) - trans_y <- if (params$height > 0) function(x) jitter(x, amount = params$height) - - # Make sure x and y jitter is only calculated once for all position aesthetics - x_aes <- intersect(ggplot_global$x_aes, names(data)) - x <- if (length(x_aes) == 0) 0 else data[[x_aes[1]]] - y_aes <- intersect(ggplot_global$y_aes, names(data)) - y <- if (length(y_aes) == 0) 0 else data[[y_aes[1]]] - dummy_data <- data_frame0(x = x, y = y, .size = nrow(data)) - fixed_jitter <- with_seed_null(params$seed, transform_position(dummy_data, trans_x, trans_y)) - x_jit <- fixed_jitter$x - x - y_jit <- fixed_jitter$y - y - # Avoid nan values, if x or y has Inf values - x_jit[is.infinite(x)] <- 0 - y_jit[is.infinite(y)] <- 0 - - # Apply jitter - transform_position(data, function(x) x + x_jit, function(x) x + y_jit) + compute_panel = function(self, data, params, scales) { + compute_jitter(data, params$width, params$height, seed = params$seed) } ) + +compute_jitter <- function(data, width = NULL, height = NULL, seed = NA) { + + 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_y <- if (height > 0) function(x) jitter(x, amount = height) + + x_aes <- intersect(ggplot_global$x_aes, names(data)) + x <- if (length(x_aes) == 0) 0 else data[[x_aes[1]]] + + y_aes <- intersect(ggplot_global$y_aes, names(data)) + y <- if (length(y_aes) == 0) 0 else data[[y_aes[1]]] + + jitter <- data_frame0(x = x, y = y, .size = nrow(data)) + jitter <- with_seed_null(seed, transform_position(jitter, trans_x, trans_y)) + + x_jit <- jitter$x - x + x_jit[is.infinite(x)] <- 0 + + y_jit <- jitter$y - y + y_jit[is.infinite(y)] <- 0 + + transform_position(data, function(x) x + x_jit, function(x) x + y_jit) +} diff --git a/R/position-jitterdodge.R b/R/position-jitterdodge.R index 291f03f263..10cb7c853f 100644 --- a/R/position-jitterdodge.R +++ b/R/position-jitterdodge.R @@ -11,6 +11,7 @@ #' @param dodge.width the amount to dodge in the x direction. Defaults to 0.75, #' the default `position_dodge()` width. #' @inheritParams position_jitter +#' @inheritParams position_dodge #' @export #' @examples #' set.seed(596) @@ -19,15 +20,18 @@ #' 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, seed = NA) { + 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, jitter.width = jitter.width, jitter.height = jitter.height, dodge.width = dodge.width, + reverse = reverse, seed = seed ) } @@ -40,6 +44,7 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, jitter.width = NULL, jitter.height = NULL, dodge.width = NULL, + reverse = NULL, required_aes = c("x", "y"), @@ -47,36 +52,32 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) width <- self$jitter.width %||% (resolution(data$x, zero = FALSE, TRUE) * 0.4) - # Adjust the x transformation based on the number of 'dodge' variables - possible_dodge <- c("fill", "colour", "linetype", "shape", "size", "alpha") - dodgecols <- intersect(possible_dodge, colnames(data)) - if (length(dodgecols) == 0) { - cli::cli_abort(c( - "{.fn position_jitterdodge} requires at least one aesthetic to dodge by.", - i = "Use one of {.or {.val {possible_dodge}}} aesthetics." - )) - } - ndodge <- lapply(data[dodgecols], levels) # returns NULL for numeric, i.e. non-dodge layers - ndodge <- vec_unique_count(unlist(ndodge)) + + ndodge <- vec_unique(data[c("group", "PANEL", "x")]) + ndodge <- vec_group_id(ndodge[c("PANEL", "x")]) + ndodge <- max(tabulate(ndodge, attr(ndodge, "n"))) list( - dodge.width = self$dodge.width, - jitter.height = self$jitter.height, + dodge.width = self$dodge.width %||% 0.75, + jitter.height = self$jitter.height %||% 0, jitter.width = width / (ndodge + 2), seed = self$seed, - flipped_aes = flipped_aes + flipped_aes = flipped_aes, + reverse = self$reverse %||% FALSE ) }, compute_panel = function(data, params, scales) { data <- flip_data(data, params$flipped_aes) - data <- collide(data, params$dodge.width, "position_jitterdodge", pos_dodge, - check.width = FALSE) - - trans_x <- if (params$jitter.width > 0) function(x) jitter(x, amount = params$jitter.width) - trans_y <- if (params$jitter.height > 0) function(x) jitter(x, amount = params$jitter.height) - - data <- with_seed_null(params$seed, transform_position(data, trans_x, trans_y)) + data <- collide( + data, + params$dodge.width, + "position_jitterdodge", + strategy = pos_dodge, + check.width = FALSE, + reverse = !params$reverse # for consistency with `position_dodge2()` + ) + 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 56e4e8fe4d..cd28360d79 100644 --- a/R/position-nudge.R +++ b/R/position-nudge.R @@ -8,6 +8,7 @@ #' @family position adjustments #' @param x,y Amount of vertical and horizontal distance to move. #' @export +#' @eval rd_aesthetics("position", "nudge") #' @examples #' df <- data.frame( #' x = c(1,3,2,5), @@ -26,7 +27,12 @@ #' ggplot(df, aes(x, y)) + #' geom_point() + #' geom_text(aes(label = y), nudge_y = -0.1) -position_nudge <- function(x = 0, y = 0) { +#' +#' # For each text individually +#' ggplot(df, aes(x, y)) + +#' 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 @@ -38,25 +44,21 @@ position_nudge <- function(x = 0, y = 0) { #' @usage NULL #' @export PositionNudge <- ggproto("PositionNudge", Position, - x = 0, - y = 0, + x = NULL, + y = NULL, + + default_aes = aes(nudge_x = 0, nudge_y = 0), setup_params = function(self, data) { - list(x = self$x, y = self$y) + list( + x = self$x %||% data$nudge_x, + y = self$y %||% data$nudge_y + ) }, compute_layer = function(self, data, params, layout) { - # transform only the dimensions for which non-zero nudging is requested - if (any(params$x != 0)) { - if (any(params$y != 0)) { - transform_position(data, function(x) x + params$x, function(y) y + params$y) - } else { - transform_position(data, function(x) x + params$x, NULL) - } - } else if (any(params$y != 0)) { - transform_position(data, NULL, function(y) y + params$y) - } else { - data # if both x and y are 0 we don't need to transform - } + trans_x <- if (any(params$x != 0)) function(x) x + params$x + trans_y <- if (any(params$y != 0)) function(y) y + params$y + transform_position(data, trans_x, trans_y) } ) diff --git a/R/position-stack.R b/R/position-stack.R index ac445be071..0e35f1191e 100644 --- a/R/position-stack.R +++ b/R/position-stack.R @@ -116,14 +116,12 @@ #' #' # Negative values ----------------------------------------------------------- #' -#' df <- tibble::tribble( -#' ~x, ~y, ~grp, -#' "a", 1, "x", -#' "a", 2, "y", -#' "b", 1, "x", -#' "b", 3, "y", -#' "b", -1, "y" +#' df <- data.frame( +#' x = rep(c("a", "b"), 2:3), +#' y = c(1, 2, 1, 3, -1), +#' grp = c("x", "y", "x", "y", "y") #' ) +#' #' ggplot(data = df, aes(x, y, group = grp)) + #' geom_col(aes(fill = grp), position = position_stack(reverse = TRUE)) + #' geom_hline(yintercept = 0) @@ -155,8 +153,14 @@ PositionStack <- ggproto("PositionStack", Position, setup_params = function(self, data) { flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) + var <- self$var %||% stack_var(data) + if (!vec_duplicate_any(data$x)) { + # We skip stacking when all data have different x positions so that + # there is nothing to stack + var <- NULL + } list( - var = self$var %||% stack_var(data), + var = var, fill = self$fill, vjust = self$vjust, reverse = self$reverse, @@ -220,7 +224,10 @@ pos_stack <- function(df, width, vjust = 1, fill = FALSE) { heights <- c(0, cumsum(y)) if (fill) { - heights <- heights / abs(heights[length(heights)]) + total <- abs(heights[length(heights)]) + if (total > sqrt(.Machine$double.eps)) { + heights <- heights / total + } } # 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)) { diff --git a/R/quick-plot.R b/R/quick-plot.R index 0ef5852cfb..64e2ab460d 100644 --- a/R/quick-plot.R +++ b/R/quick-plot.R @@ -62,7 +62,7 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, xlab = NULL, ylab = NULL, asp = NA, stat = deprecated(), position = deprecated()) { - deprecate_soft0("3.4.0", "qplot()") + deprecate_warn0("3.4.0", "qplot()") caller_env <- parent.frame() @@ -173,8 +173,3 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, #' @export #' @rdname qplot quickplot <- qplot - -is.constant <- function(x) { - is_I_call <- function(x) is.call(x) && identical(x[[1]], quote(I)) - vapply(x, is_I_call, logical(1)) -} diff --git a/R/save.R b/R/save.R index 2be88a3459..2f2faec357 100644 --- a/R/save.R +++ b/R/save.R @@ -37,7 +37,8 @@ #' @param units One of the following units in which the `width` and `height` #' arguments are expressed: `"in"`, `"cm"`, `"mm"` or `"px"`. #' @param dpi Plot resolution. Also accepts a string input: "retina" (320), -#' "print" (300), or "screen" (72). Applies only to raster output types. +#' "print" (300), or "screen" (72). Only applies when converting pixel units, +#' as is typical for raster output types. #' @param limitsize When `TRUE` (the default), `ggsave()` will not #' save images larger than 50x50 inches, to prevent the common error of #' specifying dimensions in pixels. @@ -88,35 +89,36 @@ #' dev.off() #' #' } -ggsave <- function(filename, plot = last_plot(), +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 <- check_path(path, filename, create.dir) + filename <- validate_path(path, filename, create.dir) dpi <- parse_dpi(dpi) - dev <- plot_dev(device, filename, 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) - if (is_null(bg)) { - bg <- calc_element("plot.background", plot_theme(plot))$fill %||% "transparent" - } old_dev <- grDevices::dev.cur() dev(filename = filename, width = dim[1], height = dim[2], bg = bg, ...) on.exit(utils::capture.output({ grDevices::dev.off() if (old_dev > 1) grDevices::dev.set(old_dev) # restore old device unless null device })) - grid.draw(plot) + if (!is_bare_list(plot)) { + plot <- list(plot) + } + lapply(plot, grid.draw) invisible(filename) } -check_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( @@ -181,7 +183,7 @@ parse_dpi <- function(dpi, call = caller_env()) { print = 300, retina = 320, ) - } else if (is_scalar_numeric(dpi)) { + } else if (is_bare_numeric(dpi, n = 1L)) { dpi } else { stop_input_type(dpi, "a single number or string", call = call) @@ -196,7 +198,7 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in", dim <- to_inches(dim) * scale - if (any(is.na(dim))) { + if (anyNA(dim)) { if (length(grDevices::dev.list()) == 0) { default_dim <- c(7, 7) } else { @@ -234,7 +236,18 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in", dim } -plot_dev <- function(device, filename = NULL, dpi = 300, call = caller_env()) { +get_plot_background <- function(plot, bg = NULL, default = "transparent") { + if (!is.null(bg)) { + return(bg) + } + plot <- if (is_bare_list(plot)) plot[[1]] else plot + if (!is_ggplot(plot)) { + return(default) + } + calc_element("plot.background", plot_theme(plot))$fill %||% default +} + +validate_device <- function(device, filename = NULL, dpi = 300, call = caller_env()) { force(filename) force(dpi) @@ -276,7 +289,10 @@ plot_dev <- function(device, filename = NULL, dpi = 300, call = caller_env()) { ps = eps, tex = function(filename, ...) grDevices::pictex(file = filename, ...), pdf = function(filename, ..., version = "1.4") grDevices::pdf(file = filename, ..., version = version), - svg = function(filename, ...) svglite::svglite(file = filename, ...), + 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(...), diff --git a/R/scale-.R b/R/scale-.R index 15c8ea1d5b..fa37bf5571 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -23,18 +23,20 @@ #' Also accepts rlang [lambda][rlang::as_function()] function notation. #' @param minor_breaks One of: #' - `NULL` for no minor breaks -#' - `waiver()` for the default breaks (one minor break between -#' each major break) +#' - `waiver()` for the default breaks (none for discrete, one minor break +#' between each major break for continuous) #' - A numeric vector of positions #' - A function that given the limits returns a vector of minor breaks. Also #' accepts rlang [lambda][rlang::as_function()] function notation. When #' the function has two arguments, it will be given the limits and major -#' breaks. +#' break positions. #' @param n.breaks An integer guiding the number of major breaks. The algorithm #' may choose a slightly different number to ensure nice break labels. Will #' only have an effect if `breaks = waiver()`. Use `NULL` to use the default #' number of breaks given by the transformation. -#' @param labels One of: +#' @param labels One of the options below. Please note that when `labels` is a +#' vector, it is highly recommended to also set the `breaks` argument as a +#' vector to protect against unintended mismatches. #' - `NULL` for no labels #' - `waiver()` for the default labels computed by the #' transformation object @@ -123,14 +125,11 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam position <- arg_match0(position, c("left", "right", "top", "bottom")) # If the scale is non-positional, break = NULL means removing the guide - if (is.null(breaks) && all(!is_position_aes(aesthetics))) { + if (is.null(breaks) && !any(is_position_aes(aesthetics))) { guide <- "none" } transform <- as.transform(transform) - if (!is.null(limits) && !is.function(limits)) { - limits <- transform$transform(limits) - } # Convert formula to function if appropriate limits <- allow_lambda(limits) @@ -140,6 +139,14 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam oob <- allow_lambda(oob) minor_breaks <- allow_lambda(minor_breaks) + if (!is.null(limits) && !is.function(limits)) { + limits <- transform$transform(limits) + if (!anyNA(limits)) { + limits <- sort(limits) + } + } + check_continuous_limits(limits, call = call) + ggproto(NULL, super, call = call, @@ -200,7 +207,8 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam #' 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(), labels = waiver(), limits = NULL, expand = 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(), @@ -218,6 +226,7 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name limits <- allow_lambda(limits) breaks <- allow_lambda(breaks) labels <- allow_lambda(labels) + minor_breaks <- allow_lambda(minor_breaks) if (!is.function(limits) && (length(limits) > 0) && !is.discrete(limits)) { cli::cli_warn(c( @@ -229,9 +238,13 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name position <- arg_match0(position, c("left", "right", "top", "bottom")) # If the scale is non-positional, break = NULL means removing the guide - if (is.null(breaks) && all(!is_position_aes(aesthetics))) { + is_position <- any(is_position_aes(aesthetics)) + if (is.null(breaks) && !is_position) { guide <- "none" } + if (is_position && identical(palette, identity)) { + palette <- seq_len + } ggproto(NULL, super, call = call, @@ -247,6 +260,7 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name name = name, breaks = breaks, + minor_breaks = minor_breaks, labels = labels, drop = drop, guide = guide, @@ -312,9 +326,6 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = } transform <- as.transform(transform) - if (!is.null(limits)) { - limits <- transform$transform(limits) - } # Convert formula input to function if appropriate limits <- allow_lambda(limits) @@ -323,6 +334,13 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = rescaler <- allow_lambda(rescaler) oob <- allow_lambda(oob) + if (!is.null(limits) && !is.function(limits)) { + limits <- transform$transform(limits) + if (!anyNA(limits)) { + limits <- sort(limits) + } + } + ggproto(NULL, super, call = call, @@ -519,6 +537,7 @@ Scale <- ggproto("Scale", NULL, if (empty(df)) { return() } + self$palette <- self$palette %||% fallback_palette(self) aesthetics <- intersect(self$aesthetics, names(df)) names(aesthetics) <- aesthetics @@ -595,21 +614,31 @@ Scale <- ggproto("Scale", NULL, ord }, - make_title = function(title) { + 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)) { + title <- scale_title(title) + } else { + title <- scale_title %|W|% title + } + guide_title <- allow_lambda(guide_title) + if (is.function(guide_title)) { + title <- guide_title(title) + } else { + title <- guide_title %|W|% title + } title }, - make_sec_title = function(title) { - title + make_sec_title = function(self, ...) { + self$make_title(...) } ) check_breaks_labels <- function(breaks, labels, call = NULL) { - if (is.null(breaks)) { - return(TRUE) - } - if (is.null(labels)) { - return(TRUE) + if (is.null(breaks) || is.null(labels)) { + return(invisible()) } bad_labels <- is.atomic(breaks) && is.atomic(labels) && @@ -621,7 +650,7 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { ) } - TRUE + invisible() } default_transform <- function(self, x) { @@ -685,7 +714,11 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, pal <- self$palette(uniq) scaled <- pal[match(x, uniq)] - ifelse(!is.na(scaled), scaled, self$na.value) + if (!anyNA(scaled)) { + return(scaled) + } + + vec_assign(scaled, is.na(scaled), self$na.value) }, rescale = function(self, x, limits = self$get_limits(), range = limits) { @@ -744,7 +777,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, # don't support conversion to numeric (#5304) if (zero_range(as.numeric(transformation$transform(limits)))) { breaks <- limits[1] - } else if (is.waive(self$breaks)) { + } else if (is.waiver(self$breaks)) { if (!is.null(self$n.breaks) && trans_support_nbreaks(transformation)) { breaks <- transformation$breaks(limits, self$n.breaks) } else { @@ -786,7 +819,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, b <- b[is.finite(b)] transformation <- self$get_transformation() - if (is.waive(self$minor_breaks)) { + if (is.waiver(self$minor_breaks)) { if (is.null(b)) { breaks <- NULL } else { @@ -833,7 +866,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, ) } - if (is.waive(self$labels)) { + if (is.waiver(self$labels)) { labels <- transformation$format(breaks) } else if (is.function(self$labels)) { labels <- self$labels(breaks) @@ -841,23 +874,21 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, labels <- self$labels } - if (length(labels) != length(breaks)) { + if (!identical(size0(labels), size0(breaks))) { cli::cli_abort( "{.arg breaks} and {.arg labels} have different lengths.", call = self$call ) } - if (is.list(labels)) { + + if (obj_is_list(labels)) { # Guard against list with empty elements labels[lengths(labels) == 0] <- "" # Make sure each element is scalar labels <- lapply(labels, `[`, 1) - - if (any(vapply(labels, is.language, logical(1)))) { - labels <- inject(expression(!!!labels)) - } else { - labels <- unlist(labels) - } + } + if (is.expression(labels)) { + labels <- as.list(labels) } labels @@ -951,9 +982,10 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, transform = identity, map = function(self, x, limits = self$get_limits()) { - n <- sum(!is.na(limits)) + limits <- vec_slice(limits, !is.na(limits)) + n <- vec_size(limits) if (n < 1) { - return(rep(self$na.value, length(x))) + return(vec_rep(self$na.value, vec_size(x))) } if (!is.null(self$n.breaks.cache) && self$n.breaks.cache == n) { pal <- self$palette.cache @@ -969,23 +1001,32 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, self$n.breaks.cache <- n } - if (!is_null(names(pal))) { + na_value <- NA + if (self$na.translate) { + na_value <- self$na.value + if (obj_is_list(pal) && !obj_is_list(na_value)) { + # We prevent a casting error that occurs when mapping grid patterns + na_value <- list(na_value) + } + } + + pal_names <- vec_names(pal) + + if (!is_null(pal_names)) { # if pal is named, limit the pal by the names first, # then limit the values by the pal - idx_nomatch <- is.na(match(names(pal), limits)) - pal[idx_nomatch] <- NA - pal_match <- pal[match(as.character(x), names(pal))] - pal_match <- unname(pal_match) - } else { - # if pal is not named, limit the values directly - pal_match <- pal[match(as.character(x), limits)] + vec_slice(pal, is.na(match(pal_names, limits))) <- na_value + pal <- vec_set_names(pal, NULL) + limits <- pal_names } + pal <- vec_c(pal, na_value) + pal_match <- + vec_slice(pal, match(as.character(x), limits, nomatch = vec_size(pal))) - if (self$na.translate) { - ifelse(is.na(x) | is.na(pal_match), self$na.value, pal_match) - } else { - pal_match + if (!is.na(na_value)) { + vec_slice(pal_match, is.na(x)) <- na_value } + pal_match }, rescale = function(self, x, limits = self$get_limits(), range = c(1, length(limits))) { @@ -1012,7 +1053,7 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, ) } - if (is.waive(self$breaks)) { + if (is.waiver(self$breaks)) { breaks <- limits } else if (is.function(self$breaks)) { breaks <- self$breaks(limits) @@ -1021,11 +1062,39 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, } # Breaks only occur only on values in domain - in_domain <- intersect(breaks, limits) + breaks <- setNames(as.character(breaks), names(breaks)) + in_domain <- vec_set_intersect(breaks, as.character(limits)) structure(in_domain, pos = match(in_domain, breaks)) }, - get_breaks_minor = function(...) NULL, + 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)) { + return(NULL) + } + if (is.function(breaks)) { + # Ensure function gets supplied numeric limits and breaks + if (!is.numeric(b)) { + b <- self$map(b) + } + if (!is.numeric(limits)) { + limits <- self$map(limits) + limits <- self$dimension(self$expand, limits) + } + + # Allow for two types of minor breaks specifications + break_fun <- fetch_ggproto(self, "minor_breaks") + arg_names <- fn_fmls_names(break_fun) + if (length(arg_names) == 1L) { + breaks <- break_fun(limits) + } else { + breaks <- break_fun(limits, b) + } + } + breaks + }, get_labels = function(self, breaks = self$get_breaks()) { if (self$is_empty()) { @@ -1036,45 +1105,42 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, return(NULL) } - if (is.null(self$labels)) { + labels <- self$labels + if (is.null(labels)) { return(NULL) } - if (identical(self$labels, NA)) { + if (identical(labels, NA)) { cli::cli_abort( "Invalid {.arg labels} specification. Use {.code NULL}, not {.code NA}.", call = self$call ) } - if (is.waive(self$labels)) { - if (is.numeric(breaks)) { + if (is.waiver(labels)) { + if (!is.null(names(breaks))) { + labels <- names(breaks) + } else if (is.numeric(breaks)) { # Only format numbers, because on Windows, format messes up encoding - format(breaks, justify = "none") + labels <- format(breaks, justify = "none") } else { - as.character(breaks) + labels <- as.character(breaks) } - } else if (is.function(self$labels)) { - self$labels(breaks) - } else { - if (!is.null(names(self$labels))) { - # If labels have names, use them to match with breaks - labels <- breaks - - map <- match(names(self$labels), labels, nomatch = 0) - labels[map] <- self$labels[map != 0] - labels - } else { - labels <- self$labels + } else if (is.function(labels)) { + labels <- labels(breaks) + } else if (!is.null(names(labels))) { + # If labels have names, use them to match with breaks + map <- match(names(self$labels), breaks, nomatch = 0) + labels <- replace(breaks, map, labels[map != 0]) + } else if (!is.null(attr(breaks, "pos"))) { + # Need to ensure that if breaks were dropped, corresponding labels are too + labels <- labels[attr(breaks, "pos")] + } - # Need to ensure that if breaks were dropped, corresponding labels are too - pos <- attr(breaks, "pos") - if (!is.null(pos)) { - labels <- labels[pos] - } - labels - } + if (is.expression(labels)) { + labels <- as.list(labels) } + labels }, clone = function(self) { @@ -1207,7 +1273,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, "Invalid {.arg breaks} specification. Use {.code NULL}, not {.code NA}.", call = self$call ) - } else if (is.waive(self$breaks)) { + } else if (is.waiver(self$breaks)) { if (self$nice.breaks) { if (!is.null(self$n.breaks) && trans_support_nbreaks(transformation)) { breaks <- transformation$breaks(limits, n = self$n.breaks) @@ -1245,9 +1311,17 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, new_limits[1] <- breaks[1] breaks <- breaks[-1] } - } else { + } else if (nbreaks == 1) { bin_size <- max(breaks[1] - limits[1], limits[2] - breaks[1]) new_limits <- c(breaks[1] - bin_size, breaks[1] + bin_size) + } else { + new_limits <- limits + if (zero_range(new_limits)) { + # 0.1 is the same width as the expansion `default_expansion()` + # gives for 0-width data + new_limits <- new_limits + c(-0.05, 0.05) + } + breaks <- new_limits } new_limits_trans <- suppressWarnings(transformation$transform(new_limits)) limits[is.finite(new_limits_trans)] <- new_limits[is.finite(new_limits_trans)] @@ -1274,9 +1348,6 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, breaks <- self$breaks } - # Breaks must be within limits - breaks <- oob_discard(breaks, sort(limits)) - self$breaks <- breaks transformation$transform(breaks) @@ -1297,7 +1368,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, "Invalid {.arg labels} specification. Use {.code NULL}, not {.code NA}.", call = self$call ) - } else if (is.waive(self$labels)) { + } else if (is.waiver(self$labels)) { labels <- transformation$format(breaks) } else if (is.function(self$labels)) { labels <- self$labels(breaks) @@ -1310,6 +1381,9 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, call = self$call ) } + if (is.expression(labels)) { + labels <- as.list(labels) + } labels }, @@ -1348,18 +1422,12 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, # In place modification of a scale to change the primary axis scale_flip_position <- function(scale) { - scale$position <- switch(scale$position, - top = "bottom", - bottom = "top", - left = "right", - right = "left", - scale$position - ) + scale$position <- opposite_position(scale$position) invisible() } check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) { - if (!any(is.finite(x) != is.finite(transformed))) { + if (!any(is_finite(x) != is_finite(transformed))) { return(invisible()) } if (is.null(arg)) { @@ -1371,6 +1439,16 @@ check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) cli::cli_warn(msg, call = call) } +check_continuous_limits <- function(limits, ..., + arg = caller_arg(limits), + call = caller_env()) { + if (is.null(limits) || is.function(limits)) { + return(invisible()) + } + check_numeric(limits, arg = arg, call = call, allow_na = TRUE) + check_length(limits, 2L, arg = arg, call = call) +} + trans_support_nbreaks <- function(trans) { "n" %in% names(formals(trans$breaks)) } diff --git a/R/scale-alpha.R b/R/scale-alpha.R index 53344f23be..c9155db9aa 100644 --- a/R/scale-alpha.R +++ b/R/scale-alpha.R @@ -31,8 +31,9 @@ #' #' # Changing the title #' p + scale_alpha("cylinders") -scale_alpha <- function(name = waiver(), ..., range = c(0.1, 1)) { - continuous_scale("alpha", name = name, palette = pal_rescale(range), ...) +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, ...) } #' @rdname scale_alpha @@ -41,8 +42,9 @@ scale_alpha_continuous <- scale_alpha #' @rdname scale_alpha #' @export -scale_alpha_binned <- function(name = waiver(), ..., range = c(0.1, 1)) { - binned_scale("alpha", name = name, palette = pal_rescale(range), ...) +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, ...) } #' @rdname scale_alpha @@ -56,32 +58,33 @@ scale_alpha_discrete <- function(...) { #' @rdname scale_alpha #' @export -scale_alpha_ordinal <- function(name = waiver(), ..., range = c(0.1, 1)) { - discrete_scale( - "alpha", name = name, - palette = function(n) seq(range[1], range[2], length.out = n), - ... - ) +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 { + NULL + } + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_datetime <- function(name = waiver(), ..., range = c(0.1, 1)) { +scale_alpha_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { + palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = "alpha", transform = "time", name = name, - palette = pal_rescale(range), - ... + aesthetics = aesthetics, transform = "time", name = name, + palette = palette, ... ) } #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_date <- function(name = waiver(), ..., range = c(0.1, 1)){ +scale_alpha_date <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha"){ + palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = "alpha", transform = "date", name = name, - palette = pal_rescale(range), - ... + aesthetics = aesthetics, transform = "date", name = name, + palette = palette, ... ) } diff --git a/R/scale-binned.R b/R/scale-binned.R index d84080fdef..4db4f1a916 100644 --- a/R/scale-binned.R +++ b/R/scale-binned.R @@ -92,7 +92,7 @@ ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, include.lowest = TRUE, right = self$right ) - (x - x_binned + .5) * diff(all_breaks)[x_binned] + all_breaks[x_binned] + (x - x_binned + 0.5) * diff(all_breaks)[x_binned] + all_breaks[x_binned] } else { x <- as.numeric(self$oob(x, limits)) x <- ifelse(!is.na(x), x, self$na.value) diff --git a/R/scale-colour.R b/R/scale-colour.R index 47f14063c3..c8c468559f 100644 --- a/R/scale-colour.R +++ b/R/scale-colour.R @@ -27,6 +27,13 @@ #' you want to manually set the colors of a scale, consider using #' [scale_colour_gradient()] or [scale_colour_steps()]. #' +#' @inheritParams continuous_scale +#' @param palette One of the following: +#' * `NULL` for the default palette stored in the theme. +#' * a character vector of colours. +#' * a single string naming a palette. +#' * a palette function that when called with a numeric vector with values +#' between 0 and 1 returns the corresponding output values. #' @param ... Additional parameters passed on to the scale type #' @param type One of the following: #' * "gradient" (the default) @@ -56,143 +63,201 @@ #' see the [paper on the colorspace package](https://arxiv.org/abs/1903.06490) #' and references therein. #' @examples -#' v <- ggplot(faithfuld, aes(waiting, eruptions, fill = density)) + -#' geom_tile() -#' v -#' -#' v + scale_fill_continuous(type = "gradient") -#' v + scale_fill_continuous(type = "viridis") -#' -#' # The above are equivalent to -#' v + scale_fill_gradient() -#' v + scale_fill_viridis_c() -#' -#' # To make a binned version of this plot -#' v + scale_fill_binned(type = "viridis") -#' -#' # Set a different default scale using the options -#' # mechanism -#' tmp <- getOption("ggplot2.continuous.fill") # store current setting -#' options(ggplot2.continuous.fill = scale_fill_distiller) -#' v -#' options(ggplot2.continuous.fill = tmp) # restore previous setting +#' # A standard plot +#' p <- ggplot(mpg, aes(displ, hwy, colour = cty)) + +#' geom_point() +#' +#' # You can use the scale to give a palette directly +#' p + scale_colour_continuous(palette = c("#FEE0D2", "#FC9272", "#DE2D26")) +#' +#' # The default colours are encoded into the theme +#' p + theme(palette.colour.continuous = c("#DEEBF7", "#9ECAE1", "#3182BD")) +#' +#' # You can globally set default colour palette via the theme +#' old <- update_theme(palette.colour.continuous = c("#E5F5E0", "#A1D99B", "#31A354")) +#' +#' # Plot now shows new global default +#' p +#' +#' # The default binned colour scale uses the continuous palette +#' p + scale_colour_binned() + +#' theme(palette.colour.continuous = c("#EFEDF5", "#BCBDDC", "#756BB1")) +#' +#' # Restoring the previous theme +#' theme_set(old) #' @export -scale_colour_continuous <- function(..., +scale_colour_continuous <- function(..., palette = NULL, aesthetics = "colour", + guide = "colourbar", na.value = "grey50", type = getOption("ggplot2.continuous.colour")) { - type <- type %||% "gradient" - args <- list2(...) - args$call <- args$call %||% current_call() - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type(exec(type, !!!args), "scale_colour_continuous", "colour") - } else if (identical(type, "gradient")) { - exec(scale_colour_gradient, !!!args) - } else if (identical(type, "viridis")) { - exec(scale_colour_viridis_c, !!!args) - } else { - cli::cli_abort(c( - "Unknown scale type: {.val {type}}", - "i" = "Use either {.val gradient} or {.val viridis}." - )) + 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" + ) + return(scale) } + palette <- if (!is.null(palette)) as_continuous_pal(palette) + continuous_scale( + aesthetics, palette = palette, guide = guide, na.value = na.value, + ... + ) } #' @rdname scale_colour_continuous #' @export -scale_fill_continuous <- function(..., +scale_fill_continuous <- function(..., palette = NULL, aesthetics = "fill", guide = "colourbar", + na.value = "grey50", type = getOption("ggplot2.continuous.fill")) { - type <- type %||% "gradient" - args <- list2(...) - args$call <- args$call %||% current_call() - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type(exec(type, !!!args), "scale_fill_continuous", "fill") - } else if (identical(type, "gradient")) { - exec(scale_fill_gradient, !!!args) - } else if (identical(type, "viridis")) { - exec(scale_fill_viridis_c, !!!args) - } else { - cli::cli_abort(c( - "Unknown scale type: {.val {type}}", - "i" = "Use either {.val gradient} or {.val viridis}." - )) + 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" + ) + return(scale) } + palette <- if (!is.null(palette)) as_continuous_pal(palette) + continuous_scale( + aesthetics, palette = palette, guide = guide, na.value = na.value, + ... + ) } #' @export #' @rdname scale_colour_continuous -scale_colour_binned <- function(..., +scale_colour_binned <- function(..., palette = NULL, aesthetics = "colour", guide = "coloursteps", + na.value = "grey50", type = getOption("ggplot2.binned.colour")) { - args <- list2(...) - args$call <- args$call %||% current_call() - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type(exec(type, !!!args), "scale_colour_binned", "colour") - } else { - type_fallback <- getOption("ggplot2.continuous.colour", default = "gradient") - # don't use fallback from scale_colour_continuous() if it is - # a function, since that would change the type of the color - # scale from binned to continuous - if (is.function(type_fallback)) { - type_fallback <- "gradient" - } - type <- type %||% type_fallback - - if (identical(type, "gradient")) { - exec(scale_colour_steps, !!!args) - } else if (identical(type, "viridis")) { - exec(scale_colour_viridis_b, !!!args) - } else { - cli::cli_abort(c( - "Unknown scale type: {.val {type}}", - "i" = "Use either {.val gradient} or {.val viridis}." - )) - } + + 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" + ) + return(scale) } + palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette)) + binned_scale( + aesthetics, palette = palette, guide = guide, na.value = na.value, + ... + ) } #' @export #' @rdname scale_colour_continuous -scale_fill_binned <- function(..., +scale_fill_binned <- function(..., palette = NULL, aesthetics = "fill", guide = "coloursteps", + na.value = "grey50", type = getOption("ggplot2.binned.fill")) { - args <- list2(...) - args$call <- args$call %||% current_call() - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type(exec(type, !!!args), "scale_fill_binned", "fill") - } else { - type_fallback <- getOption("ggplot2.continuous.fill", default = "gradient") - # don't use fallback from scale_colour_continuous() if it is - # a function, since that would change the type of the color - # scale from binned to continuous - if (is.function(type_fallback)) { - type_fallback <- "gradient" - } - type <- type %||% type_fallback - - if (identical(type, "gradient")) { - exec(scale_fill_steps, !!!args) - } else if (identical(type, "viridis")) { - exec(scale_fill_viridis_b, !!!args) - } else { - cli::cli_abort(c( - "Unknown scale type: {.val {type}}", - "i" = "Use either {.val gradient} or {.val viridis}." - )) - } + 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" + ) + return(scale) } + palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette)) + binned_scale( + aesthetics, palette = palette, guide = guide, na.value = na.value, + ... + ) } +#' Discrete colour scales +#' +#' The default discrete colour scale. Defaults to [scale_fill_hue()]/[scale_fill_brewer()] +#' unless `type` (which defaults to the `ggplot2.discrete.fill`/`ggplot2.discrete.colour` options) +#' is specified. +#' +#' @param palette One of the following: +#' * `NULL` for the default palette stored in the theme. +#' * a character vector of colours. +#' * a single string naming a palette. +#' * a palette function that when called with a single integer argument (the +#' number of levels in the scale) returns the values that they should take. +#' @param ... Additional parameters passed on to the scale type, +#' @inheritParams discrete_scale +#' @param type One of the following: +#' * A character vector of color codes. The codes are used for a 'manual' color +#' scale as long as the number of codes exceeds the number of data levels +#' (if there are more levels than codes, [scale_colour_hue()]/[scale_fill_hue()] +#' are used to construct the default scale). If this is a named vector, then the color values +#' will be matched to levels based on the names of the vectors. Data values that +#' don't match will be set as `na.value`. +#' * A list of character vectors of color codes. The minimum length vector that exceeds the +#' number of data levels is chosen for the color scaling. This is useful if you +#' want to change the color palette based on the number of levels. +#' * A function that returns a discrete colour/fill scale (e.g., [scale_fill_hue()], +#' [scale_fill_brewer()], etc). +#' @export +#' @seealso +#' The `r link_book("discrete colour scales section", "scales-colour#sec-colour-discrete")` +#' @examples +#' # A standard plot +#' p <- ggplot(mpg, aes(displ, hwy, colour = class)) + +#' geom_point() +#' +#' # You can use the scale to give a palette directly +#' p + scale_colour_discrete(palette = scales::pal_brewer(palette = "Dark2")) +#' +#' # The default colours are encoded into the theme +#' p + theme(palette.colour.discrete = scales::pal_grey()) +#' +#' # You can globally set default colour palette via the theme +#' old <- update_theme(palette.colour.discrete = scales::pal_viridis()) +#' +#' # Plot now shows new global default +#' p +#' +#' # 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")) + + if (has_old_args || (!is.null(type) && is.null(palette))) { + scale <- scale_backward_compatibility( + ..., 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, + ... + ) +} + +#' @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")) + + if (has_old_args || (!is.null(type) && is.null(palette))) { + scale <- scale_backward_compatibility( + ..., 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, + ... + ) +} # helper function to make sure that the provided scale is of the correct # type (i.e., is continuous and works with the provided aesthetic) @@ -219,6 +284,76 @@ check_scale_type <- function(scale, name, aesthetic, scale_is_discrete = FALSE, "x" = "The provided scale is {scale_types[2]}." ), call = call) } + invisible() +} + +# helper function for backwards compatibility through setting defaults +# scales through `options()` instead of `theme()`. +scale_backward_compatibility <- function(..., scale, aesthetic, type) { + aesthetic <- standardise_aes_names(aesthetic[1]) + + args <- list2(...) + args$call <- args$call %||% caller_call() %||% current_call() + + if (type == "binned") { + fallback <- getOption( + paste("ggplot2", type, aesthetic, sep = "."), + default = "gradient" + ) + if (is.function(fallback)) { + fallback <- "gradient" + } + scale <- scale %||% fallback + } + + if (is_bare_string(scale)) { + if (scale == "continuous") { + scale <- "gradient" + } + if (scale == "discrete") { + scale <- "hue" + } + if (scale == "viridis") { + scale <- switch( + type, discrete = "viridis_d", binned = "viridis_b", "viridis_c" + ) + } + + candidates <- paste("scale", aesthetic, scale, sep = "_") + for (candi in candidates) { + f <- find_global(candi, env = caller_env(), mode = "function") + if (!is.null(f)) { + scale <- f + break + } + } + } + + if (!is.function(scale) && type == "discrete") { + args$type <- scale + scale <- switch( + aesthetic, + colour = scale_colour_qualitative, + fill = scale_fill_qualitative + ) + } + + if (is.function(scale)) { + if (!any(c("...", "call") %in% fn_fmls_names(scale))) { + args$call <- NULL + } + if (!"..." %in% fn_fmls_names(scale)) { + args <- args[intersect(names(args), fn_fmls_names(scale))] + } + scale <- exec(scale, !!!args) + check_scale_type( + scale, + paste("scale", aesthetic, type, sep = "_"), + aesthetic, + scale_is_discrete = type == "discrete" + ) + return(scale) + } - scale + cli::cli_abort("Unknown scale type: {.val {scale}}") } diff --git a/R/scale-continuous.R b/R/scale-continuous.R index 9d6eee9ca9..9b0c8ec82c 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -142,28 +142,31 @@ ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous, # can tell the difference between continuous and discrete data. map = function(self, x, limits = self$get_limits()) { scaled <- as.numeric(self$oob(x, limits)) - ifelse(!is.na(scaled), scaled, self$na.value) + if (!anyNA(scaled)) { + return(scaled) + } + vec_assign(scaled, is.na(scaled), self$na.value) }, break_info = function(self, range = NULL) { breaks <- ggproto_parent(ScaleContinuous, self)$break_info(range) - if (!(is.waive(self$secondary.axis) || self$secondary.axis$empty())) { + if (!(is.waiver(self$secondary.axis) || self$secondary.axis$empty())) { self$secondary.axis$init(self) breaks <- c(breaks, self$secondary.axis$break_info(breaks$range, self)) } breaks }, sec_name = function(self) { - if (is.waive(self$secondary.axis)) { + if (is.waiver(self$secondary.axis)) { waiver() } else { self$secondary.axis$name } }, - make_sec_title = function(self, title) { - if (!is.waive(self$secondary.axis)) { - self$secondary.axis$make_title(title) + make_sec_title = function(self, ...) { + if (!is.waiver(self$secondary.axis)) { + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-date.R b/R/scale-date.R index 9433ccf568..ac0c314e18 100644 --- a/R/scale-date.R +++ b/R/scale-date.R @@ -81,7 +81,7 @@ scale_x_date <- function(name = waiver(), sec.axis = waiver()) { sc <- datetime_scale( - c("x", "xmin", "xmax", "xend"), + ggplot_global$x_aes, "date", name = name, palette = identity, @@ -118,7 +118,7 @@ scale_y_date <- function(name = waiver(), sec.axis = waiver()) { sc <- datetime_scale( - c("y", "ymin", "ymax", "yend"), + ggplot_global$y_aes, "date", name = name, palette = identity, @@ -156,7 +156,7 @@ scale_x_datetime <- function(name = waiver(), sec.axis = waiver()) { sc <- datetime_scale( - c("x", "xmin", "xmax", "xend"), + ggplot_global$x_aes, "time", name = name, palette = identity, @@ -196,7 +196,7 @@ scale_y_datetime <- function(name = waiver(), sec.axis = waiver()) { sc <- datetime_scale( - c("y", "ymin", "ymax", "yend"), + ggplot_global$y_aes, "time", name = name, palette = identity, @@ -223,8 +223,11 @@ scale_y_datetime <- function(name = waiver(), #' @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, @@ -233,20 +236,25 @@ scale_x_time <- function(name = waiver(), position = "bottom", sec.axis = waiver()) { - scale_x_continuous( + sc <- datetime_scale( + ggplot_global$x_aes, + "hms", name = name, + palette = identity, breaks = breaks, + date_breaks = date_breaks, labels = labels, + date_labels = date_labels, minor_breaks = minor_breaks, + date_minor_breaks = date_minor_breaks, + guide = guide, limits = limits, expand = expand, oob = oob, - na.value = na.value, - guide = guide, - position = position, - transform = scales::transform_hms(), - sec.axis = sec.axis + position = position ) + + set_sec_axis(sec.axis, sc) } @@ -254,8 +262,11 @@ scale_x_time <- function(name = waiver(), #' @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, @@ -264,20 +275,25 @@ scale_y_time <- function(name = waiver(), position = "left", sec.axis = waiver()) { - scale_y_continuous( + sc <- datetime_scale( + ggplot_global$y_aes, + "hms", name = name, + palette = identity, breaks = breaks, + date_breaks = date_breaks, labels = labels, + date_labels = date_labels, minor_breaks = minor_breaks, + date_minor_breaks = date_minor_breaks, + guide = guide, limits = limits, expand = expand, oob = oob, - na.value = na.value, - guide = guide, - position = position, - transform = scales::transform_hms(), - sec.axis = sec.axis + position = position ) + + set_sec_axis(sec.axis, sc) } #' Date/time scale constructor @@ -302,26 +318,34 @@ datetime_scale <- function(aesthetics, transform, trans = deprecated(), if (is.character(breaks)) breaks <- breaks_width(breaks) if (is.character(minor_breaks)) minor_breaks <- breaks_width(minor_breaks) - if (!is.waive(date_breaks)) { + if (!is.waiver(date_breaks)) { + check_string(date_breaks) breaks <- breaks_width(date_breaks) } - if (!is.waive(date_minor_breaks)) { + if (!is.waiver(date_minor_breaks)) { + check_string(date_minor_breaks) minor_breaks <- breaks_width(date_minor_breaks) } - if (!is.waive(date_labels)) { - labels <- function(self, x) { - tz <- self$timezone %||% "UTC" - label_date(date_labels, tz)(x) + if (!is.waiver(date_labels)) { + check_string(date_labels) + if (transform == "hms") { + labels <- label_time(date_labels) + } else { + labels <- function(self, x) { + tz <- self$timezone %||% "UTC" + label_date(date_labels, tz)(x) + } } } # x/y position aesthetics should use ScaleContinuousDate or # ScaleContinuousDatetime; others use ScaleContinuous - if (all(aesthetics %in% c("x", "xmin", "xmax", "xend", "y", "ymin", "ymax", "yend"))) { + if (all(aesthetics %in% c(ggplot_global$x_aes, ggplot_global$y_aes))) { scale_class <- switch( transform, date = ScaleContinuousDate, - time = ScaleContinuousDatetime + time = ScaleContinuousDatetime, + ScaleContinuousPosition ) } else { scale_class <- ScaleContinuous @@ -329,7 +353,8 @@ datetime_scale <- function(aesthetics, transform, trans = deprecated(), transform <- switch(transform, date = transform_date(), - time = transform_time(timezone) + time = transform_time(timezone), + hms = transform_hms() ) sc <- continuous_scale( @@ -362,6 +387,16 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, self$timezone <- tz self$trans <- transform_time(self$timezone) } + 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) + } + if (inherits(x, "Date")) { + x <- as.POSIXct(x) + } ggproto_parent(ScaleContinuous, self)$transform(x) }, map = function(self, x, limits = self$get_limits()) { @@ -369,24 +404,24 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, }, break_info = function(self, range = NULL) { breaks <- ggproto_parent(ScaleContinuous, self)$break_info(range) - if (!(is.waive(self$secondary.axis) || self$secondary.axis$empty())) { + if (!(is.waiver(self$secondary.axis) || self$secondary.axis$empty())) { self$secondary.axis$init(self) breaks <- c(breaks, self$secondary.axis$break_info(breaks$range, self)) } breaks }, sec_name = function(self) { - if (is.waive(self$secondary.axis)) { + if (is.waiver(self$secondary.axis)) { waiver() } else { self$secondary.axis$name } }, - make_sec_title = function(self, title) { - if (!is.waive(self$secondary.axis)) { - self$secondary.axis$make_title(title) + make_sec_title = function(self, ...) { + if (!is.waiver(self$secondary.axis)) { + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } @@ -401,6 +436,19 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, map = function(self, x, limits = self$get_limits()) { self$oob(x, limits) }, + 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) + } + if (inherits(x, "POSIXct")) { + x <- as.Date(x) + } + ggproto_parent(ScaleContinuous, self)$transform(x) + }, get_breaks = function(self, limits = self$get_limits()) { breaks <- ggproto_parent(ScaleContinuous, self)$get_breaks(limits) if (is.null(breaks)) { @@ -410,24 +458,24 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, }, break_info = function(self, range = NULL) { breaks <- ggproto_parent(ScaleContinuous, self)$break_info(range) - if (!(is.waive(self$secondary.axis) || self$secondary.axis$empty())) { + if (!(is.waiver(self$secondary.axis) || self$secondary.axis$empty())) { self$secondary.axis$init(self) breaks <- c(breaks, self$secondary.axis$break_info(breaks$range, self)) } breaks }, sec_name = function(self) { - if (is.waive(self$secondary.axis)) { + if (is.waiver(self$secondary.axis)) { waiver() } else { self$secondary.axis$name } }, - make_sec_title = function(self, title) { - if (!is.waive(self$secondary.axis)) { - self$secondary.axis$make_title(title) + make_sec_title = function(self, ...) { + if (!is.waiver(self$secondary.axis)) { + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-discrete-.R b/R/scale-discrete-.R index 268448f844..adaebb96d7 100644 --- a/R/scale-discrete-.R +++ b/R/scale-discrete-.R @@ -12,6 +12,16 @@ #' #' @inheritDotParams discrete_scale -scale_name #' @inheritParams discrete_scale +#' @param palette A palette function that when called with a single integer +#' argument (the number of levels in the scale) returns the numerical values +#' that they should take. +#' @param sec.axis [dup_axis()] is used to specify a secondary axis. +#' @param continuous.limits One of: +#' * `NULL` to use the default scale range +#' * A numeric vector of length two providing a display range for the scale. +#' Use `NA` to refer to the existing minimum or maximum. +#' * A function that accepts the limits and returns a numeric vector of +#' length two. #' @rdname scale_discrete #' @family position scales #' @seealso @@ -63,31 +73,37 @@ #' geom_point() + #' scale_x_discrete(labels = abbreviate) #' } -scale_x_discrete <- function(name = waiver(), ..., expand = waiver(), - guide = waiver(), position = "bottom") { +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 = c("x", "xmin", "xmax", "xend"), name = name, - palette = identity, ..., + aesthetics = ggplot_global$x_aes, name = name, + palette = palette, ..., expand = expand, guide = guide, position = position, super = ScaleDiscretePosition ) sc$range_c <- ContinuousRange$new() - sc + sc$continuous_limits <- continuous.limits + set_sec_axis(sec.axis, sc) } #' @rdname scale_discrete #' @export -scale_y_discrete <- function(name = waiver(), ..., expand = waiver(), - guide = waiver(), position = "left") { +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 = c("y", "ymin", "ymax", "yend"), name = name, - palette = identity, ..., + aesthetics = ggplot_global$y_aes, name = name, + palette = palette, ..., expand = expand, guide = guide, position = position, super = ScaleDiscretePosition ) sc$range_c <- ContinuousRange$new() - sc + sc$continuous_limits <- continuous.limits + set_sec_axis(sec.axis, sc) } # The discrete position scale maintains two separate ranges - one for @@ -100,6 +116,8 @@ scale_y_discrete <- function(name = waiver(), ..., expand = waiver(), #' @usage NULL #' @export ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, + continuous_limits = NULL, + train = function(self, x) { if (is.discrete(x)) { self$range$train(x, drop = self$drop, na.rm = !self$na.translate) @@ -124,7 +142,9 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, }, is_empty = function(self) { - is.null(self$range$range) && is.null(self$limits) && is.null(self$range_c$range) + is.null(self$range$range) && + (is.null(self$limits) || is.function(self$limits)) && + is.null(self$range_c$range) }, reset = function(self) { @@ -133,8 +153,25 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, }, map = function(self, x, limits = self$get_limits()) { + if (inherits(x, "AsIs")) { + return(x) + } if (is.discrete(x)) { - x <- seq_along(limits)[match(as.character(x), limits)] + values <- self$palette(length(limits)) + if (!is.numeric(values)) { + cli::cli_abort( + "The {.arg palette} function must return a {.cls numeric} vector.", + call = self$call + ) + } + if (length(values) < length(limits)) { + cli::cli_abort( + "The {.arg palette} function must return at least \\ + {length(limits)} values.", + call = self$call + ) + } + x <- values[match(as.character(x), limits)] } mapped_discrete(x) }, @@ -147,6 +184,14 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, expand_limits_scale(self, expand, limits) }, + sec_name = function(self) { + if (is.waiver(self$secondary.axis)) { + waiver() + } else { + self$secondary.axis$name + } + }, + clone = function(self) { new <- ggproto(NULL, self) new$range <- DiscreteRange$new() diff --git a/R/scale-expansion.R b/R/scale-expansion.R index 9ede4c1400..9c682eeaa6 100644 --- a/R/scale-expansion.R +++ b/R/scale-expansion.R @@ -69,7 +69,7 @@ expand_range4 <- function(limits, expand) { cli::cli_abort("{.arg expand} must be a numeric vector with 2 or 4 elements.") } - if (all(!is.finite(limits))) { + if (!any(is.finite(limits))) { return(c(-Inf, Inf)) } @@ -81,9 +81,7 @@ expand_range4 <- function(limits, expand) { # Calculate separate range expansion for the lower and # upper range limits, and then combine them into one vector - lower <- expand_range(limits, expand[1], expand[2])[1] - upper <- expand_range(limits, expand[3], expand[4])[2] - c(lower, upper) + expand_range(limits, expand[c(1, 3)], expand[c(2, 4)]) } #' Calculate the default expansion for a scale @@ -98,11 +96,24 @@ expand_range4 <- function(limits, expand) { #' default_expansion <- function(scale, discrete = expansion(add = 0.6), continuous = expansion(mult = 0.05), expand = TRUE) { - if (!expand) { - return(expansion(0, 0)) + out <- expansion() + if (!any(expand)) { + return(out) } + scale_expand <- scale$expand %|W|% + if (scale$is_discrete()) discrete else continuous - scale$expand %|W|% if (scale$is_discrete()) discrete else continuous + # for backward compatibility, we ensure expansions have expected length + expand <- rep_len(expand, 2L) + scale_expand <- rep_len(scale_expand, 4) + + if (expand[1]) { + out[1:2] <- scale_expand[1:2] + } + if (expand[2]) { + out[3:4] <- scale_expand[3:4] + } + out } #' Expand limits in (possibly) transformed space @@ -137,10 +148,11 @@ expand_limits_scale <- function(scale, expand = expansion(0, 0), limits = waiver if (scale$is_discrete()) { coord_limits <- coord_limits %||% c(NA_real_, NA_real_) expand_limits_discrete( - limits, + scale$map(limits), expand, coord_limits, - range_continuous = scale$range_c$range + range_continuous = scale$range_c$range, + continuous_limits = scale$continuous_limits ) } else { # using the inverse transform to resolve the NA value is needed for date/datetime/time @@ -157,7 +169,20 @@ expand_limits_continuous <- function(limits, expand = expansion(0, 0), coord_lim } expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA), - range_continuous = NULL) { + range_continuous = NULL, continuous_limits = NULL) { + if (is.function(continuous_limits)) { + continuous_limits <- continuous_limits(limits) + } + if (!is.null(continuous_limits)) { + if (!anyNA(continuous_limits)) { + continuous_limits <- range(continuous_limits) + } + 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) + } + limit_info <- expand_limits_discrete_trans( limits, expand, @@ -193,22 +218,25 @@ expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), continuous_range <- ifelse(is.finite(final_scale_limits), final_scale_limits, limits) list( - continuous_range_coord = continuous_range_coord, - continuous_range = continuous_range + continuous_range_coord = sort(continuous_range_coord), + continuous_range = sort(continuous_range) ) } expand_limits_discrete_trans <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA), trans = transform_identity(), range_continuous = NULL) { - if (is.discrete(limits)) { - n_discrete_limits <- length(limits) - } else { - n_discrete_limits <- 0 + discrete_limits <- NULL + if (length(limits) > 0) { + if (is.discrete(limits)) { + discrete_limits <- c(1, length(limits)) # for backward compatibility + } else { + discrete_limits <- range(limits) + } } is_empty <- is.null(limits) && is.null(range_continuous) - is_only_continuous <- n_discrete_limits == 0 + is_only_continuous <- is.null(discrete_limits) is_only_discrete <- is.null(range_continuous) if (is_empty) { @@ -216,10 +244,10 @@ expand_limits_discrete_trans <- function(limits, expand = expansion(0, 0), } else if (is_only_continuous) { expand_limits_continuous_trans(range_continuous, expand, coord_limits, trans) } else if (is_only_discrete) { - expand_limits_continuous_trans(c(1, n_discrete_limits), expand, coord_limits, trans) + expand_limits_continuous_trans(discrete_limits, expand, coord_limits, trans) } else { # continuous and discrete - limit_info_discrete <- expand_limits_continuous_trans(c(1, n_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( diff --git a/R/scale-gradient.R b/R/scale-gradient.R index f0b2771154..32f61a2e8e 100644 --- a/R/scale-gradient.R +++ b/R/scale-gradient.R @@ -16,7 +16,7 @@ #' @param low,high Colours for low and high ends of the gradient. #' @param guide Type of legend. Use `"colourbar"` for continuous #' colour bar, or `"legend"` for discrete colour legend. -#' @inheritDotParams continuous_scale -na.value -guide -aesthetics -expand -position +#' @inheritDotParams continuous_scale -na.value -guide -aesthetics -expand -position -palette #' @seealso [scales::pal_seq_gradient()] for details on underlying #' palette, [scale_colour_steps()] for binned variants of these scales. #' @@ -54,6 +54,14 @@ #' geom_point(aes(colour = z1)) + #' scale_colour_gradientn(colours = terrain.colors(10)) #' +#' # The gradientn scale can be centered by using a rescaler +#' ggplot(df, aes(x, y)) + +#' geom_point(aes(colour = z1)) + +#' scale_colour_gradientn( +#' colours = c("blue", "dodgerblue", "white", "orange", "red"), +#' rescaler = ~ scales::rescale_mid(.x, mid = 0) +#' ) +#' #' # Equivalent fill scales do the same job for the fill aesthetic #' ggplot(faithfuld, aes(waiting, eruptions)) + #' geom_raster(aes(fill = density)) + diff --git a/R/scale-grey.R b/R/scale-grey.R index b3683295f7..cc6a88033e 100644 --- a/R/scale-grey.R +++ b/R/scale-grey.R @@ -5,7 +5,7 @@ #' #' @inheritParams scales::pal_grey #' @inheritParams scale_colour_hue -#' @inheritDotParams discrete_scale -expand -position -scale_name +#' @inheritDotParams discrete_scale -expand -position -scale_name -palette #' @family colour scales #' @seealso #' The documentation on [colour aesthetics][aes_colour_fill_alpha]. diff --git a/R/scale-hue.R b/R/scale-hue.R index ba50f81dc2..311533e283 100644 --- a/R/scale-hue.R +++ b/R/scale-hue.R @@ -4,7 +4,7 @@ #' It does not generate colour-blind safe palettes. #' #' @param na.value Colour to use for missing values -#' @inheritDotParams discrete_scale -aesthetics -expand -position -scale_name +#' @inheritDotParams discrete_scale -aesthetics -expand -position -scale_name -palette #' @param aesthetics Character string or vector of character strings listing the #' name(s) of the aesthetic(s) that this scale works with. This can be useful, for #' example, to apply colour settings to the `colour` and `fill` aesthetics at the @@ -78,106 +78,6 @@ scale_fill_hue <- function(name = waiver(), ..., h = c(0, 360) + 15, c = 100, ) } - -#' Discrete colour scales -#' -#' The default discrete colour scale. Defaults to [scale_fill_hue()]/[scale_fill_brewer()] -#' unless `type` (which defaults to the `ggplot2.discrete.fill`/`ggplot2.discrete.colour` options) -#' is specified. -#' -#' @param ... Additional parameters passed on to the scale type, -#' @param type One of the following: -#' * A character vector of color codes. The codes are used for a 'manual' color -#' scale as long as the number of codes exceeds the number of data levels -#' (if there are more levels than codes, [scale_colour_hue()]/[scale_fill_hue()] -#' are used to construct the default scale). If this is a named vector, then the color values -#' will be matched to levels based on the names of the vectors. Data values that -#' don't match will be set as `na.value`. -#' * A list of character vectors of color codes. The minimum length vector that exceeds the -#' number of data levels is chosen for the color scaling. This is useful if you -#' want to change the color palette based on the number of levels. -#' * A function that returns a discrete colour/fill scale (e.g., [scale_fill_hue()], -#' [scale_fill_brewer()], etc). -#' @export -#' @seealso -#' The `r link_book("discrete colour scales section", "scales-colour#sec-colour-discrete")` -#' @examples -#' # Template function for creating densities grouped by a variable -#' cty_by_var <- function(var) { -#' ggplot(mpg, aes(cty, colour = factor({{var}}), fill = factor({{var}}))) + -#' geom_density(alpha = 0.2) -#' } -#' -#' # The default, scale_fill_hue(), is not colour-blind safe -#' cty_by_var(class) -#' -#' # (Temporarily) set the default to Okabe-Ito (which is colour-blind safe) -#' okabe <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7") -#' withr::with_options( -#' list(ggplot2.discrete.fill = okabe), -#' print(cty_by_var(class)) -#' ) -#' -#' # Define a collection of palettes to alter the default based on number of levels to encode -#' discrete_palettes <- list( -#' c("skyblue", "orange"), -#' RColorBrewer::brewer.pal(3, "Set2"), -#' RColorBrewer::brewer.pal(6, "Accent") -#' ) -#' withr::with_options( -#' list(ggplot2.discrete.fill = discrete_palettes), { -#' # 1st palette is used when there 1-2 levels (e.g., year) -#' print(cty_by_var(year)) -#' # 2nd palette is used when there are 3 levels -#' print(cty_by_var(drv)) -#' # 3rd palette is used when there are 4-6 levels -#' print(cty_by_var(fl)) -#' }) -#' -scale_colour_discrete <- function(..., type = getOption("ggplot2.discrete.colour")) { - # TODO: eventually `type` should default to a set of colour-blind safe color codes (e.g. Okabe-Ito) - type <- type %||% scale_colour_hue - args <- list2(...) - args$call <- args$call %||% current_call() - - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type( - exec(type, !!!args), - "scale_colour_discrete", - "colour", - scale_is_discrete = TRUE - ) - } else { - exec(scale_colour_qualitative, !!!args, type = type) - } -} - -#' @rdname scale_colour_discrete -#' @export -scale_fill_discrete <- function(..., type = getOption("ggplot2.discrete.fill")) { - # TODO: eventually `type` should default to a set of colour-blind safe color codes (e.g. Okabe-Ito) - type <- type %||% scale_fill_hue - args <- list2(...) - args$call <- args$call %||% current_call() - - if (is.function(type)) { - if (!any(c("...", "call") %in% fn_fmls_names(type))) { - args$call <- NULL - } - check_scale_type( - exec(type, !!!args), - "scale_fill_discrete", - "fill", - scale_is_discrete = TRUE - ) - } else { - exec(scale_fill_qualitative, !!!args, type = type) - } -} - scale_colour_qualitative <- function(name = waiver(), ..., type = NULL, h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1, @@ -205,22 +105,22 @@ scale_fill_qualitative <- function(name = waiver(), ..., type = NULL, #' @param type a character vector or a list of character vectors #' @noRd pal_qualitative <- function(type, h, c, l, h.start, direction) { + type_list <- type + if (!is.list(type_list)) { + type_list <- list(type_list) + } + if (!all(vapply(type_list, is.character, logical(1)))) { + stop_input_type(type, "a character vector or list of character vectors") + } + type_lengths <- lengths(type_list) function(n) { - type_list <- if (!is.list(type)) list(type) else type - if (!all(vapply(type_list, is.character, logical(1)))) { - cli::cli_abort("{.arg type} must be a character vector or a list of character vectors.") - } - type_lengths <- lengths(type_list) # If there are more levels than color codes default to pal_hue() if (max(type_lengths) < n) { return(scales::pal_hue(h, c, l, h.start, direction)(n)) } # Use the minimum length vector that exceeds the number of levels (n) - type_list <- type_list[order(type_lengths)] - i <- 1 - while (length(type_list[[i]]) < n) { - i <- i + 1 - } - type_list[[i]][seq_len(n)] + i <- which(type_lengths >= n) + i <- i[which.min(type_lengths[i])] + type_list[[i]] } } diff --git a/R/scale-identity.R b/R/scale-identity.R index d86f6ae360..3ab2de5c43 100644 --- a/R/scale-identity.R +++ b/R/scale-identity.R @@ -89,9 +89,10 @@ 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") { +scale_shape_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "shape") { continuous_scale( - "shape", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -101,9 +102,10 @@ 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") { +scale_linetype_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "linetype") { discrete_scale( - "linetype", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleDiscreteIdentity ) @@ -113,9 +115,10 @@ 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") { +scale_linewidth_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "linewidth") { continuous_scale( - "linewidth", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -123,9 +126,10 @@ scale_linewidth_identity <- function(name = waiver(), ..., guide = "none") { #' @rdname scale_identity #' @export -scale_alpha_identity <- function(name = waiver(), ..., guide = "none") { +scale_alpha_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "alpha") { continuous_scale( - "alpha", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -135,9 +139,10 @@ 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") { +scale_size_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "size") { continuous_scale( - "size", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) diff --git a/R/scale-linetype.R b/R/scale-linetype.R index a1b983b23d..f3d48aa4c5 100644 --- a/R/scale-linetype.R +++ b/R/scale-linetype.R @@ -5,10 +5,17 @@ #' line types unless `scale_linetype_binned()` is used. Still, as linetypes has #' no inherent order, this use is not advised. #' -#' @inheritParams scale_x_discrete -#' @inheritDotParams discrete_scale -expand -position -na.value -scale_name -#' @param na.value The linetype to use for `NA` values. +#' @inheritParams discrete_scale +#' @inheritDotParams discrete_scale -expand -position -na.value -scale_name -palette #' @rdname scale_linetype +#' @details +#' Lines can be referred to by number, name or hex code. Contrary to base R +#' graphics, `NA`s are interpreted as blanks. +#' +#' \if{html}{\figure{linetype_table.svg}{Named linetypes by number and name}} +#' \if{latex}{\figure{linetype_table.pdf}} +#' +#' #' @seealso #' The documentation for [differentiation related aesthetics][aes_linetype_size_shape]. #' @@ -35,22 +42,20 @@ #' scale_linetype_identity() + #' facet_grid(linetype ~ .) + #' theme_void(20) -scale_linetype <- function(name = waiver(), ..., na.value = "blank") { +scale_linetype <- function(name = waiver(), ..., aesthetics = "linetype") { discrete_scale( - "linetype", name = name, - palette = pal_linetype(), - na.value = na.value, + aesthetics, name = name, + palette = NULL, ... ) } #' @rdname scale_linetype #' @export -scale_linetype_binned <- function(name = waiver(), ..., na.value = "blank") { +scale_linetype_binned <- function(name = waiver(), ..., aesthetics = "linetype") { binned_scale( - "linetype", name = name, - palette = pal_binned(pal_linetype()), - na.value = na.value, + aesthetics, name = name, + palette = NULL, ... ) } diff --git a/R/scale-linewidth.R b/R/scale-linewidth.R index 801df22b3a..2a062e0e73 100644 --- a/R/scale-linewidth.R +++ b/R/scale-linewidth.R @@ -2,7 +2,7 @@ #' #' `scale_linewidth` scales the width of lines and polygon strokes. Due to #' historical reasons, it is also possible to control this with the `size` -#' aesthetic, but using `linewidth` is encourage to clearly differentiate area +#' aesthetic, but using `linewidth` is encouraged to clearly differentiate area #' aesthetics from stroke width aesthetics. #' #' @name scale_linewidth @@ -31,10 +31,12 @@ NULL #' @usage NULL scale_linewidth_continuous <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, - range = c(1, 6), transform = "identity", + range = NULL, transform = "identity", trans = deprecated(), - guide = "legend") { - continuous_scale("linewidth", palette = pal_rescale(range), name = name, + 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) } @@ -46,10 +48,11 @@ scale_linewidth <- scale_linewidth_continuous #' @rdname scale_linewidth #' @export scale_linewidth_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = c(1, 6), n.breaks = NULL, + limits = NULL, range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins") { - binned_scale("linewidth", palette = pal_rescale(range), name = name, + 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) @@ -68,32 +71,33 @@ scale_linewidth_discrete <- function(...) { #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_ordinal <- function(name = waiver(), ..., range = c(2, 6)) { - force(range) - - discrete_scale( - "linewidth", name = name, - palette = function(n) seq(range[1], range[2], length.out = n), - ... - ) +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 { + NULL + } + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_datetime <- function(name = waiver(), ..., range = c(1, 6)) { +scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { + palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - "linewidth", transform = "time", name = name, - palette = pal_rescale(range), ... + aesthetics, transform = "time", name = name, + palette = palette, ... ) } #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_date <- function(name = waiver(), ..., range = c(1, 6)) { +scale_linewidth_date <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { + palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - "linewidth", transform = "date", name = name, - palette = pal_rescale(range), ... + aesthetics, transform = "date", name = name, + palette = palette, ... ) } diff --git a/R/scale-manual.R b/R/scale-manual.R index 6e96a54c3b..9f6284361b 100644 --- a/R/scale-manual.R +++ b/R/scale-manual.R @@ -11,7 +11,7 @@ #' `scale_discrete_manual()` is a generic scale that can work with any aesthetic or set #' of aesthetics provided via the `aesthetics` argument. #' -#' @inheritParams scale_x_discrete +#' @inheritParams discrete_scale #' @inheritDotParams discrete_scale -expand -position -aesthetics -palette -scale_name #' @param aesthetics Character string or vector of character strings listing the #' name(s) of the aesthetic(s) that this scale works with. This can be useful, for @@ -103,38 +103,38 @@ 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) { - manual_scale("size", values, breaks, ..., na.value = na.value) +scale_size_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "size") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other shape scales: [scale_shape()], [scale_shape_identity()]. #' @export -scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("shape", values, breaks, ..., na.value = na.value) +scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "shape") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other linetype scales: [scale_linetype()], [scale_linetype_identity()]. #' @export -scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = "blank") { - manual_scale("linetype", values, breaks, ..., na.value = na.value) +scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "linetype") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other alpha scales: [scale_alpha()], [scale_alpha_identity()]. #' @export -scale_linewidth_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("linewidth", values, breaks, ..., na.value = na.value) +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) { - manual_scale("alpha", values, breaks, ..., na.value = na.value) +scale_alpha_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "alpha") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual @@ -171,12 +171,12 @@ manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), } # order values according to breaks - if (is.vector(values) && is.null(names(values)) && !is.waive(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 { - names(values) <- breaks[1:length(values)] + names(values) <- breaks[seq_along(values)] } } diff --git a/R/scale-shape.R b/R/scale-shape.R index 7c4c750519..bde6756840 100644 --- a/R/scale-shape.R +++ b/R/scale-shape.R @@ -9,9 +9,16 @@ #' #' @param solid Should the shapes be solid, `TRUE`, or hollow, #' `FALSE`? -#' @inheritParams scale_x_discrete -#' @inheritDotParams discrete_scale -expand -position -scale_name +#' @inheritParams discrete_scale +#' @inheritDotParams discrete_scale -expand -position -scale_name -palette #' @rdname scale_shape +#' @details +#' Shapes can be referred to by number or name. Shapes in \[0, 20\] do not +#' support a fill aesthetic, whereas shapes in \[21, 25\] do. +#' +#' \if{html}{\figure{shape_table.svg}{All shapes by number and name}} +#' \if{latex}{\figure{shape_table.pdf}} +#' #' @seealso #' The documentation for [differentiation related aesthetics][aes_linetype_size_shape]. #' @@ -42,14 +49,16 @@ #' scale_shape_identity() + #' facet_wrap(~shape) + #' theme_void() -scale_shape <- function(name = waiver(), ..., solid = TRUE) { - discrete_scale("shape", name = name, palette = pal_shape(solid), ...) +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) { - binned_scale("shape", name = name, palette = pal_binned(pal_shape(solid)), ...) +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, ...) } #' @rdname scale_shape diff --git a/R/scale-size.R b/R/scale-size.R index 33f14d4834..964abf16a6 100644 --- a/R/scale-size.R +++ b/R/scale-size.R @@ -52,11 +52,13 @@ NULL #' @export #' @usage NULL scale_size_continuous <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = c(1, 6), + limits = NULL, range = NULL, transform = "identity", trans = deprecated(), - guide = "legend") { - continuous_scale("size", palette = pal_area(range), name = name, + 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) } @@ -70,8 +72,8 @@ scale_size <- scale_size_continuous scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = c(1, 6), transform = "identity", trans = deprecated(), - guide = "legend") { - continuous_scale("size", palette = pal_rescale(range), name = name, + 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) } @@ -79,10 +81,12 @@ scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), #' @rdname scale_size #' @export scale_size_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), - limits = NULL, range = c(1, 6), n.breaks = NULL, + limits = NULL, range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins") { - binned_scale("size", palette = pal_area(range), name = name, + 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) @@ -101,26 +105,22 @@ scale_size_discrete <- function(...) { #' @rdname scale_size #' @export #' @usage NULL -scale_size_ordinal <- function(name = waiver(), ..., range = c(2, 6)) { - force(range) - - discrete_scale( - "size", name = name, - palette = function(n) { - area <- seq(range[1] ^ 2, range[2] ^ 2, length.out = n) - sqrt(area) - }, - ... - ) +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 { + NULL + } + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @inheritDotParams continuous_scale -aesthetics -scale_name -palette -rescaler -expand -position #' @param max_size Size of largest points. #' @export #' @rdname scale_size -scale_size_area <- function(name = waiver(), ..., max_size = 6) { +scale_size_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { continuous_scale( - "size", name = name, + aesthetics, name = name, palette = abs_area(max_size), rescaler = rescale_max, ... ) @@ -128,9 +128,9 @@ scale_size_area <- function(name = waiver(), ..., max_size = 6) { #' @export #' @rdname scale_size -scale_size_binned_area <- function(name = waiver(), ..., max_size = 6) { +scale_size_binned_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { binned_scale( - "size", name = name, + aesthetics, name = name, palette = abs_area(max_size), rescaler = rescale_max, ... ) @@ -139,13 +139,15 @@ scale_size_binned_area <- function(name = waiver(), ..., max_size = 6) { #' @rdname scale_size #' @export #' @usage NULL -scale_size_datetime <- function(name = waiver(), ..., range = c(1, 6)) { - datetime_scale("size", "time", name = name, palette = pal_area(range), ...) +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, ...) } #' @rdname scale_size #' @export #' @usage NULL -scale_size_date <- function(name = waiver(), ..., range = c(1, 6)) { - datetime_scale("size", "date", name = name, palette = pal_area(range), ...) +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-view.R b/R/scale-view.R index 3a068ea81c..a926084cd8 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -15,17 +15,16 @@ 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()) { - # continuous_range can be specified in arbitrary order, but - # continuous scales expect the one in ascending order. - continuous_scale_sorted <- sort(continuous_range) breaks <- scale$get_breaks(continuous_scale_sorted) - minor_breaks <- scale$get_breaks_minor(b = breaks, limits = 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 = limits) } + 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, @@ -46,7 +45,7 @@ view_scale_primary <- function(scale, limits = scale$get_limits(), view_scale_secondary <- function(scale, limits = scale$get_limits(), continuous_range = scale$dimension(limits = limits)) { - if (is.null(scale$secondary.axis) || is.waive(scale$secondary.axis) || scale$secondary.axis$empty()) { + 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) @@ -77,7 +76,7 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), # different breaks and labels in a different data space aesthetics = scale$aesthetics, name = scale$sec_name(), - make_title = function(self, title) self$scale$make_sec_title(title), + make_title = function(self, ...) self$scale$make_sec_title(...), continuous_range = sort(continuous_range), dimension = function(self) self$break_info$range, get_limits = function(self) self$break_info$range, @@ -91,23 +90,6 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), } } -view_scale_empty <- function() { - ggproto(NULL, ViewScale, - is_empty = function() TRUE, - is_discrete = function() NA, - dimension = function() c(0, 1), - get_limits = function() c(0, 1), - get_breaks = function() NULL, - get_breaks_minor = function() NULL, - get_labels = function(breaks = NULL) breaks, - rescale = function(x) cli::cli_abort("Not implemented."), - map = function(x) cli::cli_abort("Not implemented."), - make_title = function(title) title, - break_positions = function() NULL, - break_positions_minor = function() NULL - ) -} - ViewScale <- ggproto("ViewScale", NULL, # map, rescale, and make_title need a reference # to the original scale @@ -135,6 +117,9 @@ ViewScale <- ggproto("ViewScale", NULL, rescale = function(self, x) { self$scale$rescale(x, self$limits, self$continuous_range) }, + reverse = function(self, x) { + self$scale$rescale(x, rev(self$limits), rev(self$continuous_range)) + }, map = function(self, x) { if (self$is_discrete()) { self$scale$map(x, self$limits) @@ -142,8 +127,18 @@ ViewScale <- ggproto("ViewScale", NULL, x } }, - make_title = function(self, title) { - self$scale$make_title(title) + make_title = function(self, ...) { + self$scale$make_title(...) + }, + mapped_breaks = function(self) { + self$map(self$get_breaks()) + }, + mapped_breaks_minor = function(self) { + b <- self$get_breaks_minor() + if (is.null(b)) { + return(NULL) + } + self$map(b) }, break_positions = function(self) { self$rescale(self$get_breaks()) @@ -155,5 +150,31 @@ ViewScale <- ggproto("ViewScale", NULL, } self$rescale(b) + }, + make_fixed_copy = function(self) { + breaks <- self$get_breaks() + minor <- self$get_breaks_minor() + transform <- self$scale$get_transformation() + + if (self$scale$is_discrete()) { + limits <- self$get_limits() + } else { + limits <- self$continuous_range + } + + if (!is.null(transform)) { + breaks <- transform$inverse(breaks) + minor <- transform$inverse(minor) + } + + ggproto( + NULL, self$scale, + breaks = breaks, + minor_breaks = minor, + limits = limits, + expand = c(0, 0, 0, 0), + continuous_limits = self$continuous_range, + train = function (...) NULL + ) } ) diff --git a/R/scales-.R b/R/scales-.R index e62eb0e8cb..6c14347f49 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -78,7 +78,8 @@ ScalesList <- ggproto("ScalesList", NULL, function(scale) scale$map_df(df = df) ), recursive = FALSE) - data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))]) + df[names(mapped)] <- mapped + df }, transform_df = function(self, df) { @@ -104,7 +105,8 @@ ScalesList <- ggproto("ScalesList", NULL, function(scale) scale$transform_df(df = df) ), recursive = FALSE) - data_frame0(!!!transformed, df[setdiff(names(df), names(transformed))]) + df[names(transformed)] <- transformed + df }, backtransform_df = function(self, df) { @@ -139,10 +141,8 @@ ScalesList <- ggproto("ScalesList", NULL, } ), recursive = FALSE) - data_frame0( - !!!backtransformed, - df[setdiff(names(df), names(backtransformed))] - ) + df[names(backtransformed)] <- backtransformed + df }, # `aesthetics` is a list of aesthetic-variable mappings. The name of each @@ -154,6 +154,7 @@ ScalesList <- ggproto("ScalesList", NULL, return() } + for (aes in new_aesthetics) { self$add(find_scale(aes, data[[aes]], env)) } @@ -168,6 +169,39 @@ ScalesList <- ggproto("ScalesList", NULL, scale_name <- paste("scale", aes, "continuous", sep = "_") self$add(find_global(scale_name, env, mode = "function")()) } + }, + + set_palettes = function(self, theme) { + for (scale in self$scales) { + if (!is.null(scale$palette)) { + next + } + + # Resolve palette theme setting for this scale + type <- if (scale$is_discrete()) "discrete" else "continuous" + elem <- paste0("palette.", scale$aesthetics, ".", type) + elem <- compact(lapply(elem, calc_element, theme))[1][[1]] + + # Resolve the palette itself + elem <- elem %||% fallback_palette(scale) + palette <- switch( + type, + discrete = as_discrete_pal(elem), + continuous = as_continuous_pal(elem) + ) + if (!is.function(palette)) { + cli::cli_warn( + "Failed to find palette for {.field {scale$aesthetics[1]}} scale." + ) + } + + # Set palette to scale + # Note: while direct assignment is not ideal, we've already cloned the + # scale at the beginning of the plot build method, so it doesn't affect + # other plots + scale$palette <- palette + invisible() + } } ) diff --git a/R/stat-align.R b/R/stat-align.R index 5f49b29152..3187ca28c0 100644 --- a/R/stat-align.R +++ b/R/stat-align.R @@ -40,22 +40,19 @@ StatAlign <- ggproto("StatAlign", Stat, if (empty(data)) { return(data_frame0()) } - + if (is_unique(data$group)) { + return(data) + } names <- flipped_names(flipped_aes) x <- data[[names$x]] y <- data[[names$y]] - if (is_unique(data$group)) { - # No need for interpolation - cross <- x[0] - } else { - # Find positions where 0 is crossed - 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] - } + # Find positions where 0 is crossed + 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] unique_loc <- unique(sort(c(x, cross))) adjust <- diff(range(unique_loc, na.rm = TRUE)) * 0.001 diff --git a/R/stat-bin.R b/R/stat-bin.R index 4f35d83a84..f65b54857b 100644 --- a/R/stat-bin.R +++ b/R/stat-bin.R @@ -1,8 +1,7 @@ #' @param binwidth The width of the bins. Can be specified as a numeric value -#' or as a function that calculates width from unscaled x. Here, "unscaled x" -#' refers to the original x values in the data, before application of any -#' scale transformation. When specifying a function along with a grouping -#' structure, the function will be called once per group. +#' or as a function that takes x after scale transformation as input and +#' returns a single numeric value. When specifying a function along with a +#' grouping structure, the function will be called once per group. #' The default is to use the number of bins in `bins`, #' covering the range of the data. You should always override #' this value, exploring multiple widths to find the best to illustrate the @@ -22,11 +21,16 @@ #' outside the range of the data. #' @param breaks Alternatively, you can supply a numeric vector giving #' the bin boundaries. Overrides `binwidth`, `bins`, `center`, -#' and `boundary`. +#' and `boundary`. Can also be a function that takes group-wise values as input and returns bin boundaries. #' @param closed One of `"right"` or `"left"` indicating whether right #' or left edges of bins are included in the bin. #' @param pad If `TRUE`, adds empty bins at either end of x. This ensures #' frequency polygons touch 0. Defaults to `FALSE`. +#' @param drop Treatment of zero count bins. If `"none"` (default), such +#' bins are kept as-is. If `"all"`, all zero count bins are filtered out. +#' If `"extremes"` only zero count bins at the flanks are filtered out, but +#' not in the middle. `TRUE` is shorthand for `"all"` and `FALSE` is shorthand +#' for `"none"`. #' @eval rd_computed_vars( #' count = "number of points in bin.", #' density = "density of points in bin, scaled to integrate to 1.", @@ -56,6 +60,7 @@ stat_bin <- function(mapping = NULL, data = NULL, closed = c("right", "left"), pad = FALSE, na.rm = FALSE, + drop = "none", orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -78,6 +83,7 @@ stat_bin <- function(mapping = NULL, data = NULL, pad = pad, na.rm = na.rm, orientation = orientation, + drop = drop, ... ) ) @@ -91,6 +97,15 @@ StatBin <- ggproto("StatBin", Stat, setup_params = function(self, data, params) { 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" + } + drop <- params$drop + params$drop <- arg_match0( + params$drop %||% "none", + 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) { @@ -109,29 +124,7 @@ StatBin <- ggproto("StatBin", Stat, )) } - if (!is.null(params$drop)) { - deprecate_warn0("2.1.0", "stat_bin(drop)", "stat_bin(pad)") - params$drop <- NULL - } - if (!is.null(params$origin)) { - deprecate_warn0("2.1.0", "stat_bin(origin)", "stat_bin(boundary)") - params$boundary <- params$origin - params$origin <- NULL - } - if (!is.null(params$right)) { - deprecate_warn0("2.1.0", "stat_bin(right)", "stat_bin(closed)") - params$closed <- if (params$right) "right" else "left" - params$right <- NULL - } - if (!is.null(params$boundary) && !is.null(params$center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified in {.fn {snake_class(self)}}.") - } - - if (is.null(params$breaks) && is.null(params$binwidth) && is.null(params$bins)) { - cli::cli_inform("{.fn {snake_class(self)}} using {.code bins = 30}. Pick better value with {.arg binwidth}.") - params$bins <- 30 - } - + params <- fix_bin_params(params, fun = snake_class(self), version = "2.1.0") params }, @@ -140,27 +133,25 @@ StatBin <- ggproto("StatBin", Stat, compute_group = function(data, scales, binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, closed = c("right", "left"), pad = FALSE, - breaks = NULL, flipped_aes = FALSE, + breaks = NULL, flipped_aes = FALSE, drop = "none", # The following arguments are not used, but must # be listed so parameters are computed correctly - origin = NULL, right = NULL, drop = NULL) { + origin = NULL, right = NULL) { x <- flipped_names(flipped_aes)$x - if (!is.null(breaks)) { - if (!scales[[x]]$is_discrete()) { - breaks <- scales[[x]]$transform(breaks) - } - bins <- bin_breaks(breaks, closed) - } else if (!is.null(binwidth)) { - if (is.function(binwidth)) { - binwidth <- binwidth(data[[x]]) - } - bins <- bin_breaks_width(scales[[x]]$dimension(), binwidth, - center = center, boundary = boundary, closed = closed) - } else { - bins <- bin_breaks_bins(scales[[x]]$dimension(), bins, center = center, - boundary = boundary, closed = closed) - } + bins <- compute_bins( + 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) + + keep <- switch( + drop, + all = bins$count != 0, + extremes = inner_runs(bins$count != 0), + TRUE + ) + bins <- vec_slice(bins, keep) bins$flipped_aes <- flipped_aes flip_data(bins, flipped_aes) }, @@ -172,3 +163,12 @@ StatBin <- ggproto("StatBin", Stat, dropped_aes = "weight" # after statistical transformation, weights are no longer available ) +inner_runs <- function(x) { + rle <- vec_unrep(x) + nruns <- nrow(rle) + inner <- rep(TRUE, nruns) + i <- unique(c(1, nruns)) + inner[i] <- inner[i] & rle$key[i] + rep(inner, rle$times) +} + diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index 69f57ebee3..fe27a41162 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -1,7 +1,4 @@ -#' @param bins numeric vector giving number of bins in both vertical and -#' horizontal directions. Set to 30 by default. -#' @param binwidth Numeric vector giving bin width in both vertical and -#' horizontal directions. Overrides `bins` if both set. +#' @inheritParams stat_bin #' @param drop if `TRUE` removes all cells with 0 counts. #' @export #' @rdname geom_bin_2d @@ -11,11 +8,21 @@ #' ncount = "count, scaled to maximum of 1.", #' ndensity = "density, scaled to a maximum of 1." #' ) +#' @section Controlling binning parameters for the x and y directions: +#' The arguments `bins`, `binwidth`, `breaks`, `center`, and `boundary` can +#' be set separately for the x and y directions. When given as a scalar, one +#' value applies to both directions. When given as a vector of length two, +#' the first is applied to the x direction and the second to the y direction. +#' Alternatively, these can be a named list containing `x` and `y` elements, +#' for example `list(x = 10, y = 20)`. stat_bin_2d <- function(mapping = NULL, data = NULL, geom = "tile", position = "identity", ..., bins = 30, binwidth = NULL, + center = NULL, + boundary = NULL, + breaks = NULL, drop = TRUE, na.rm = FALSE, show.legend = NA, @@ -31,6 +38,9 @@ stat_bin_2d <- function(mapping = NULL, data = NULL, params = list2( bins = bins, binwidth = binwidth, + center = center, + boundary = boundary, + breaks = breaks, drop = drop, na.rm = na.rm, ... @@ -45,48 +55,37 @@ stat_bin_2d <- function(mapping = NULL, data = NULL, stat_bin2d <- stat_bin_2d #' @rdname ggplot2-ggproto +#' @include stat-summary-2d.R #' @format NULL #' @usage NULL #' @export -StatBin2d <- ggproto("StatBin2d", Stat, +StatBin2d <- ggproto( + "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, origin = NULL, drop = TRUE) { + breaks = NULL, origin = NULL, drop = TRUE, + boundary = NULL, closed = NULL, center = NULL) { - origin <- dual_param(origin, list(NULL, NULL)) - binwidth <- dual_param(binwidth, list(NULL, NULL)) - breaks <- dual_param(breaks, list(NULL, NULL)) - bins <- dual_param(bins, list(x = 30, y = 30)) + data$z <- data$weight %||% 1 + data$weight <- NULL - xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) - ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) + # For backward compatibility, boundary defaults to 0 + boundary <- boundary %||% if (is.null(center)) list(x = 0, y = 0) - xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) - ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) - - if (is.null(data$weight)) - data$weight <- 1 - - out <- tapply_df(data$weight, list(xbin = xbin, ybin = ybin), sum, drop = drop) - - xdim <- bin_loc(xbreaks, out$xbin) - out$x <- xdim$mid - out$width <- xdim$length - - ydim <- bin_loc(ybreaks, out$ybin) - out$y <- ydim$mid - out$height <- ydim$length + out <- StatSummary2d$compute_group( + data, scales, binwidth = binwidth, bins = bins, breaks = breaks, + drop = drop, fun = "sum", boundary = boundary, closed = closed, + center = center + ) out$count <- out$value out$ncount <- out$count / max(out$count, na.rm = TRUE) out$density <- out$count / sum(out$count, na.rm = TRUE) out$ndensity <- out$density / max(out$density, na.rm = TRUE) out - }, - - dropped_aes = "weight" # No longer available after transformation + } ) dual_param <- function(x, default = list(x = NULL, y = NULL)) { @@ -102,64 +101,3 @@ dual_param <- function(x, default = list(x = NULL, y = NULL)) { list(x = x, y = x) } } - -bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL, - bins = 30, right = TRUE) { - # Bins for categorical data should take the width of one level, - # and should show up centered over their tick marks. All other parameters - # are ignored. - if (scale$is_discrete()) { - breaks <- scale$get_breaks() - return(-0.5 + seq_len(length(breaks) + 1)) - } else { - if (!is.null(breaks)) { - breaks <- scale$transform(breaks) - } - } - - if (!is.null(breaks)) - return(breaks) - - range <- scale$get_limits() - - if (is.null(binwidth) || identical(binwidth, NA)) { - binwidth <- diff(range) / bins - } - check_number_decimal(binwidth) - - if (is.null(origin) || identical(origin, NA)) { - origin <- round_any(range[1], binwidth, floor) - } - check_number_decimal(origin) - - breaks <- seq(origin, range[2] + binwidth, binwidth) - - # Check if the last bin lies fully outside the range - if (length(breaks) > 1 && breaks[length(breaks) - 1] >= range[2]) { - breaks <- breaks[-length(breaks)] - } - - adjust_breaks(breaks, right) -} - -adjust_breaks <- function(x, right = TRUE) { - diddle <- 1e-07 * stats::median(diff(x)) - if (right) { - fuzz <- c(-diddle, rep.int(diddle, length(x) - 1)) - } else { - fuzz <- c(rep.int(-diddle, length(x) - 1), diddle) - } - sort(x) + fuzz -} - -bin_loc <- function(x, id) { - left <- x[-length(x)] - right <- x[-1] - - list( - left = left[id], - right = right[id], - mid = ((left + right) / 2)[id], - length = diff(x)[id] - ) -} diff --git a/R/stat-bindot.R b/R/stat-bindot.R index 66e40ce6cb..66184a527c 100644 --- a/R/stat-bindot.R +++ b/R/stat-bindot.R @@ -77,13 +77,11 @@ StatBindot <- ggproto("StatBindot", Stat, } if (method == "histodot") { - closed <- if (right) "right" else "left" - if (!is.null(binwidth)) { - bins <- bin_breaks_width(range, binwidth, boundary = origin, closed = closed) - } else { - bins <- bin_breaks_bins(range, 30, boundary = origin, closed = closed) - } - + bins <- compute_bins( + 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 @@ -143,14 +141,14 @@ densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range # Sort weight and x, by x weight <- weight[order(x)] - x <- x[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 1:length(x)) { + 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 diff --git a/R/stat-binhex.R b/R/stat-binhex.R index 0b5d3991c6..be5b61daf7 100644 --- a/R/stat-binhex.R +++ b/R/stat-binhex.R @@ -7,6 +7,13 @@ #' ncount = "count, scaled to maximum of 1.", #' ndensity = "density, scaled to maximum of 1." #' ) +#' @section Controlling binning parameters for the x and y directions: +#' The arguments `bins` and `binwidth` can +#' be set separately for the x and y directions. When given as a scalar, one +#' value applies to both directions. When given as a vector of length two, +#' the first is applied to the x direction and the second to the y direction. +#' Alternatively, these can be a named list containing `x` and `y` elements, +#' for example `list(x = 10, y = 20)`. stat_bin_hex <- function(mapping = NULL, data = NULL, geom = "hex", position = "identity", ..., diff --git a/R/stat-connect.R b/R/stat-connect.R new file mode 100644 index 0000000000..48a193fdf1 --- /dev/null +++ b/R/stat-connect.R @@ -0,0 +1,162 @@ +#' Connect observations +#' +#' Connect successive points with lines of different shapes. +#' +#' @inheritParams layer +#' @inheritParams geom_point +#' @param connection A specification of how two points are connected. Can be one +#' of the folloing: +#' * A string giving a named connection. These options are: +#' * `"hv"` to first jump horizontally, then vertically. +#' * `"vh"` to first jump vertically, then horizontally. +#' * `"mid"` to step half-way between adjacent x-values. +#' * `"linear"` to use a straight segment. +#' * A numeric matrix with two columns giving x and y coordinates respectively. +#' The coordinates should describe points on a path that connect point A +#' at location (0, 0) and point B at location (1, 1). At least one of these +#' two points is expected to be included in the coordinates. +#' +#' @eval rd_aesthetics("stat", "connect") +#' @export +#' +#' @examples +#' ggplot(head(economics, 20), aes(date, unemploy)) + +#' stat_connect(connection = "hv") +#' +#' # Setup custom connections +#' x <- seq(0, 1, length.out = 20)[-1] +#' smooth <- cbind(x, scales::rescale(1 / (1 + exp(-(x * 10 - 5))))) +#' zigzag <- cbind(c(0.4, 0.6, 1), c(0.75, 0.25, 1)) +#' +#' ggplot(head(economics, 10), aes(date, unemploy)) + +#' geom_point() + +#' stat_connect(aes(colour = "zigzag"), connection = zigzag) + +#' stat_connect(aes(colour = "smooth"), connection = smooth) +stat_connect <- function( + mapping = NULL, + data = NULL, + geom = "path", + position = "identity", + ..., + connection = "hv", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE) { + layer( + data = data, + mapping = mapping, + stat = StatConnect, + geom = geom, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + connection = connection, + ... + ) + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatConnect <- ggproto( + "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 + ) + + connection <- params$connection %||% "hv" + + if (is.character(connection)) { + 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) + ) + } + + if (!is.matrix(connection) || + !typeof(connection) %in% c("integer", "double") || + !identical(dim(connection)[2], 2L)) { + extra <- "" + if (!is.null(dim(connection)[2])) { + extra <- paste0(" with ", dim(connection)[2], " column(s)") + } + cli::cli_abort( + "{.arg connection} must be a numeric {.cls matrix} with 2 columns, \\ + not {.obj_type_friendly {connection}}{extra}." + ) + } + + if (any(!is.finite(connection))) { + cli::cli_abort( + "{.arg connection} cannot contain missing or other non-finite values." + ) + } + + if (nrow(connection) < 1) { + connection <- NULL + } + + params$connection <- connection + params + }, + + compute_group = function(data, scales, connection = "hv", flipped_aes = FALSE) { + + data <- flip_data(data, flipped_aes) + + n <- nrow(data) + if (n <= 1) { + return(vec_slice(data, 0)) + } + + if (!is.matrix(connection)) { + return(data) + } + m <- nrow(connection) + + before <- rep(seq_len(n - 1), each = m) + after <- rep(seq_len(n)[-1], each = m) + + data <- vec_slice(data, order(data$x %||% data$xmin)) + + # Interpolate x + # 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) + 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) + y <- vec_slice(y, before) * (1 - yjust) + vec_slice(y, after) * yjust + + # Reconstitute data + new_data <- vec_slice(data, before) + new_data[colnames(x)] <- split_matrix(x) + new_data[colnames(y)] <- split_matrix(y) + + # Esnure data starts and ends are intact + if (!all(connection[1, ] == c(0, 0))) { + new_data <- vec_c(vec_slice(data, 1), new_data) + } + if (!all(connection[m, ] == c(1, 1))) { + new_data <- vec_c(new_data, vec_slice(data, n)) + } + flip_data(new_data, flipped_aes) + } + +) diff --git a/R/stat-contour.R b/R/stat-contour.R index 882879430d..0602ed3899 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -104,15 +104,20 @@ StatContour <- ggproto("StatContour", Stat, 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)) - path_df <- iso_to_path(isolines, data$group[1]) + path_df <- iso_to_geom(isolines, data$group[1], geom = "path") path_df$level <- as.numeric(path_df$level) path_df$nlevel <- rescale_max(path_df$level) + # Re-apply data rotation + path_df[c("x", "y")] <- rotate_xy(path_df$x, path_df$y, rotation) path_df } ) @@ -138,17 +143,24 @@ StatContourFilled <- ggproto("StatContourFilled", Stat, }, 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)) names(isobands) <- pretty_isoband_levels(names(isobands)) - path_df <- iso_to_polygon(isobands, data$group[1]) + 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$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) path_df } @@ -259,51 +271,17 @@ isoband_z_matrix <- function(data) { raster } -#' Convert the output of isolines functions -#' -#' @param iso the output of [isoband::isolines()] -#' @param group the name of the group -#' -#' @return A data frame that can be passed to [geom_path()]. -#' @noRd -#' -iso_to_path <- function(iso, group = 1) { - lengths <- vapply(iso, function(x) length(x$x), integer(1)) - - if (all(lengths == 0)) { - cli::cli_warn("{.fn stat_contour}: Zero contours were generated") - return(data_frame0()) - } - - levels <- names(iso) - xs <- unlist(lapply(iso, "[[", "x"), use.names = FALSE) - ys <- unlist(lapply(iso, "[[", "y"), use.names = FALSE) - ids <- unlist(lapply(iso, "[[", "id"), use.names = FALSE) - item_id <- rep(seq_along(iso), lengths) - - # Add leading zeros so that groups can be properly sorted - groups <- paste(group, sprintf("%03d", item_id), sprintf("%03d", ids), sep = "-") - groups <- factor(groups) - - data_frame0( - level = rep(levels, lengths), - x = xs, - y = ys, - piece = as.integer(groups), - group = groups, - .size = length(xs) - ) -} - #' Convert the output of isoband functions #' -#' @param iso the output of [isoband::isobands()] +#' @param iso the output of [isoband::isobands()] or [isoband::isolines()] #' @param group the name of the group +#' @param geom The type of geometry to return. Either `"path"` or `"polygon"` +#' for isolines and isobands respectively. #' -#' @return A data frame that can be passed to [geom_polygon()]. +#' @return A data frame that can be passed to [geom_polygon()] or [geom_path()]. #' @noRd #' -iso_to_polygon <- function(iso, group = 1) { +iso_to_geom <- function(iso, group = 1, geom = "path") { lengths <- vapply(iso, function(x) length(x$x), integer(1)) if (all(lengths == 0)) { @@ -319,6 +297,11 @@ iso_to_polygon <- function(iso, group = 1) { # Add leading zeros so that groups can be properly sorted groups <- paste(group, sprintf("%03d", item_id), sep = "-") + if (geom == "path") { + groups <- paste(groups, sprintf("%03d", ids), sep = "-") + ids <- NULL + } + groups <- factor(groups) data_frame0( @@ -385,3 +368,49 @@ contour_deduplicate <- function(data, check = c("x", "y", "group", "PANEL")) { } data } + +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))) + i <- which.max(freq) + + # If this angle represents less than half of the angles, we probably + # have unordered data, in which case the approach above is invalid + if ((freq[i] / sum(freq)) < 0.5) { + # In such case, try approach with convex hull + hull <- grDevices::chull(x, y) + hull <- c(hull, hull[1]) + # Find largest edge along hull + dx <- diff(x[hull]) + dy <- diff(y[hull]) + i <- which.max(sqrt(dx^2 + dy^2)) + # Take angle of largest edge + angle <- atan2(dy[i], dx[i]) + } else { + angle <- all_angles[i] + } + + # 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) + if (any(straight)) { + return(0) + } + angle +} + +rotate_xy <- function(x, y, angle) { + # Skip rotation if angle was straight + if (angle == 0) { + return(list(x = x, y = y)) + } + cos <- cos(angle) + sin <- sin(angle) + # Using zapsmall to make `unique0` later recognise values that may have + # rounding errors. + list( + x = zapsmall(cos * x - sin * y, digits = 13), + y = zapsmall(sin * x + cos * y, digits = 13) + ) +} diff --git a/R/stat-count.R b/R/stat-count.R index 18dc1ebaa6..fd78d1beaa 100644 --- a/R/stat-count.R +++ b/R/stat-count.R @@ -13,7 +13,6 @@ stat_count <- function(mapping = NULL, data = NULL, geom = "bar", position = "stack", ..., - width = NULL, na.rm = FALSE, orientation = NA, show.legend = NA, @@ -22,7 +21,6 @@ stat_count <- function(mapping = NULL, data = NULL, params <- list2( na.rm = na.rm, orientation = orientation, - width = width, ... ) diff --git a/R/stat-density-2d.R b/R/stat-density-2d.R index 3fd6cf60ee..69bef8430c 100644 --- a/R/stat-density-2d.R +++ b/R/stat-density-2d.R @@ -138,11 +138,15 @@ StatDensity2d <- ggproto("StatDensity2d", Stat, contour_type = "lines", compute_layer = function(self, data, params, layout) { + check_installed("MASS", reason = "for calculating 2D density.") # first run the regular layer calculation to infer densities data <- ggproto_parent(Stat, self)$compute_layer(data, params, layout) + if (empty(data)) { + return(data_frame0()) + } # if we're not contouring we're done - if (!isTRUE(params$contour)) return(data) + if (!isTRUE(params$contour %||% TRUE)) return(data) # set up data and parameters for contouring contour_var <- params$contour_var %||% "density" @@ -177,10 +181,8 @@ StatDensity2d <- ggproto("StatDensity2d", Stat, compute_group = function(data, scales, na.rm = FALSE, h = NULL, adjust = c(1, 1), n = 100, ...) { - if (is.null(h)) { - h <- c(MASS::bandwidth.nrd(data$x), MASS::bandwidth.nrd(data$y)) - h <- h * adjust - } + + h <- precompute_2d_bw(data$x, data$y, h = h, adjust = adjust) # calculate density dens <- MASS::kde2d( @@ -213,3 +215,27 @@ StatDensity2dFilled <- ggproto("StatDensity2dFilled", StatDensity2d, contour_type = "bands" ) +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] <- bw.nrd0(x) * 4 + if (h[2] == 0 && length(y) > 1) h[2] <- bw.nrd0(y) * 4 + h <- h * adjust + } + + check_numeric(h) + check_length(h, 2L) + + if (any(is.na(h) | h <= 0)) { + cli::cli_abort(c( + "The bandwidth argument {.arg h} must contain numbers larger than 0.", + i = "Please set the {.arg h} argument to stricly positive numbers manually." + )) + } + + h +} + diff --git a/R/stat-density.R b/R/stat-density.R index 4bf28f797b..5b948f5d88 100644 --- a/R/stat-density.R +++ b/R/stat-density.R @@ -24,6 +24,8 @@ #' @eval rd_computed_vars( #' density = "density estimate.", #' count = "density * number of points - useful for stacked density plots.", +#' wdensity = "density * sum of weights. In absence of weights, the same as +#' `count`.", #' scaled = "density estimate, scaled to maximum of 1.", #' n = "number of points.", #' ndensity = "alias for `scaled`, to mirror the syntax of [`stat_bin()`]." @@ -113,17 +115,19 @@ StatDensity <- ggproto("StatDensity", Stat, compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, bounds = c(-Inf, Inf)) { - nx <- length(x) + nx <- w_sum <- length(x) if (is.null(w)) { w <- rep(1 / nx, nx) } else { - w <- w / sum(w) + w_sum <- sum(w) + w <- w / w_sum } # Adjust data points and weights to all fit inside bounds sample_data <- fit_data_to_bounds(bounds, x, w) x <- sample_data$x w <- sample_data$w + w_sum <- sample_data$w_sum * w_sum nx <- length(x) # if less than 2 points return data frame of NAs and a warning @@ -135,6 +139,7 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, scaled = NA_real_, ndensity = NA_real_, count = NA_real_, + wdensity = NA_real_, n = NA_integer_, .size = 1 )) @@ -143,10 +148,23 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, bw <- precompute_bw(x, bw) # Decide whether to use boundary correction if (any(is.finite(bounds))) { - dens <- stats::density(x, weights = w, bw = bw, adjust = adjust, - kernel = kernel, n = n) + # To prevent discontinuities, we widen the range before calling the + # unbounded estimator (#5641). + 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 <- reflect_density(dens = dens, bounds = bounds, from = from, to = to) + dens <- stats::density( + 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] + ) } else { dens <- stats::density(x, weights = w, bw = bw, adjust = adjust, kernel = kernel, n = n, from = from, to = to) @@ -158,6 +176,7 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, scaled = dens$y / max(dens$y, na.rm = TRUE), ndensity = dens$y / max(dens$y, na.rm = TRUE), count = dens$y * nx, + wdensity = dens$y * w_sum, n = nx, .size = length(dens$x) ) @@ -166,7 +185,7 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, # Check if all data points are inside bounds. If not, warn and remove them. fit_data_to_bounds <- function(bounds, x, w) { is_inside_bounds <- (bounds[1] <= x) & (x <= bounds[2]) - + w_sum <- 1 if (!all(is_inside_bounds)) { cli::cli_warn("Some data points are outside of `bounds`. Removing them.") x <- x[is_inside_bounds] @@ -177,7 +196,7 @@ fit_data_to_bounds <- function(bounds, x, w) { } } - return(list(x = x, w = w)) + return(list(x = x, w = w, w_sum = w_sum)) } # Update density estimation to mitigate boundary effect at known `bounds`: @@ -220,9 +239,10 @@ reflect_density <- function(dens, bounds, from, to) { # Similar to stats::density.default # Once R4.3.0 is the lowest supported version, this function can be replaced by # using `density(..., warnWbw = FALSE)`. -precompute_bw = function(x, bw = "nrd0") { +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 <- switch( to_lower_ascii(bw), diff --git a/R/stat-ecdf.R b/R/stat-ecdf.R index 5f7e5fdd30..96430b1e32 100644 --- a/R/stat-ecdf.R +++ b/R/stat-ecdf.R @@ -12,6 +12,10 @@ #' and one of them must be unused. The ECDF will be calculated on the given aesthetic #' and will be output on the unused one. #' +#' If the `weight` aesthetic is provided, a weighted ECDF will be computed. In +#' this case, the ECDF is incremented by `weight / sum(weight)` instead of +#' `1 / length(x)` for each observation. +#' #' @inheritParams layer #' @inheritParams geom_point #' @param na.rm If `FALSE` (the default), removes missing values with @@ -20,10 +24,16 @@ #' of points to interpolate with. #' @param pad If `TRUE`, pad the ecdf with additional points (-Inf, 0) #' and (Inf, 1) +#' @eval rd_aesthetics("stat", "ecdf") #' @eval rd_computed_vars( #' ecdf = "Cumulative density corresponding to `x`.", #' y = "`r lifecycle::badge('superseded')` For backward compatibility." #' ) +#' @section Dropped variables: +#' \describe{ +#' \item{weight}{After calculation, weights of individual observations (if +#' supplied), are no longer available.} +#' } #' @export #' @examples #' set.seed(1) @@ -41,6 +51,17 @@ #' # Multiple ECDFs #' ggplot(df, aes(x, colour = g)) + #' stat_ecdf() +#' +#' # Using weighted eCDF +#' weighted <- data.frame(x = 1:10, weights = c(1:5, 5:1)) +#' plain <- data.frame(x = rep(weighted$x, weighted$weights)) +#' +#' ggplot(plain, aes(x)) + +#' stat_ecdf(linewidth = 1) + +#' stat_ecdf( +#' aes(weight = weights), +#' data = weighted, colour = "green" +#' ) stat_ecdf <- function(mapping = NULL, data = NULL, geom = "step", position = "identity", ..., @@ -74,7 +95,7 @@ stat_ecdf <- function(mapping = NULL, data = NULL, StatEcdf <- ggproto("StatEcdf", Stat, required_aes = c("x|y"), - default_aes = aes(x = after_stat(ecdf), y = after_stat(ecdf)), + 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) @@ -100,7 +121,7 @@ StatEcdf <- ggproto("StatEcdf", Stat, if (pad) { x <- c(-Inf, x, Inf) } - data_ecdf <- stats::ecdf(data$x)(x) + data_ecdf <- wecdf(data$x, data$weight)(x) df_ecdf <- data_frame0( x = x, @@ -110,6 +131,63 @@ StatEcdf <- ggproto("StatEcdf", Stat, ) df_ecdf$flipped_aes <- flipped_aes flip_data(df_ecdf, flipped_aes) - } + }, + + dropped_aes = "weight" ) +# Weighted eCDF function +wecdf <- function(x, weights = NULL) { + + weights <- weights %||% 1 + weights <- vec_recycle(weights, length(x)) + + # Sort vectors + ord <- order(x, na.last = NA) + x <- x[ord] + 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}.")) + weights[!is.finite(weights)] <- 0 + } + + # `total` replaces `length(x)` + total <- sum(weights) + + if (abs(total) < 1000 * .Machine$double.eps) { + if (total == 0) { + cli::cli_abort(paste0( + "Cannot compute eCDF when the {.field weight} aesthetic sums up to ", + "{.val 0}." + )) + } + cli::cli_warn(c( + "The sum of the {.field weight} aesthetic is close to {.val 0}.", + "i" = "Computed eCDF might be unstable." + )) + } + + # Link each observation to unique value + vals <- unique0(x) + matched <- match(x, vals) + + # Instead of tabulating `matched`, as we would for unweighted `ecdf(x)`, + # we sum weights per unique value of `x` + agg_weights <- vapply( + split(weights, matched), + sum, numeric(1) + ) + + # Like `ecdf(x)`, we return an approx function + stats::approxfun( + vals, + cumsum(agg_weights) / total, + method = "constant", + yleft = 0, yright = 1, + f = 0, ties = "ordered" + ) +} diff --git a/R/stat-ellipse.R b/R/stat-ellipse.R index 1a9232aa66..cc38cbbd0d 100644 --- a/R/stat-ellipse.R +++ b/R/stat-ellipse.R @@ -20,6 +20,7 @@ #' @param segments The number of segments to be used in drawing the ellipse. #' @inheritParams layer #' @inheritParams geom_point +#' @eval rd_aesthetics("stat", "ellipse") #' @export #' @examples #' ggplot(faithful, aes(waiting, eruptions)) + @@ -76,6 +77,16 @@ stat_ellipse <- function(mapping = NULL, data = NULL, #' @export StatEllipse <- ggproto("StatEllipse", Stat, required_aes = c("x", "y"), + optional_aes = "weight", + dropped_aes = "weight", + + setup_params = function(data, params) { + params$type <- params$type %||% "t" + if (identical(params$type, "t")) { + check_installed("MASS", "for calculating ellipses with `type = \"t\"`.") + } + params + }, compute_group = function(data, scales, type = "t", level = 0.95, segments = 51, na.rm = FALSE) { @@ -88,6 +99,9 @@ calculate_ellipse <- function(data, vars, type, level, segments){ dfn <- 2 dfd <- nrow(data) - 1 + weight <- data$weight %||% rep(1, nrow(data)) + weight <- weight / sum(weight) + if (!type %in% c("t", "norm", "euclid")) { cli::cli_inform("Unrecognized ellipse type") ellipse <- matrix(NA_real_, ncol = 2) @@ -96,11 +110,12 @@ calculate_ellipse <- function(data, vars, type, level, segments){ ellipse <- matrix(NA_real_, ncol = 2) } else { if (type == "t") { - v <- MASS::cov.trob(data[,vars]) + # Prone to convergence problems when `sum(weight) != nrow(data)` + v <- MASS::cov.trob(data[,vars], wt = weight * nrow(data)) } else if (type == "norm") { - v <- stats::cov.wt(data[,vars]) + v <- stats::cov.wt(data[,vars], wt = weight) } else if (type == "euclid") { - v <- stats::cov.wt(data[,vars]) + v <- stats::cov.wt(data[,vars], wt = weight) v$cov <- diag(rep(min(diag(v$cov)), 2)) } shape <- v$cov diff --git a/R/stat-function.R b/R/stat-function.R index 8f31b8daba..bf6d2e4b74 100644 --- a/R/stat-function.R +++ b/R/stat-function.R @@ -50,7 +50,7 @@ stat_function <- function(mapping = NULL, data = NULL, #' @usage NULL #' @export StatFunction <- ggproto("StatFunction", Stat, - default_aes = aes(y = after_scale(y)), + default_aes = aes(x = NULL, y = after_scale(y)), compute_group = function(data, scales, fun, xlim = NULL, n = 101, args = list()) { if (is.null(scales$x)) { diff --git a/R/stat-manual.R b/R/stat-manual.R new file mode 100644 index 0000000000..994c8d622e --- /dev/null +++ b/R/stat-manual.R @@ -0,0 +1,131 @@ + +#' Manually compute transformations +#' +#' `stat_manual()` takes a function that computes a data transformation for +#' every group. +#' +#' @inheritParams layer +#' @inheritParams geom_point +#' @param fun Function that takes a data frame as input and returns a data +#' frame or data frame-like list as output. The default (`identity()`) returns +#' the data unchanged. +#' @param args A list of arguments to pass to the function given in `fun`. +#' +#' @eval rd_aesthetics("stat", "manual") +#' @section Aesthetics: +#' Input aesthetics are determined by the `fun` argument. Output aesthetics must +#' include those required by `geom`. Any aesthetic that is constant within a +#' group will be preserved even if dropped by `fun`. +#' +#' @export +#' +#' @examples +#' # A standard scatterplot +#' p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + +#' geom_point() +#' +#' # The default just displays points as-is +#' p + stat_manual() +#' +#' # Using a custom function +#' make_hull <- function(data) { +#' hull <- chull(x = data$x, y = data$y) +#' data.frame(x = data$x[hull], y = data$y[hull]) +#' } +#' +#' p + stat_manual( +#' geom = "polygon", +#' fun = make_hull, +#' fill = NA +#' ) +#' +#' # Using the `with` function with quoting +#' p + stat_manual( +#' fun = with, +#' args = list(expr = quote({ +#' hull <- chull(x, y) +#' list(x = x[hull], y = y[hull]) +#' })), +#' geom = "polygon", fill = NA +#' ) +#' +#' # Using the `transform` function with quoting +#' p + stat_manual( +#' geom = "segment", +#' fun = transform, +#' args = list( +#' xend = quote(mean(x)), +#' yend = quote(mean(y)) +#' ) +#' ) +#' +#' # Using dplyr verbs with `vars()` +#' if (requireNamespace("dplyr", quietly = TRUE)) { +#' +#' # Get centroids with `summarise()` +#' p + stat_manual( +#' size = 10, shape = 21, +#' fun = dplyr::summarise, +#' args = vars(x = mean(x), y = mean(y)) +#' ) +#' +#' # Connect to centroid with `mutate` +#' p + stat_manual( +#' geom = "segment", +#' fun = dplyr::mutate, +#' args = vars(xend = mean(x), yend = mean(y)) +#' ) +#' +#' # Computing hull with `reframe()` +#' p + stat_manual( +#' geom = "polygon", fill = NA, +#' fun = dplyr::reframe, +#' args = vars(hull = chull(x, y), x = x[hull], y = y[hull]) +#' ) +#' } +stat_manual <- function( + mapping = NULL, + data = NULL, + geom = "point", + position = "identity", + ..., + fun = identity, + args = list(), + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE) { + + layer( + data = data, + mapping = mapping, + stat = StatManual, + geom = geom, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + fun = fun, + args = args, + ... + ) + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +StatManual <- ggproto( + "StatManual", Stat, + + setup_params = function(data, params) { + params$fun <- allow_lambda(params$fun) + check_function(params$fun, arg = "fun") + params + }, + + compute_group = function(data, scales, fun = identity, args = list()) { + as_gg_data_frame(inject(fun(data, !!!args))) + } +) diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 67b0da407d..ab6c194cfe 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -6,12 +6,12 @@ #' the data geom_qq_line <- function(mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, dparams = list(), - line.p = c(.25, .75), + line.p = c(0.25, 0.75), fullrange = FALSE, na.rm = FALSE, show.legend = NA, @@ -56,7 +56,7 @@ StatQqLine <- ggproto("StatQqLine", Stat, distribution = stats::qnorm, dparams = list(), na.rm = FALSE, - line.p = c(.25, .75), + line.p = c(0.25, 0.75), fullrange = FALSE) { sample <- sort(data$sample) @@ -86,6 +86,9 @@ StatQqLine <- ggproto("StatQqLine", Stat, x <- range(theoretical) } - data_frame0(x = x, y = slope * x + intercept) + data_frame0( + x = x, y = slope * x + intercept, + slope = slope, intercept = intercept + ) } ) diff --git a/R/stat-qq.R b/R/stat-qq.R index dc3762dacd..71068bbd04 100644 --- a/R/stat-qq.R +++ b/R/stat-qq.R @@ -22,7 +22,9 @@ #' x = "x-coordinates of the endpoints of the line segment connecting the #' points at the chosen quantiles of the theoretical and the sample #' distributions.", -#' y = "y-coordinates of the endpoints." +#' y = "y-coordinates of the endpoints.", +#' slope = "Amount of change in `y` across 1 unit of `x`.", +#' intercept = "Value of `y` at `x == 0`." #' ) #' #' @export @@ -32,8 +34,12 @@ #' p <- ggplot(df, aes(sample = y)) #' p + stat_qq() + stat_qq_line() #' -#' # Use fitdistr from MASS to estimate distribution params -#' params <- as.list(MASS::fitdistr(df$y, "t")$estimate) +#' # Use fitdistr from MASS to estimate distribution params: +#' # if (requireNamespace("MASS", quietly = TRUE)) { +#' # params <- as.list(MASS::fitdistr(df$y, "t")$estimate) +#' # } +#' # Here, we use pre-computed params +#' params <- list(m = -0.02505057194115, s = 1.122568610124, df = 6.63842653897) #' ggplot(df, aes(sample = y)) + #' stat_qq(distribution = qt, dparams = params["df"]) + #' stat_qq_line(distribution = qt, dparams = params["df"]) diff --git a/R/stat-smooth-methods.R b/R/stat-smooth-methods.R index 77d50cdff3..dc90e3c457 100644 --- a/R/stat-smooth-methods.R +++ b/R/stat-smooth-methods.R @@ -60,7 +60,7 @@ predictdf.loess <- function(model, xseq, se, level) { if (se) { y <- pred$fit - ci <- pred$se.fit * stats::qt(level / 2 + .5, pred$df) + ci <- pred$se.fit * stats::qt(level / 2 + 0.5, pred$df) ymin <- y - ci ymax <- y + ci base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) @@ -79,7 +79,7 @@ predictdf.locfit <- function(model, xseq, se, level) { if (se) { y <- pred$fit - ci <- pred$se.fit * stats::qt(level / 2 + .5, model$dp["df2"]) + ci <- pred$se.fit * stats::qt(level / 2 + 0.5, model$dp["df2"]) ymin <- y - ci ymax <- y + ci base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit) diff --git a/R/stat-smooth.R b/R/stat-smooth.R index 864e229edf..147bd06e41 100644 --- a/R/stat-smooth.R +++ b/R/stat-smooth.R @@ -18,7 +18,7 @@ #' `y ~ poly(x, 2)`, `y ~ log(x)`. `NULL` by default, in which case #' `method = NULL` implies `formula = y ~ x` when there are fewer than 1,000 #' observations and `formula = y ~ s(x, bs = "cs")` otherwise. -#' @param se Display confidence interval around smooth? (`TRUE` by default, see +#' @param se Display confidence band around smooth? (`TRUE` by default, see #' `level` to control.) #' @param fullrange If `TRUE`, the smoothing line gets expanded to the range of the plot, #' potentially beyond the data. This does not extend the line into any additional padding @@ -26,7 +26,7 @@ #' @param xseq A numeric vector of values at which the smoother is evaluated. #' When `NULL` (default), `xseq` is internally evaluated as a sequence of `n` #' equally spaced points for continuous data. -#' @param level Level of confidence interval to use (0.95 by default). +#' @param level Level of confidence band to use (0.95 by default). #' @param span Controls the amount of smoothing for the default loess smoother. #' Smaller numbers produce wigglier lines, larger numbers produce smoother #' lines. Only used with loess, i.e. when `method = "loess"`, @@ -40,8 +40,8 @@ #' .details = "`stat_smooth()` provides the following variables, some of #' which depend on the orientation:", #' "y|x" = "Predicted value.", -#' "ymin|xmin" = "Lower pointwise confidence interval around the mean.", -#' "ymax|xmax" = "Upper pointwise confidence interval around the mean.", +#' "ymin|xmin" = "Lower pointwise confidence band around the mean.", +#' "ymax|xmax" = "Upper pointwise confidence band around the mean.", #' "se" = "Standard error." #' ) #' @export @@ -95,36 +95,63 @@ StatSmooth <- ggproto("StatSmooth", Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE) msg <- character() - if (is.null(params$method) || identical(params$method, "auto")) { + method <- params$method + if (is.null(method) || identical(method, "auto")) { # Use loess for small datasets, gam with a cubic regression basis for # larger. Based on size of the _largest_ group to avoid bad memory # behaviour of loess max_group <- max(table(interaction(data$group, data$PANEL, drop = TRUE))) if (max_group < 1000) { - params$method <- "loess" + method <- "loess" } else { - params$method <- "gam" + method <- "gam" } - msg <- c(msg, paste0("method = '", params$method, "'")) + msg <- c(msg, paste0("method = '", method, "'")) + } + + 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\"}.", + i = "Install {.pkg mgcv} or change the {.arg method} argument to \\ + resolve this issue." + )) + method <- "lm" } if (is.null(params$formula)) { - if (identical(params$method, "gam")) { + if (identical(method, "gam")) { params$formula <- y ~ s(x, bs = "cs") } else { params$formula <- y ~ x } msg <- c(msg, paste0("formula = '", deparse(params$formula), "'")) } - if (identical(params$method, "gam")) { - params$method <- gam_method() + + # Special case span because it's the most commonly used model argument + if (identical(method, "loess")) { + params$method.args$span <- params$span %||% 0.75 + } + + if (is.character(method)) { + if (identical(method, "gam")) { + method <- gam_method() + } else { + method <- match.fun(method) + } + } + # 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" } if (length(msg) > 0) { cli::cli_inform("{.fn geom_smooth} using {msg}") } + params$method <- method params }, @@ -159,23 +186,6 @@ StatSmooth <- ggproto("StatSmooth", Stat, } } - # Special case span because it's the most commonly used model argument - if (identical(method, "loess")) { - method.args$span <- span - } - - if (is.character(method)) { - if (identical(method, "gam")) { - method <- gam_method() - } else { - method <- match.fun(method) - } - } - # If gam and gam's method is not specified by the user then use REML - if (identical(method, gam_method()) && is.null(method.args$method)) { - method.args$method <- "REML" - } - prediction <- try_fetch( { model <- inject(method( @@ -205,4 +215,10 @@ StatSmooth <- ggproto("StatSmooth", Stat, ) # This function exists to silence an undeclared import warning -gam_method <- function() mgcv::gam +gam_method <- function() { + if (is_installed("mgcv")) { + mgcv::gam + } else { + NA + } +} diff --git a/R/stat-summary-2d.R b/R/stat-summary-2d.R index 30b61e6f58..41d0c5b588 100644 --- a/R/stat-summary-2d.R +++ b/R/stat-summary-2d.R @@ -28,6 +28,7 @@ #' @param drop drop if the output of `fun` is `NA`. #' @param fun function for summary. #' @param fun.args A list of extra arguments to pass to `fun` +#' @inheritSection stat_bin_2d Controlling binning parameters for the x and y directions #' @export #' @examples #' d <- ggplot(diamonds, aes(carat, depth, z = price)) @@ -92,31 +93,50 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, 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") + } + + params <- fix_bin_params(params, fun = snake_class(self), version = "3.5.2") + vars <- c("origin", "binwidth", "breaks", "center", "boundary") + params[vars] <- lapply(params[vars], dual_param, default = NULL) + params$closed <- dual_param(params$closed, list(x = "right", y = "right")) + + params + }, + compute_group = function(data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, - fun = "mean", fun.args = list()) { - origin <- dual_param(origin, list(NULL, NULL)) - binwidth <- dual_param(binwidth, list(NULL, NULL)) - breaks <- dual_param(breaks, list(NULL, NULL)) + fun = "mean", fun.args = list(), + boundary = 0, closed = NULL, center = NULL) { bins <- dual_param(bins, list(x = 30, y = 30)) - xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) - ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) - - xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) - ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) + xbin <- compute_bins( + 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 + ) + cut_id <- list( + xbin = as.integer(bin_cut(data$x, xbin)), + ybin = as.integer(bin_cut(data$y, ybin)) + ) fun <- as_function(fun) f <- function(x) { inject(fun(x, !!!fun.args)) } - out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop) + out <- tapply_df(data$z, cut_id, f, drop = drop) - xdim <- bin_loc(xbreaks, out$xbin) + xdim <- bin_loc(xbin$breaks, out$xbin) out$x <- xdim$mid out$width <- xdim$length - ydim <- bin_loc(ybreaks, out$ybin) + ydim <- bin_loc(ybin$breaks, out$ybin) out$y <- ydim$mid out$height <- ydim$length @@ -126,7 +146,7 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, # Adaptation of tapply that returns a data frame instead of a matrix tapply_df <- function(x, index, fun, ..., drop = TRUE) { - labels <- lapply(index, ulevels) + labels <- lapply(index, ulevels, na.last = NA) # drop NA out <- expand.grid(labels, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) grps <- split(x, index) diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index ce57b6def9..e3db18b102 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -23,15 +23,15 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, 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 + 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)") - fun.min = fun.min %||% fun.ymin + 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)") - fun.max = fun.max %||% fun.ymax + fun.max <- fun.max %||% fun.ymax } layer( data = data, @@ -64,28 +64,38 @@ stat_summary_bin <- function(mapping = NULL, data = NULL, StatSummaryBin <- ggproto("StatSummaryBin", Stat, required_aes = c("x", "y"), - extra_params = c("na.rm", "orientation"), + 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, ambiguous = TRUE) + 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.args %||% list() + ) params }, - compute_group = function(data, scales, fun.data = NULL, fun = NULL, - fun.max = NULL, fun.min = NULL, fun.args = list(), + compute_group = function(data, scales, fun = NULL, bins = 30, binwidth = NULL, breaks = NULL, origin = NULL, right = FALSE, na.rm = FALSE, - flipped_aes = FALSE) { - data <- flip_data(data, flipped_aes) - fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args) + flipped_aes = FALSE, width = NULL, center = NULL, + boundary = NULL, closed = c("right", "left")) { + x <- flipped_names(flipped_aes)$x - breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, right = right) + bins <- compute_bins( + data[[x]], scales[[x]], + breaks = breaks, binwidth = binwidth, bins = bins, + center = center, boundary = boundary, closed = closed + ) + data$bin <- bin_cut(data[[x]], bins) - data$bin <- cut(data$x, breaks, include.lowest = TRUE, labels = FALSE) - out <- dapply(data, "bin", fun) + data <- flip_data(data, flipped_aes) + out <- dapply(data, "bin", fun %||% function(df) mean_se(df$y)) - locs <- bin_loc(breaks, out$bin) + locs <- bin_loc(bins$breaks, out$bin) out$x <- locs$mid - out$width <- if (scales[[x]]$is_discrete()) 0.9 else locs$length + out$width <- width %||% if (scales[[x]]$is_discrete()) 0.9 else locs$length out$flipped_aes <- flipped_aes flip_data(out, flipped_aes) } diff --git a/R/stat-summary.R b/R/stat-summary.R index ddcb7b5ae3..a32eda8ca0 100644 --- a/R/stat-summary.R +++ b/R/stat-summary.R @@ -143,15 +143,15 @@ stat_summary <- function(mapping = NULL, data = NULL, 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 + fun <- fun %||% fun.y } if (lifecycle::is_present(fun.ymin)) { deprecate_warn0("3.3.0", "stat_summary(fun.ymin)", "stat_summary(fun.min)") - fun.min = fun.min %||% fun.ymin + fun.min <- fun.min %||% fun.ymin } if (lifecycle::is_present(fun.ymax)) { deprecate_warn0("3.3.0", "stat_summary(fun.ymax)", "stat_summary(fun.max)") - fun.max = fun.max %||% fun.ymax + fun.max <- fun.max %||% fun.ymax } layer( data = data, @@ -181,18 +181,22 @@ stat_summary <- function(mapping = NULL, data = NULL, StatSummary <- ggproto("StatSummary", Stat, required_aes = c("x", "y"), - extra_params = c("na.rm", "orientation"), + 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.args %||% list() + ) params }, - compute_panel = function(data, scales, fun.data = NULL, fun = NULL, - fun.max = NULL, fun.min = NULL, fun.args = list(), - na.rm = FALSE, flipped_aes = FALSE) { + compute_panel = function(data, scales, fun = NULL, + na.rm = FALSE, flipped_aes = FALSE) { data <- flip_data(data, flipped_aes) - fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args) - summarised <- summarise_by_x(data, fun) + summarised <- summarise_by_x(data, fun %||% function(df) mean_se(df$y)) summarised$flipped_aes <- flipped_aes flip_data(summarised, flipped_aes) } @@ -218,6 +222,16 @@ summarise_by_x <- function(data, summary, ...) { merge(summary, unique, by = c("x", "group"), sort = FALSE) } +# Return unique columns +# This is used for figuring out which columns are constant within a group +# +# @keyword internal +uniquecols <- function(df) { + df <- df[1, sapply(df, is_unique), drop = FALSE] + attr(df, "row.names") <- .set_row_names(nrow(df)) + df +} + #' A selection of summary functions from Hmisc #' #' @description diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 4eadd8ca58..6b0e4f0ff8 100644 --- a/R/stat-ydensity.R +++ b/R/stat-ydensity.R @@ -7,6 +7,8 @@ #' @param drop Whether to discard groups with less than 2 observations #' (`TRUE`, default) or keep such groups for position adjustment purposes #' (`FALSE`). +#' @param quantiles If not `NULL` (default), compute the `quantile` variable +#' and draw horizontal lines at the given quantiles in `geom_violin()`. #' #' @eval rd_computed_vars( #' density = "Density estimate.", @@ -16,7 +18,8 @@ #' violinwidth = "Density scaled for the violin plot, according to area, #' counts or to a constant maximum width.", #' n = "Number of points.", -#' width = "Width of violin bounding box." +#' width = "Width of violin bounding box.", +#' quantile = "Whether the row is part of the `quantiles` computation." #' ) #' #' @seealso [geom_violin()] for examples, and [stat_density()] @@ -26,6 +29,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL, geom = "violin", position = "dodge", ..., + quantiles = c(0.25, 0.50, 0.75), bw = "nrd0", adjust = 1, kernel = "gaussian", @@ -56,6 +60,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL, drop = drop, na.rm = na.rm, bounds = bounds, + quantiles = quantiles, ... ) ) @@ -73,14 +78,26 @@ StatYdensity <- ggproto("StatYdensity", Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) + if (!is.null(params$draw_quantiles)) { + deprecate_soft0( + "3.6.0", + what = "stat_ydensity(draw_quantiles)", + with = "stat_ydensity(quantiles)" + ) + params$quantiles <- params$draw_quantiles + check_numeric(params$quantiles, arg = "quantiles") + } + params }, - extra_params = c("na.rm", "orientation"), + # `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)) { + 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( @@ -115,17 +132,43 @@ StatYdensity <- ggproto("StatYdensity", Stat, } dens$width <- width + if (!is.null(quantiles)) { + if (!(all(quantiles >= 0) && all(quantiles <= 1))) { + cli::cli_abort("{.arg quantiles} must be between 0 and 1.") + } + if (!is.null(data[["weight"]]) || !all(data[["weight"]] == 1)) { + cli::cli_warn( + "{.arg quantiles} for weighted data is not implemented." + ) + } + quants <- quantile(data$y, probs = quantiles) + quants <- data_frame0( + y = unname(quants), + quantile = quantiles + ) + + # Interpolate other metrics + for (var in setdiff(names(dens), names(quants))) { + quants[[var]] <- + approx(dens$y, dens[[var]], xout = quants$y, ties = "ordered")$y + } + + dens <- vec_slice(dens, !dens$y %in% quants$y) + dens <- vec_c(dens, quants) + } + 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)) { + 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, + quantiles = quantiles ) if (!drop && any(data$n < 2)) { cli::cli_warn( diff --git a/R/summarise-plot.R b/R/summarise-plot.R index 9411c1c586..9ab046cb8c 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -61,12 +61,12 @@ NULL #' @rdname summarise_plot #' @export -summarise_layout = function(p) { +summarise_layout <- function(p) { check_inherits(p, "ggplot_built") l <- p$layout layout <- l$layout - layout <- tibble( + layout <- data_frame0( panel = l$layout$PANEL, row = l$layout$ROW, col = l$layout$COL @@ -98,7 +98,7 @@ summarise_layout = function(p) { #' @rdname summarise_plot #' @export -summarise_coord = function(p) { +summarise_coord <- function(p) { check_inherits(p, "ggplot_built") # Given a transform object, find the log base; if the transform object is @@ -134,7 +134,7 @@ summarise_layers <- function(p) { # This currently only returns the mappings, but in the future, other # information could be added. - tibble( + data_frame0( mapping = layer_mappings ) } diff --git a/R/summary.R b/R/summary.R index e5422f8ad4..4a227a3599 100644 --- a/R/summary.R +++ b/R/summary.R @@ -29,8 +29,9 @@ summary.ggplot <- function(object, ...) { cat("scales: ", paste(object$scales$input(), collapse = ", "), "\n") } - cat("faceting: ") - print(object$facet) + vars <- object$facet$vars() + vars <- if (length(vars) > 0) paste0("~", vars) else "" + cat("faceting: ", paste0(vars, collapse = ", "), "\n") if (length(object$layers) > 0) cat("-----------------------------------\n") diff --git a/R/theme-current.R b/R/theme-current.R index 839a02371d..c6848c7d76 100644 --- a/R/theme-current.R +++ b/R/theme-current.R @@ -5,8 +5,8 @@ NULL #' Get, set, and modify the active theme #' #' The current/active theme (see [theme()]) is automatically applied to every -#' plot you draw. Use `theme_get()` to get the current theme, and `theme_set()` to -#' completely override it. `theme_update()` and `theme_replace()` are shorthands for +#' plot you draw. Use `get_theme()` to get the current theme, and `set_theme()` to +#' completely override it. `update_theme()` and `replace_theme()` are shorthands for #' changing individual elements. #' #' @section Adding on to a theme: @@ -14,30 +14,30 @@ NULL #' `+` and `%+replace%` can be used to modify elements in themes. #' #' `+` updates the elements of e1 that differ from elements specified (not -#' NULL) in e2. Thus this operator can be used to incrementally add or modify +#' `NULL`) in e2. Thus this operator can be used to incrementally add or modify #' attributes of a ggplot theme. #' #' In contrast, `%+replace%` replaces the entire element; any element of a #' theme not specified in e2 will not be present in the resulting theme (i.e. -#' NULL). Thus this operator can be used to overwrite an entire theme. +#' `NULL`). Thus this operator can be used to overwrite an entire theme. #' -#' `theme_update()` uses the `+` operator, so that any unspecified values in the +#' `update_theme()` uses the `+` operator, so that any unspecified values in the #' theme element will default to the values they are set in the theme. -#' `theme_replace()` uses `%+replace%` to completely replace the element, so any +#' `replace_theme()` uses `%+replace%` to completely replace the element, so any #' unspecified values will overwrite the current value in the theme with #' `NULL`. #' -#' In summary, the main differences between `theme_set()`, `theme_update()`, -#' and `theme_replace()` are: -#' * `theme_set()` completely overrides the current theme. -#' * `theme_update()` modifies a particular element of the current theme +#' In summary, the main differences between `set_theme()`, `update_theme()`, +#' and `replace_theme()` are: +#' * `set_theme()` completely overrides the current theme. +#' * `update_theme()` modifies a particular element of the current theme #' using the `+` operator. -#' * `theme_replace()` modifies a particular element of the current theme +#' * `replace_theme()` modifies a particular element of the current theme #' using the `%+replace%` operator. #' #' @param ... named list of theme settings #' @param e1,e2 Theme and element to combine -#' @return `theme_set()`, `theme_update()`, and `theme_replace()` +#' @return `set_theme()`, `update_theme()`, and `replace_theme()` #' invisibly return the previous theme so you can easily save it, then #' later restore it. #' @seealso [+.gg()] @@ -47,25 +47,25 @@ NULL #' geom_point() #' p #' -#' # Use theme_set() to completely override the current theme. -#' # theme_update() and theme_replace() are similar except they +#' # Use set_theme() to completely override the current theme. +#' # update_theme() and replace_theme() are similar except they #' # apply directly to the current/active theme. -#' # theme_update() modifies a particular element of the current theme. +#' # update_theme() modifies a particular element of the current theme. #' # Here we have the old theme so we can later restore it. #' # Note that the theme is applied when the plot is drawn, not #' # when it is created. -#' old <- theme_set(theme_bw()) +#' old <- set_theme(theme_bw()) #' p #' -#' theme_set(old) -#' theme_update(panel.grid.minor = element_line(colour = "red")) +#' set_theme(old) +#' update_theme(panel.grid.minor = element_line(colour = "red")) #' p #' -#' theme_set(old) -#' theme_replace(panel.grid.minor = element_line(colour = "red")) +#' set_theme(old) +#' replace_theme(panel.grid.minor = element_line(colour = "red")) #' p #' -#' theme_set(old) +#' set_theme(old) #' p #' #' @@ -82,33 +82,49 @@ NULL #' theme(text = element_text(family = "Times")) #' rep_el$text #' -theme_get <- function() { +get_theme <- function() { ggplot_global$theme_current } -#' @rdname theme_get +#' @export +#' @rdname get_theme +theme_get <- get_theme + +#' @rdname get_theme #' @param new new theme (a list of theme elements) #' @export -theme_set <- function(new) { +set_theme <- function(new) { check_object(new, is_theme, "a {.cls theme} object") old <- ggplot_global$theme_current ggplot_global$theme_current <- new invisible(old) } -#' @rdname theme_get #' @export -theme_update <- function(...) { - theme_set(theme_get() + theme(...)) +#' @rdname get_theme +theme_set <- set_theme + +#' @rdname get_theme +#' @export +update_theme <- function(...) { + set_theme(get_theme() + theme(...)) } -#' @rdname theme_get #' @export -theme_replace <- function(...) { - theme_set(theme_get() %+replace% theme(...)) +#' @rdname get_theme +theme_update <- update_theme + +#' @rdname get_theme +#' @export +replace_theme <- function(...) { + set_theme(get_theme() %+replace% theme(...)) } -#' @rdname theme_get +#' @export +#' @rdname get_theme +theme_replace <- replace_theme + +#' @rdname get_theme #' @export "%+replace%" <- function(e1, e2) { if (!is_theme(e1) || !is_theme(e2)) { diff --git a/R/theme-defaults.R b/R/theme-defaults.R index 05260557e9..6f32012cd0 100644 --- a/R/theme-defaults.R +++ b/R/theme-defaults.R @@ -6,8 +6,12 @@ #' #' @param base_size base font size, given in pts. #' @param base_family base font family +#' @param header_family font family for titles and headers. The default, `NULL`, +#' uses theme inheritance to set the font. This setting affects axis titles, +#' legend titles, the plot title and tag text. #' @param base_line_size base size for line elements #' @param base_rect_size base size for rect elements +#' @param ink,paper colour for foreground and background elements respectively. #' #' @details #' \describe{ @@ -101,8 +105,10 @@ NULL #' @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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { # The half-line (base-fontsize / 2) sets up the basic vertical # rhythm of the theme. Most margins will be set to this value. @@ -120,32 +126,56 @@ theme_grey <- function(base_size = 11, base_family = "", # Elements in this first block aren't used directly, but are inherited # by others line = element_line( - colour = "black", linewidth = base_line_size, + colour = ink, linewidth = base_line_size, linetype = 1, lineend = "butt" ), rect = element_rect( - fill = "white", colour = "black", + fill = paper, colour = ink, linewidth = base_rect_size, linetype = 1 ), text = element_text( family = base_family, face = "plain", - colour = "black", size = base_size, + 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 + ), + + geom = element_geom( + ink = ink, paper = paper, accent = "#3366FF", + 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 = "grey30"), + axis.text = element_text(size = rel(0.8), colour = col_mix(ink, paper, 0.305)), 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 = "grey20"), - axis.ticks.length = unit(half_line / 2, "pt"), + 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, @@ -173,15 +203,15 @@ theme_grey <- function(base_size = 11, base_family = "", ), legend.background = element_rect(colour = NA), - legend.spacing = unit(2 * half_line, "pt"), + legend.spacing = rel(2), legend.spacing.x = NULL, legend.spacing.y = NULL, - legend.margin = margin(half_line, half_line, half_line, half_line), + legend.margin = NULL, legend.key = NULL, legend.key.size = unit(1.2, "lines"), legend.key.height = NULL, legend.key.width = NULL, - legend.key.spacing = unit(half_line, "pt"), + legend.key.spacing = NULL, legend.text = element_text(size = rel(0.8)), legend.title = element_text(hjust = 0), legend.ticks.length = rel(0.2), @@ -189,25 +219,25 @@ theme_grey <- function(base_size = 11, base_family = "", legend.direction = NULL, legend.justification = "center", legend.box = NULL, - legend.box.margin = margin(0, 0, 0, 0, "cm"), + legend.box.margin = rel(0), legend.box.background = element_blank(), - legend.box.spacing = unit(2 * half_line, "pt"), + legend.box.spacing = rel(2), - panel.background = element_rect(fill = "grey92", colour = NA), + panel.background = element_rect(fill = col_mix(ink, paper, 0.925), colour = NA), panel.border = element_blank(), - panel.grid = element_line(colour = "white"), + panel.grid = element_line(colour = paper), panel.grid.minor = element_line(linewidth = rel(0.5)), - panel.spacing = unit(half_line, "pt"), + panel.spacing = NULL, panel.spacing.x = NULL, panel.spacing.y = NULL, panel.ontop = FALSE, - strip.background = element_rect(fill = "grey85", colour = NA), - strip.clip = "inherit", + strip.background = element_rect(fill = col_mix(ink, paper, 0.854), colour = NA), + strip.clip = "on", strip.text = element_text( - colour = "grey10", + colour = col_mix(ink, paper, 0.105), size = rel(0.8), - margin = margin(0.8 * half_line, 0.8 * half_line, 0.8 * half_line, 0.8 * half_line) + margin = margin_auto(0.8 * half_line) ), strip.text.x = NULL, strip.text.y = element_text(angle = -90), @@ -218,7 +248,7 @@ theme_grey <- function(base_size = 11, base_family = "", strip.switch.pad.grid = unit(half_line / 2, "pt"), strip.switch.pad.wrap = unit(half_line / 2, "pt"), - plot.background = element_rect(colour = "white"), + plot.background = element_rect(colour = paper), plot.title = element_text( # font size "large" size = rel(1.2), hjust = 0, vjust = 1, @@ -240,7 +270,7 @@ theme_grey <- function(base_size = 11, base_family = "", hjust = 0.5, vjust = 0.5 ), plot.tag.position = 'topleft', - plot.margin = margin(half_line, half_line, half_line, half_line), + plot.margin = NULL, complete = TRUE ) @@ -255,24 +285,31 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { # Starts with theme_grey and then modify some parts theme_grey( base_size = base_size, base_family = base_family, + header_family = header_family, base_line_size = base_line_size, - base_rect_size = base_rect_size + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( # white background and dark border - panel.background = element_rect(fill = "white", colour = NA), - panel.border = element_rect(fill = NA, colour = "grey20"), + panel.background = element_rect(fill = paper, colour = NA), + 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 = "grey92"), + panel.grid = element_line(colour = col_mix(ink, paper, 0.925)), panel.grid.minor = element_line(linewidth = rel(0.5)), # contour strips to match panel contour - strip.background = element_rect(fill = "grey85", colour = "grey20"), + strip.background = element_rect( + fill = col_mix(ink, paper, 0.851), + colour = col_mix(ink, paper, 0.2) + ), complete = TRUE ) @@ -281,8 +318,10 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { half_line <- base_size / 2 # Starts with theme_bw and then modify some parts @@ -290,28 +329,30 @@ theme_linedraw <- function(base_size = 11, base_family = "", 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 + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( # black text and ticks on the axes - axis.text = element_text(colour = "black", size = rel(0.8)), - axis.ticks = element_line(colour = "black", 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(fill = NA, colour = "black", linewidth = rel(1)), - panel.grid = element_line(colour = "black"), + 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 = "black"), + strip.background = element_rect(fill = ink), strip.text = element_text( - colour = "white", + colour = paper, size = rel(0.8), - margin = margin(0.8 * half_line, 0.8 * half_line, 0.8 * half_line, 0.8 * half_line) + margin = margin_auto(0.8 * half_line) ), complete = TRUE @@ -321,36 +362,40 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { half_line <- base_size / 2 # Starts with theme_grey and then modify some parts theme_grey( base_size = base_size, base_family = base_family, + header_family = header_family, base_line_size = base_line_size, - base_rect_size = base_rect_size + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( # white panel with light grey border - panel.background = element_rect(fill = "white", colour = NA), - panel.border = element_rect(fill = NA, colour = "grey70", linewidth = rel(1)), + panel.background = element_rect(fill = paper, colour = NA), + panel.border = element_rect(colour = col_mix(ink, paper, 0.705), linewidth = rel(1)), # light grey, thinner gridlines # => make them slightly darker to keep acceptable contrast - panel.grid = element_line(colour = "grey87"), + 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 = "grey70", linewidth = rel(0.5)), + axis.ticks = element_line(colour = col_mix(ink, paper, 0.705), linewidth = rel(0.5)), # dark strips with light text (inverse contrast compared to theme_grey) - strip.background = element_rect(fill = "grey70", colour = NA), + strip.background = element_rect(fill = col_mix(ink, paper, 0.705), colour = NA), strip.text = element_text( - colour = "white", + colour = paper, size = rel(0.8), - margin = margin(0.8 * half_line, 0.8 * half_line, 0.8 * half_line, 0.8 * half_line) + margin = margin_auto(0.8 * half_line) ), complete = TRUE @@ -361,35 +406,39 @@ theme_light <- function(base_size = 11, base_family = "", #' @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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { half_line <- base_size / 2 # Starts with theme_grey and then modify some parts theme_grey( base_size = base_size, base_family = base_family, + header_family = header_family, base_line_size = base_line_size, - base_rect_size = base_rect_size + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( # dark panel - panel.background = element_rect(fill = "grey50", colour = NA), + panel.background = element_rect(fill = col_mix(ink, paper, 0.5), 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 = "grey42"), + 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 = "grey20", 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 = "grey15", colour = NA), + strip.background = element_rect(fill = col_mix(ink, paper, 0.15), colour = NA), strip.text = element_text( - colour = "grey90", + colour = col_mix(ink, paper, 0.9), size = rel(0.8), - margin = margin(0.8 * half_line, 0.8 * half_line, 0.8 * half_line, 0.8 * half_line) + margin = margin_auto(0.8 * half_line) ), complete = TRUE @@ -399,23 +448,31 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { # Starts with theme_bw and remove most parts 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 + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( - axis.ticks = element_blank(), + 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)), legend.background = element_blank(), legend.key = element_blank(), panel.background = element_blank(), panel.border = element_blank(), strip.background = element_blank(), - plot.background = element_blank(), + plot.background = element_rect(fill = paper, colour = NA), complete = TRUE ) @@ -424,25 +481,30 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { 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 + base_rect_size = base_rect_size, + ink = ink, paper = paper ) %+replace% theme( # no background and no grid - panel.border = element_blank(), - panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), + panel.border = element_blank(), + panel.grid = element_blank(), # show axes - axis.line = element_line(colour = "black", linewidth = rel(1)), + axis.text = element_text(size = rel(0.8)), + axis.line = element_line(lineend = "square"), + axis.ticks = element_line(), # simple, black and white strips - strip.background = element_rect(fill = "white", colour = "black", linewidth = rel(2)), + strip.background = element_rect(linewidth = rel(2)), # NB: size is 1 but clipped, it looks like the 0.5 of the axes complete = TRUE @@ -452,44 +514,63 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = alpha(ink, 0)) { half_line <- base_size / 2 # Only keep indispensable text: legend and plot titles t <- theme( line = element_blank(), - rect = element_blank(), + rect = element_rect( + fill = paper, colour = NA, linewidth = 0, linetype = 1, + inherit.blank = FALSE + ), + polygon = element_blank(), + point = element_blank(), text = element_text( family = base_family, face = "plain", - colour = "black", size = base_size, + 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), axis.text = element_blank(), axis.title = element_blank(), - axis.ticks.length = unit(0, "pt"), + axis.ticks.length = rel(0), axis.ticks.length.x = NULL, axis.ticks.length.x.top = NULL, axis.ticks.length.x.bottom = NULL, axis.ticks.length.y = NULL, axis.ticks.length.y.left = NULL, axis.ticks.length.y.right = NULL, - axis.minor.ticks.length = unit(0, "pt"), + 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.key.spacing = unit(half_line, "pt"), + legend.key.spacing = rel(1), + legend.margin = rel(0), + legend.box.margin = rel(0), + legend.box.spacing = unit(0.2, "cm"), legend.ticks.length = rel(0.2), - strip.clip = "inherit", + 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.switch.pad.grid = unit(half_line / 2, "pt"), - strip.switch.pad.wrap = unit(half_line / 2, "pt"), + strip.switch.pad.grid = rel(0.5), + strip.switch.pad.wrap = rel(0.5), + strip.background = element_blank(), panel.ontop = FALSE, - panel.spacing = unit(half_line, "pt"), - plot.margin = unit(c(0, 0, 0, 0), "lines"), + panel.spacing = NULL, + panel.background = element_blank(), + panel.border = element_blank(), + plot.margin = rel(0), plot.title = element_text( size = rel(1.2), hjust = 0, vjust = 1, @@ -511,6 +592,7 @@ theme_void <- function(base_size = 11, base_family = "", hjust = 0.5, vjust = 0.5 ), plot.tag.position = 'topleft', + plot.background = element_rect(), complete = TRUE ) @@ -523,36 +605,57 @@ 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) { + base_rect_size = base_size / 22, + ink = "black", paper = "white") { half_line <- base_size / 2 t <- theme( line = element_line( - colour = "black", linewidth = base_line_size, + colour = ink, linewidth = base_line_size, linetype = 1, lineend = "butt" ), rect = element_rect( - fill = "white", colour = "black", + fill = paper, colour = ink, linewidth = base_rect_size, linetype = 1 ), text = element_text( family = base_family, face = "plain", - colour = "black", size = base_size, + 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 + ), + title = element_text(family = header_family), + spacing = unit(half_line, "pt"), + margins = margin_auto(half_line), + geom = element_geom( + ink = ink, paper = paper, accent = "#3366FF", + 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 = "grey30"), + axis.text = element_text(size = rel(0.8), colour = col_mix(ink, paper, 0.305)), 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 = "grey20"), - axis.ticks.length = unit(half_line / 2, "pt"), + 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, @@ -580,15 +683,15 @@ theme_test <- function(base_size = 11, base_family = "", ), legend.background = element_rect(colour = NA), - legend.spacing = unit(2 * half_line, "pt"), + legend.spacing = rel(2), legend.spacing.x = NULL, legend.spacing.y = NULL, - legend.margin = margin(0, 0, 0, 0, "cm"), + 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 = unit(half_line, "pt"), + legend.key.spacing = NULL, legend.key.spacing.x = NULL, legend.key.spacing.y = NULL, legend.text = element_text(size = rel(0.8)), @@ -598,25 +701,28 @@ theme_test <- function(base_size = 11, base_family = "", legend.direction = NULL, legend.justification = "center", legend.box = NULL, - legend.box.margin = margin(0, 0, 0, 0, "cm"), + legend.box.margin = margin_auto(0, unit = "cm"), legend.box.background = element_blank(), - legend.box.spacing = unit(2 * half_line, "pt"), + legend.box.spacing = rel(2), - panel.background = element_rect(fill = "white", colour = NA), - panel.border = element_rect(fill = NA, colour = "grey20"), + 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 = unit(half_line, "pt"), + panel.spacing = NULL, panel.spacing.x = NULL, panel.spacing.y = NULL, panel.ontop = FALSE, - strip.background = element_rect(fill = "grey85", colour = "grey20"), - strip.clip = "inherit", + strip.background = element_rect( + fill = col_mix(ink, paper, 0.851), + colour = col_mix(ink, paper, 0.2) + ), + strip.clip = "on", strip.text = element_text( - colour = "grey10", + colour = col_mix(ink, paper, 0.105), size = rel(0.8), - margin = margin(0.8 * half_line, 0.8 * half_line, 0.8 * half_line, 0.8 * half_line) + margin = margin_auto(0.8 * half_line) ), strip.text.x = NULL, strip.text.y = element_text(angle = -90), @@ -624,10 +730,10 @@ theme_test <- function(base_size = 11, base_family = "", 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"), + strip.switch.pad.grid = rel(0.5), + strip.switch.pad.wrap = rel(0.5), - plot.background = element_rect(colour = "white"), + plot.background = element_rect(colour = paper), plot.title = element_text( size = rel(1.2), hjust = 0, vjust = 1, @@ -649,7 +755,7 @@ theme_test <- function(base_size = 11, base_family = "", hjust = 0.5, vjust = 0.5 ), plot.tag.position = 'topleft', - plot.margin = margin(half_line, half_line, half_line, half_line), + plot.margin = NULL, complete = TRUE ) diff --git a/R/theme-elements.R b/R/theme-elements.R index 6cb4d23a59..b73a1d1d92 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -8,14 +8,26 @@ #' - `element_rect()`: borders and backgrounds. #' - `element_line()`: lines. #' - `element_text()`: text. +#' - `element_polygon()`: polygons. +#' - `element_point()`: points. +#' - `element_geom()`: defaults for drawing layers. #' #' `rel()` is used to specify sizes relative to the parent, -#' `margin()` is used to specify the margins of elements. +#' `margin()`, `margin_part()` and `margin_auto()` are all used to specify the +#' margins of elements. #' -#' @param fill Fill colour. +#' @param fill Fill colour. `fill_alpha()` can be used to set the transparency +#' of the fill. #' @param colour,color Line/border colour. Color is an alias for colour. -#' @param linewidth Line/border size in mm. -#' @param size text size in pts. +#' `alpha()` can be used to set the transparency of the colour. +#' @param linewidth,borderwidth,stroke Line/border size in mm. +#' @param size,fontsize,pointsize text size in pts, point size in mm. +#' @param linetype,bordertype Line type for lines and borders respectively. An +#' integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, +#' twodash), or a string with an even number (up to eight) of hexadecimal +#' digits which give the lengths in consecutive positions in the string. +#' @param shape,pointshape Shape for points (1-25). +#' @param arrow.fill Fill colour for arrows. #' @param inherit.blank Should this element inherit the existence of an #' `element_blank` among its parents? If `TRUE` the existence of #' a blank element among its parents will cause this element to be blank as @@ -24,31 +36,47 @@ #' @param type For testing elements: the type of element to expect. One of #' `"blank"`, `"rect"`, `"line"` or `"text"`. #' @return An S3 object of class `element`, `rel`, or `margin`. +#' @details +#' The `element_polygon()` and `element_point()` functions are not rendered +#' in standard plots and just serve as extension points. +#' #' @examples +#' # A standard plot #' plot <- ggplot(mpg, aes(displ, hwy)) + geom_point() #' +#' # Turning off theme elements by setting them to blank #' plot + theme( #' panel.background = element_blank(), #' axis.text = element_blank() #' ) #' +#' # Text adjustments #' plot + theme( #' axis.text = element_text(colour = "red", size = rel(1.5)) #' ) #' +#' # Turning on the axis line with an arrow #' plot + theme( #' axis.line = element_line(arrow = arrow()) #' ) #' #' plot + theme( #' panel.background = element_rect(fill = "white"), -#' plot.margin = margin(2, 2, 2, 2, "cm"), +#' plot.margin = margin_auto(2, unit = "cm"), #' plot.background = element_rect( #' fill = "grey90", #' colour = "black", #' linewidth = 1 #' ) #' ) +#' +#' ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' geom_smooth(formula = y ~ x, method = "lm") + +#' theme(geom = element_geom( +#' ink = "red", accent = "black", +#' pointsize = 1, linewidth = 2 +#' )) #' @name element #' @aliases NULL NULL @@ -68,7 +96,7 @@ element_rect <- function(fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, color = NULL, inherit.blank = FALSE, size = deprecated()) { if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_rect(size)", "element_rect(linewidth)") + deprecate_warn0("3.4.0", "element_rect(size)", "element_rect(linewidth)") linewidth <- size } @@ -82,25 +110,24 @@ element_rect <- function(fill = NULL, colour = NULL, linewidth = NULL, #' @export #' @rdname element -#' @param linetype Line type. An integer (0:8), a name (blank, solid, -#' dashed, dotted, dotdash, longdash, twodash), or a string with -#' an even number (up to eight) of hexadecimal digits which give the -#' lengths in consecutive positions in the string. #' @param lineend Line end Line end style (round, butt, square) #' @param arrow Arrow specification, as created by [grid::arrow()] element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL, - lineend = NULL, color = NULL, arrow = NULL, inherit.blank = FALSE, size = deprecated()) { + lineend = NULL, color = NULL, arrow = NULL, arrow.fill = NULL, + inherit.blank = FALSE, size = deprecated()) { if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_line(size)", "element_line(linewidth)") + deprecate_warn0("3.4.0", "element_line(size)", "element_line(linewidth)") linewidth <- size } - if (!is.null(color)) colour <- color - if (is.null(arrow)) arrow <- FALSE + colour <- color %||% colour + arrow.fill <- arrow.fill %||% colour + arrow <- arrow %||% FALSE + structure( list(colour = colour, linewidth = linewidth, linetype = linetype, lineend = lineend, - arrow = arrow, inherit.blank = inherit.blank), + arrow = arrow, arrow.fill = arrow.fill, inherit.blank = inherit.blank), class = c("element_line", "element") ) } @@ -156,13 +183,83 @@ is_theme_element <- function(x, type = "any") { line = inherits(x, "element_line"), text = inherits(x, "element_text"), blank = inherits(x, "element_blank"), - # TODO: ideally we accept more elements from extensions. We need to - # consider how this will work with S7 classes, where ggplot2 doesn't know - # about the extension's class objects. FALSE ) } +element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL, + linetype = NULL, color = NULL, + inherit.blank = FALSE) { + structure( + list( + fill = fill, colour = color %||% colour, linewidth = linewidth, + linetype = linetype, inherit.blank = inherit.blank + ), + class = c("element_polygon", "element") + ) +} + +#' @export +#' @rdname element +element_point <- function(colour = NULL, shape = NULL, size = NULL, fill = NULL, + stroke = NULL, color = NULL, inherit.blank = FALSE) { + structure( + list( + colour = color %||% colour, fill = fill, shape = shape, size = size, + stroke = stroke, inherit.blank = inherit.blank + ), + class = c("element_point", "element") + ) +} + +#' @param ink Foreground colour. +#' @param paper Background colour. +#' @param accent Accent colour. +#' @export +#' @rdname element +element_geom <- function( + # colours + ink = NULL, paper = NULL, accent = NULL, + # linewidth + linewidth = NULL, borderwidth = NULL, + # linetype + linetype = NULL, bordertype = NULL, + # text + family = NULL, fontsize = NULL, + # points + pointsize = NULL, pointshape = NULL, + + colour = NULL, color = NULL, fill = NULL) { + + if (!is.null(fontsize)) { + fontsize <- fontsize / .pt + } + + structure( + list( + 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 + ), + class = c("element_geom", "element") + ) +} + +.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 +) + #' @export print.element <- function(x, ...) utils::str(x) @@ -205,14 +302,6 @@ element_render <- function(theme, element, ..., name = NULL) { ggname(paste(element, name, sep = "."), grob) } - -# Returns NULL if x is length 0 -len0_null <- function(x) { - if (length(x) == 0) NULL - else x -} - - #' Generate grid grob from theme element #' #' @param element Theme element, i.e. `element_rect` or similar. @@ -233,13 +322,13 @@ element_grob.element_rect <- function(element, x = 0.5, y = 0.5, fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, ..., size = deprecated()) { if (lifecycle::is_present(size)) { - deprecate_soft0("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 } # The gp settings can override element_gp - gp <- gpar(lwd = len0_null(linewidth * .pt), col = colour, fill = fill, lty = linetype) - element_gp <- gpar(lwd = len0_null(element$linewidth * .pt), col = element$colour, + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + element_gp <- gg_par(lwd = element$linewidth, col = element$colour, fill = element$fill, lty = element$linetype) rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) @@ -262,10 +351,10 @@ element_grob.element_text <- function(element, label = "", x = NULL, y = NULL, angle <- angle %||% element$angle %||% 0 # The gp settings can override element_gp - gp <- gpar(fontsize = size, col = colour, + gp <- gg_par(fontsize = size, col = colour, fontfamily = family, fontface = face, lineheight = lineheight) - element_gp <- gpar(fontsize = element$size, col = element$colour, + element_gp <- gg_par(fontsize = element$size, col = element$colour, fontfamily = element$family, fontface = element$face, lineheight = element$lineheight) @@ -279,28 +368,35 @@ element_grob.element_text <- function(element, label = "", x = NULL, y = NULL, #' @export element_grob.element_line <- function(element, x = 0:1, y = 0:1, colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL, + arrow.fill = NULL, default.units = "npc", id.lengths = NULL, ..., size = deprecated()) { if (lifecycle::is_present(size)) { - deprecate_soft0("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 } - # The gp settings can override element_gp - gp <- gpar( - col = colour, fill = colour, - lwd = len0_null(linewidth * .pt), lty = linetype, lineend = lineend - ) - element_gp <- gpar( - col = element$colour, fill = element$colour, - lwd = len0_null(element$linewidth * .pt), lty = element$linetype, - lineend = element$lineend - ) arrow <- if (is.logical(element$arrow) && !element$arrow) { NULL } else { element$arrow } + if (is.null(arrow)) { + arrow.fill <- colour + element$arrow.fill <- element$colour + } + + # The gp settings can override element_gp + gp <- gg_par( + col = colour, fill = arrow.fill %||% colour, + lwd = linewidth, lty = linetype, lineend = lineend + ) + element_gp <- gg_par( + col = element$colour, fill = element$arrow.fill %||% element$colour, + lwd = element$linewidth, lty = element$linetype, + lineend = element$lineend + ) + polylineGrob( x, y, default.units = default.units, gp = modify_list(element_gp, gp), @@ -308,6 +404,40 @@ element_grob.element_line <- function(element, x = 0:1, y = 0:1, ) } +#' @export +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, ..., + id = NULL, id.lengths = NULL, + pathId = NULL, pathId.lengths = NULL) { + + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + element_gp <- gg_par(lwd = element$linewidth, col = element$colour, + fill = element$fill, lty = element$linetype) + pathGrob( + 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 + ) +} + +#' @export +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") { + + 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) + 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, ...) +} + #' Define and register new theme elements #' #' The underlying structure of a ggplot2 theme is defined via the element tree, which @@ -372,6 +502,8 @@ register_theme_elements <- function(..., element_tree = NULL, complete = TRUE) { t <- theme(..., complete = complete) ggplot_global$theme_default <- ggplot_global$theme_default %+replace% t + check_element_tree(element_tree) + # Merge element trees ggplot_global$element_tree <- defaults(element_tree, ggplot_global$element_tree) @@ -417,6 +549,43 @@ get_element_tree <- function() { ggplot_global$element_tree } +check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { + check_object(x, is_bare_list, "a bare {.cls list}", arg = arg, call = call) + if (length(x) < 1) { + return(invisible(NULL)) + } + + if (!is_named(x)) { + cli::cli_abort("{.arg {arg}} must have names.", call = call) + } + + # All elements should be constructed with `el_def()` + fields <- names(el_def()) + bad_fields <- !vapply(x, function(el) all(fields %in% names(el)), logical(1)) + 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}}}"), + call = call + ) + } + + # 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 + )) + if (any(bad_parent)) { + bad_parent <- names(x)[bad_parent] + cli::cli_abort( + "Invalid parent in {.arg {arg}}: {.and {.val {bad_parent}}}.", + call = call + ) + } + invisible(NULL) +} + #' @rdname register_theme_elements #' @details #' The function `el_def()` is used to define new or modified element types and @@ -444,12 +613,18 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { 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("unit"), + 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"), @@ -473,7 +648,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { 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("unit"), + 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"), @@ -529,16 +704,17 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { ), legend.background = el_def("element_rect", "rect"), - legend.margin = el_def("margin"), - legend.spacing = el_def("unit"), + 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("unit"), + 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"), @@ -578,13 +754,13 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.box = el_def("character"), legend.box.just = el_def("character"), - legend.box.margin = el_def("margin"), + legend.box.margin = el_def(c("margin", "unit", "rel"), "margins"), legend.box.background = el_def("element_rect", "rect"), - legend.box.spacing = el_def("unit"), + 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("unit"), + 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"), @@ -592,6 +768,8 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { 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"), @@ -606,19 +784,34 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { 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("unit"), - strip.switch.pad.wrap = el_def("unit"), + 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.title.position = el_def("character"), - plot.subtitle = el_def("element_text", "title"), - plot.caption = el_def("element_text", "title"), + 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", "title"), + 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("margin"), + plot.margin = el_def(c("margin", "unit", "rel"), "margins"), + + 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")) ) @@ -634,7 +827,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { # @param el an element # @param elname the name of the element # @param element_tree the element tree to validate against -validate_element <- function(el, elname, element_tree, call = caller_env()) { +check_element <- function(el, elname, element_tree, call = caller_env()) { eldef <- element_tree[[elname]] if (is.null(eldef)) { diff --git a/R/theme-sub.R b/R/theme-sub.R new file mode 100644 index 0000000000..abfb178c44 --- /dev/null +++ b/R/theme-sub.R @@ -0,0 +1,144 @@ +#' Shortcuts for theme settings +#' +#' This collection of functions serves as a shortcut for [`theme()`][theme] with +#' shorter argument names. Besides the shorter arguments, it also helps in +#' keeping theme declarations more organised. +#' +#' @eval subtheme_param_doc() +#' +#' @return A `theme`-class object that can be added to a plot. +#' @name subtheme +#' +#' @examples +#' # A standard plot +#' p <- ggplot(mtcars, aes(disp, mpg, colour = drat)) + +#' geom_point() +#' +#' red_text <- element_text(colour = "red") +#' red_line <- element_line(colour = "red") +#' +#' # The theme settings below: +#' p + theme( +#' axis.title.x.bottom = red_text, +#' axis.text.x.bottom = red_text, +#' axis.line.x.bottom = red_line, +#' axis.ticks.x.bottom = red_line +#' ) +#' +#' # Are equivalent to these less verbose theme settings +#' p + theme_sub_axis_bottom( +#' title = red_text, +#' text = red_text, +#' line = red_line, +#' ticks = red_line +#' ) +NULL + +subtheme <- function(elements, prefix = "", suffix = "", call = caller_env()) { + if (length(elements) < 1) { + return(theme()) + } + names(elements) <- paste0(prefix, names(elements), suffix) + + extra <- setdiff(names(elements), names(get_element_tree())) + if (length(extra) > 0) { + cli::cli_warn( + "Ignoring unknown {.fn theme} element{?s}: {.and {.field {extra}}}.", + call = call + ) + elements <- elements[setdiff(names(elements), extra)] + } + + exec(theme, !!!elements) +} + +#' @export +#' @describeIn subtheme Theme specification for all axes. +theme_sub_axis <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.") +} + +#' @export +#' @describeIn subtheme Theme specification for both x axes. +theme_sub_axis_x <- function(title, text, ticks, ticks.length, line) { + 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) { + 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) { + 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) { + 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) { + 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) { + subtheme(find_args(), "axis.", ".y.right") +} + +#' @export +#' @describeIn subtheme Theme specification for the legend. +theme_sub_legend <- function(background, margin, spacing, spacing.x, spacing.y, + key, key.size, key.height, key.width, text, title, + position, direction, justification, 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, 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) { + 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) { + 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 + ) + args <- sort(unique(unlist(lapply(funs, fn_fmls_names), use.names = FALSE))) + paste0( + "@param ", + paste0(args, collapse = ","), + " Arguments that are renamed and passed on to ", + "\\code{\\link[=theme]{theme()}}." + ) +} diff --git a/R/theme.R b/R/theme.R index 8640f8417d..823f36d34b 100644 --- a/R/theme.R +++ b/R/theme.R @@ -25,6 +25,11 @@ #' @param text all text elements ([element_text()]) #' @param title all title elements: plot, axes, legends ([element_text()]; #' inherits from `text`) +#' @param point all point elements ([element_point()]) +#' @param polygon all polygon elements ([element_polygon()]) +#' @param geom defaults for geoms ([element_geom()]) +#' @param spacing all spacings ([`unit()`][grid::unit]) +#' @param margins all margins ([margin()]) #' @param aspect.ratio aspect ratio of the panel #' #' @param axis.title,axis.title.x,axis.title.y,axis.title.x.top,axis.title.x.bottom,axis.title.y.left,axis.title.y.right @@ -52,7 +57,7 @@ #' minor tick marks along axes ([element_line()]). `axis.minor.ticks.*.*` #' inherit from the corresponding major ticks `axis.ticks.*.*`. #' @param 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 -#' length of tick marks (`unit`) +#' length of tick marks (`unit`). `axis.ticks.length` inherits from `spacing`. #' @param 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 #' length of minor tick marks (`unit`), or relative to `axis.ticks.length` when provided with `rel()`. #' @param 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 @@ -65,22 +70,30 @@ #' #' @param legend.background background of legend ([element_rect()]; inherits #' from `rect`) -#' @param legend.margin the margin around each legend ([margin()]) +#' @param legend.margin the margin around each legend ([margin()]); inherits +#' from `margins`. #' @param legend.spacing,legend.spacing.x,legend.spacing.y #' the spacing between legends (`unit`). `legend.spacing.x` & `legend.spacing.y` -#' inherit from `legend.spacing` or can be specified separately +#' inherit from `legend.spacing` or can be specified separately. +#' `legend.spacing` inherits from `spacing`. #' @param legend.key background underneath legend keys ([element_rect()]; #' inherits from `rect`) #' @param legend.key.size,legend.key.height,legend.key.width #' size of legend keys (`unit`); key background height & width inherit from -#' `legend.key.size` or can be specified separately +#' `legend.key.size` or can be specified separately. In turn `legend.key.size` +#' inherits from `spacing`. #' @param legend.key.spacing,legend.key.spacing.x,legend.key.spacing.y spacing #' between legend keys given as a `unit`. Spacing in the horizontal (x) and #' vertical (y) direction inherit from `legend.key.spacing` or can be -#' specified separately. +#' specified separately. `legend.key.spacing` inherits from `spacing`. +#' @param legend.key.justification Justification for positioning legend keys +#' when more space is available than needed for display. The default, `NULL`, +#' stretches keys into the available space. Can be a location like `"center"` +#' or `"top"`, or a two-element numeric vector. #' @param legend.frame frame drawn around the bar ([element_rect()]). #' @param legend.ticks tick marks shown along bars or axes ([element_line()]) -#' @param legend.ticks.length length of tick marks in legend (`unit`) +#' @param legend.ticks.length length of tick marks in legend +#' ([`unit()`][grid::unit]); inherits from `legend.key.size`. #' @param legend.axis.line lines along axes in legends ([element_line()]) #' @param legend.text legend item labels ([element_text()]; inherits from #' `text`) @@ -110,14 +123,14 @@ #' @param legend.box arrangement of multiple legends ("horizontal" or #' "vertical") #' @param legend.box.just justification of each legend within the overall -#' bounding box, when there are multiple legends ("top", "bottom", "left", or -#' "right") +#' bounding box, when there are multiple legends ("top", "bottom", "left", +#' "right", "center" or "centre") #' @param legend.box.margin margins around the full legend area, as specified -#' using [margin()] +#' using [margin()]; inherits from `margins`. #' @param legend.box.background background of legend area ([element_rect()]; #' inherits from `rect`) #' @param legend.box.spacing The spacing between the plotting area and the -#' legend box (`unit`) +#' legend box (`unit`); inherits from `spacing`. #' #' @param panel.background background of plotting area, drawn underneath plot #' ([element_rect()]; inherits from `rect`) @@ -127,7 +140,7 @@ #' ([element_rect()]; inherits from `rect`) #' @param panel.spacing,panel.spacing.x,panel.spacing.y spacing between facet #' panels (`unit`). `panel.spacing.x` & `panel.spacing.y` inherit from `panel.spacing` -#' or can be specified separately. +#' or can be specified separately. `panel.spacing` inherits from `spacing`. #' @param panel.grid,panel.grid.major,panel.grid.minor,panel.grid.major.x,panel.grid.major.y,panel.grid.minor.x,panel.grid.minor.y #' grid lines ([element_line()]). Specify major grid lines, #' or minor grid lines separately (using `panel.grid.major` or `panel.grid.minor`) @@ -136,6 +149,9 @@ #' and x axis grid lines are vertical. `panel.grid.*.*` inherits from #' `panel.grid.*` which inherits from `panel.grid`, which in turn inherits #' from `line` +#' @param panel.widths,panel.heights Sizes for panels (`units`). Can be a +#' single unit to set the total size for the panel area, or a unit vector to +#' set the size of individual panels. #' @param panel.ontop option to place the panel (background, gridlines) over #' the data layers (`logical`). Usually used with a transparent or blank #' `panel.background`. @@ -166,7 +182,7 @@ #' set the x,y-coordinate relative to the whole plot. The coordinate option #' is unavailable for `plot.tag.location = "margin"`. #' @param plot.margin margin around entire plot (`unit` with the sizes of -#' the top, right, bottom, and left margins) +#' the top, right, bottom, and left margins); inherits from `margin`. #' #' @param strip.background,strip.background.x,strip.background.y #' background of facet labels ([element_rect()]; @@ -188,10 +204,8 @@ #' that inherit from `strip.text.x` and `strip.text.y`, respectively. #' As a consequence, some theme stylings need to be applied to #' the position-dependent elements rather than to the parent elements -#' @param strip.switch.pad.grid space between strips and axes when strips are -#' switched (`unit`) -#' @param strip.switch.pad.wrap space between strips and axes when strips are -#' switched (`unit`) +#' @param strip.switch.pad.grid,strip.switch.pad.wrap space between strips and +#' axes when strips are switched (`unit`); inherits from `spacing`. #' #' @param ... additional element specifications not part of base ggplot2. In general, #' these should also be defined in the `element tree` argument. [Splicing][rlang::splice] a list is also supported. @@ -200,7 +214,7 @@ #' differently when added to a ggplot object. Also, when setting #' `complete = TRUE` all elements will be set to inherit from blank #' elements. -#' @param validate `TRUE` to run `validate_element()`, `FALSE` to bypass checks. +#' @param validate `TRUE` to run `check_element()`, `FALSE` to bypass checks. #' @export #' @seealso #' [+.gg()] and [%+replace%], @@ -222,7 +236,7 @@ #' # Panels -------------------------------------------------------------------- #' #' p1 + theme(panel.background = element_rect(fill = "white", colour = "grey50")) -#' p1 + theme(panel.border = element_rect(linetype = "dashed", fill = NA)) +#' p1 + theme(panel.border = element_rect(linetype = "dashed")) #' p1 + theme(panel.grid.major = element_line(colour = "black")) #' p1 + theme( #' panel.grid.major.y = element_blank(), @@ -276,14 +290,14 @@ #' legend.position.inside = c(.95, .95), #' legend.justification = c("right", "top"), #' legend.box.just = "right", -#' legend.margin = margin(6, 6, 6, 6) +#' legend.margin = margin_auto(6) #' ) #' #' # The legend.box properties work similarly for the space around #' # all the legends #' p2 + theme( #' legend.box.background = element_rect(), -#' legend.box.margin = margin(6, 6, 6, 6) +#' legend.box.margin = margin_auto(6) #' ) #' #' # You can also control the display of the keys @@ -311,6 +325,11 @@ theme <- function(..., rect, text, title, + point, + polygon, + geom, + spacing, + margins, aspect.ratio, axis.title, axis.title.x, @@ -382,6 +401,7 @@ theme <- function(..., legend.key.spacing, legend.key.spacing.x, legend.key.spacing.y, + legend.key.justification, legend.frame, legend.ticks, legend.ticks.length, @@ -419,6 +439,8 @@ theme <- function(..., panel.grid.minor.x, panel.grid.minor.y, panel.ontop, + panel.widths, + panel.heights, plot.background, plot.title, plot.title.position, @@ -445,36 +467,29 @@ theme <- function(..., 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) - if (!is.null(elements$axis.ticks.margin)) { - deprecate_warn0( - "2.0.0", "theme(axis.ticks.margin)", - details = "Please set `margin` property of `axis.text` instead" - ) - elements$axis.ticks.margin <- NULL - } - if (!is.null(elements$panel.margin)) { - deprecate_warn0( - "2.2.0", "theme(panel.margin)", "theme(panel.spacing)" - ) - elements$panel.spacing <- elements$panel.margin - elements$panel.margin <- NULL - } - if (!is.null(elements$panel.margin.x)) { - deprecate_warn0( - "2.2.0", "theme(panel.margin.x)", "theme(panel.spacing.x)" - ) - elements$panel.spacing.x <- elements$panel.margin.x - elements$panel.margin.x <- NULL - } - if (!is.null(elements$panel.margin.y)) { - deprecate_warn0( - "2.2.0", "theme(panel.margin.y)", "theme(panel.spacing.y)" - ) - elements$panel.spacing.y <- elements$panel.margin.y - elements$panel.margin.y <- NULL + # If complete theme set all non-blank elements to inherit from blanks + if (complete) { + elements <- lapply(elements, function(el) { + if (is_theme_element(el) && !is_theme_element(el, "blank")) { + el$inherit.blank <- TRUE + } + el + }) } + structure( + elements, + class = c("theme", "gg"), + complete = complete, + validate = validate + ) +} + +fix_theme_deprecations <- function(elements) { if (is.unit(elements$legend.margin) && !is_margin(elements$legend.margin)) { cli::cli_warn(c( "{.var legend.margin} must be specified using {.fn margin}", @@ -517,22 +532,46 @@ theme <- function(..., elements$legend.position.inside <- elements$legend.position elements$legend.position <- "inside" } + elements +} - # If complete theme set all non-blank elements to inherit from blanks - if (complete) { - elements <- lapply(elements, function(el) { - if (is_theme_element(el) && !is_theme_element(el, "blank")) { - el$inherit.blank <- TRUE - } - el - }) +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") + if (!any(pals %in% names(elements))) { + return(elements) } - structure( + + # Standardise spelling + elements <- replace_null( elements, - class = c("theme", "gg"), - complete = complete, - validate = validate + palette.colour.discrete = elements$palette.color.discrete, + palette.colour.continuous = elements$palette.color.continuous ) + elements$palette.color.discrete <- NULL + elements$palette.color.continuous <- 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") + index <- which(pals %in% names(elements)) + + for (i in index) { + if (is.null(getOption(opts[i]))) { + next + } + cli::cli_warn(c( + "The {.code options('{opts[i]}')} setting is incompatible with the \\ + {.arg {pals[i]}} theme setting.", + i = "You can set {.code options({opts[i]} = NULL)}." + )) + } + + elements } # check whether theme is complete @@ -544,18 +583,56 @@ is_theme_validate <- function(x) { isTRUE(validate %||% TRUE) } -validate_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { +check_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { if (!is_theme_validate(theme)) { return() } + elnames <- names(theme) + elnames[startsWith(elnames, "geom.")] <- "geom" + mapply( - validate_element, theme, names(theme), + check_element, theme, elnames, MoreArgs = list(element_tree = tree, call = call) ) } +#' Complete a theme +#' +#' This function takes a theme and completes it so that it can be used +#' downstream to render theme elements. Missing elements are filled in and +#' every item is validated to the specifications of the element tree. +#' +#' @param theme An incomplete [theme][theme()] object to complete, or `NULL` +#' to complete the default theme. +#' @param default A complete [theme][theme()] to fill in missing pieces. +#' Defaults to the global theme settings. +#' +#' @keywords internal +#' @return A [theme][theme()] object. +#' @export +#' +#' @examples +#' my_theme <- theme(line = element_line(colour = "red")) +#' complete_theme(my_theme) +complete_theme <- function(theme = NULL, default = theme_get()) { + if (!is_bare_list(theme)) { + check_object(theme, is_theme, "a {.cls theme} object", allow_null = TRUE) + } + theme <- plot_theme(list(theme = theme), default = default) + + # Using `theme(!!!theme)` drops `NULL` entries, so strip most attributes and + # construct a new theme + attributes(theme) <- list(names = attr(theme, "names")) + structure( + theme, + class = c("theme", "gg"), + complete = TRUE, # This theme is complete and has no missing elements + validate = FALSE # Settings have already been validated + ) +} + # Combine plot defaults with current theme to get complete theme for a plot -plot_theme <- function(x, default = theme_get()) { +plot_theme <- function(x, default = get_theme()) { theme <- x$theme # apply theme defaults appropriately if needed @@ -574,10 +651,13 @@ plot_theme <- function(x, default = theme_get()) { theme[missing] <- ggplot_global$theme_default[missing] # Check that all elements have the correct class (element_text, unit, etc) - validate_theme(theme) + check_theme(theme) # Remove elements that are not registered - theme[setdiff(names(theme), names(get_element_tree()))] <- NULL + # We accept unregistered `geom.*` elements + remove <- setdiff(names(theme), names(get_element_tree())) + remove <- remove[!startsWith(remove, "geom.")] + theme[remove] <- NULL theme } @@ -692,6 +772,11 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # if we have null properties, try to fill in from ggplot_global$theme_default el_out <- combine_elements(el_out, ggplot_global$theme_default[[element]]) nullprops <- vapply(el_out, is.null, logical(1)) + if (inherits(el_out, "element_geom")) { + # Geom elements are expected to have NULL fill/colour, so allow these + # to be missing + nullprops[c("colour", "fill")] <- FALSE + } if (!any(nullprops)) { return(el_out) # no null properties remaining, return element } @@ -746,7 +831,7 @@ merge_element.default <- function(new, old) { # If old is NULL or element_blank, then just return new return(new) } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || - is.logical(new)) { + is.logical(new) || is.function(new)) { # If new is NULL, or a string, numeric vector, unit, or logical, just return it return(new) } @@ -787,6 +872,18 @@ merge_element.element <- function(new, old) { new } +#' @rdname merge_element +#' @export +merge_element.margin <- function(new, old) { + if (is.null(old) || inherits(old, "element_blank")) { + return(new) + } + if (anyNA(new)) { + new[is.na(new)] <- old[is.na(new)] + } + new +} + #' Combine the properties of two elements #' #' @param e1 An element object @@ -820,6 +917,15 @@ combine_elements <- function(e1, e2) { return(e1) } + if (inherits(e1, "margin") && inherits(e2, "margin")) { + if (anyNA(e2)) { + e2[is.na(e2)] <- unit(0, "pt") + } + if (anyNA(e1)) { + e1[is.na(e1)] <- e2[is.na(e1)] + } + } + # If neither of e1 or e2 are element_* objects, return e1 if (!is_theme_element(e1) && !is_theme_element(e2)) { return(e1) @@ -849,8 +955,14 @@ combine_elements <- function(e1, e2) { e1$linewidth <- e2$linewidth * unclass(e1$linewidth) } + if (inherits(e1, "element_text")) { + e1$margin <- combine_elements(e1$margin, e2$margin) + } + # If e2 is 'richer' than e1, fill e2 with e1 parameters - if (is.subclass(e2, e1)) { + is_subclass <- !any(inherits(e2, class(e1), which = TRUE) == 0) + is_subclass <- is_subclass && length(setdiff(class(e2), class(e1)) > 0) + if (is_subclass) { new <- defaults(e1, e2) e2[names(new)] <- new return(e2) @@ -859,12 +971,6 @@ combine_elements <- function(e1, e2) { e1 } -is.subclass <- function(x, y) { - inheritance <- inherits(x, class(y), which = TRUE) - !any(inheritance == 0) && length(setdiff(class(x), class(y))) > 0 -} - - #' @export #' @rdname is_tests is_theme <- function(x) inherits(x, "theme") diff --git a/R/utilities-break.R b/R/utilities-break.R index 1bcce62ec3..11bc22019d 100644 --- a/R/utilities-break.R +++ b/R/utilities-break.R @@ -24,6 +24,9 @@ #' table(cut_width(runif(1000), 0.1, center = 0)) #' table(cut_width(runif(1000), 0.1, labels = FALSE)) cut_interval <- function(x, n = NULL, length = NULL, ...) { + if ((!is.null(n) && !is.null(length)) || (is.null(n) && is.null(length))) { + cli::cli_abort("Specify exactly one of {.var n} and {.var length}.") + } cut(x, breaks(x, "width", n, length), include.lowest = TRUE, ...) } @@ -76,8 +79,8 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" } boundary <- as.numeric(boundary) - # Determine bins - min_x <- find_origin(x_range, width, boundary) + # Determine bins, find origin + min_x <- boundary + floor((x_range[1] - boundary) / width) * width # Small correction factor so that we don't get an extra bin when, for # example, origin = 0, max(x) = 20, width = 10. max_x <- max(x, na.rm = TRUE) + (1 - 1e-08) * width @@ -86,12 +89,6 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" cut(x, breaks, include.lowest = TRUE, right = (closed == "right"), ...) } -# Find the left side of left-most bin -find_origin <- function(x_range, width, boundary) { - shift <- floor((x_range[1] - boundary) / width) - boundary + shift * width -} - 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))) { diff --git a/R/utilities-checks.R b/R/utilities-checks.R index db5fee2353..d444e8c3d0 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -7,6 +7,7 @@ check_object <- function(x, check_fun, what, ..., + allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { @@ -18,6 +19,9 @@ check_object <- function(x, if (allow_null && is_null(x)) { return(invisible(NULL)) } + if (allow_na && all(is.na(x))) { + return(invisible(NULL)) + } } stop_input_type( @@ -69,6 +73,60 @@ check_inherits <- function(x, ) } +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) + } + + n <- length(x) + if (n %in% length) { + return(invisible(NULL)) + } + fmt <- if (inherits(arg, "AsIs")) identity else function(x) sprintf("`%s`", x) + if (length(length) > 0) { + type <- paste0("a vector of length ", oxford_comma(length)) + if (length(length) == 1) { + type <- switch( + sprintf("%d", length), + "0" = "an empty vector", + "1" = "a scalar of length 1", + type + ) + } + msg <- sprintf( + "%s must be %s, not length %d.", + fmt(arg), type, n + ) + cli::cli_abort(msg, call = call, arg = arg) + } + + range <- pmax(range(min, max, na.rm = TRUE), 0) + if (n >= min & n <= max) { + return(invisible(NULL)) + } + if (identical(range[1], range[2])) { + check_length(x, range[1], arg = arg, call = call) + return(invisible(NULL)) + } + + type <- if (range[2] == 1) "scalar" else "vector" + + what <- paste0("a length between ", range[1], " and ", range[2]) + if (identical(range[2], Inf)) { + what <- paste0("at least length ", range[1]) + } + if (identical(range[1], 0)) { + what <- paste0("at most length ", range[2]) + } + + msg <- sprintf( + "`%s` must be a %s with %s, not length %d.", + fmt(arg), type, what, n + ) + cli::cli_abort(msg, call = call, arg = arg) +} + #' Check graphics device capabilities #' #' This function makes an attempt to estimate whether the graphics device is @@ -182,7 +240,7 @@ check_inherits <- function(x, #' #' # Possibly throw an error #' try(check_device("glyphs", action = "abort")) -check_device = function(feature, action = "warn", op = NULL, maybe = FALSE, +check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, call = caller_env()) { check_bool(maybe, allow_na = TRUE) diff --git a/R/utilities-grid.R b/R/utilities-grid.R index 389dad3eea..a935d5b38f 100644 --- a/R/utilities-grid.R +++ b/R/utilities-grid.R @@ -13,6 +13,41 @@ ggname <- function(prefix, grob) { grob } +#' Interpreter for graphical parameters +#' +#' This is a wrapper for [`grid::gpar()`] that applies ggplot2's interpretation +#' of graphical parameters. +#' +#' @param ... Named arguments passed on to `gpar()`. +#' @param stroke Linewidth for points. Populates the `lwd` grid parameter. +#' @param pointsize Size for points. Populates the `fontsize` grid parameter. +#' +#' @return An object of class 'gpar'. +#' @keywords internal +#' @export +gg_par <- function(..., stroke = NULL, pointsize = NULL) { + args <- list2(...) + args <- args[lengths(args) > 0] + + if (!is.null(args$lwd)) { + args$lwd <- args$lwd * .pt + } + if (!is.null(stroke)) { + args$lwd <- stroke * .stroke / 2 + } + if (!is.null(pointsize)) { + # Stroke is added around the outside of the point + stroke <- stroke %||% 0 + stroke[is.na(stroke)] <- 0 + args$fontsize <- pointsize * .pt + stroke * .stroke / 2 + } + if (!is.null(args$lty) && anyNA(args$lty)) { + args$lty[is.na(args$lty)] <- if (is.character(args$lty)) "blank" else 0 + } + + inject(gpar(!!!args)) +} + width_cm <- function(x) { if (is.grob(x)) { convertWidth(grobWidth(x), "cm", TRUE) diff --git a/R/utilities-help.R b/R/utilities-help.R index 4a2312b549..15a8069d66 100644 --- a/R/utilities-help.R +++ b/R/utilities-help.R @@ -2,8 +2,9 @@ # Geoms and there's some difference among their aesthetics). rd_aesthetics <- function(type, name, extra_note = NULL) { obj <- switch(type, - geom = check_subclass(name, "Geom", env = globalenv()), - stat = check_subclass(name, "Stat", env = globalenv()) + geom = validate_subclass(name, "Geom", env = globalenv()), + stat = validate_subclass(name, "Stat", env = globalenv()), + position = validate_subclass(name, "Position", env = globalenv()) ) aes <- rd_aesthetics_item(obj) @@ -11,11 +12,10 @@ rd_aesthetics <- function(type, name, extra_note = NULL) { "@section Aesthetics:", paste0( "\\code{", type, "_", name, "()} ", - "understands the following aesthetics (required aesthetics are in bold):" + "understands the following aesthetics. Required aesthetics are displayed", + " in bold and defaults are displayed for optional aesthetics:" ), - "\\itemize{", - paste0(" \\item ", aes), - "}", + "\\tabular{rll}{", aes, "}", if (!is.null(extra_note)) paste0(extra_note, "\n"), "Learn more about setting these aesthetics in \\code{vignette(\"ggplot2-specs\")}." ) @@ -23,16 +23,39 @@ rd_aesthetics <- function(type, name, extra_note = NULL) { rd_aesthetics_item <- function(x) { req <- x$required_aes - req <- sub("|", "} \\emph{or} \\code{", req, fixed = TRUE) + req <- gsub("|", "} \\emph{or} \\code{", req, fixed = TRUE) req_aes <- unlist(strsplit(x$required_aes, "|", fixed = TRUE)) optional_aes <- setdiff(x$aesthetics(), req_aes) all <- union(req, sort(optional_aes)) docs <- rd_match_docpage(all) + defaults <- rd_defaults(x, all) item <- ifelse(all %in% req, paste0("\\strong{\\code{", docs, "}}"), paste0("\\code{", docs, "}") ) + paste0(" \u2022 \\tab ", item, " \\tab ", defaults, " \\cr\\cr") +} + +rd_defaults <- function(layer, aesthetics) { + defaults <- layer$default_aes + + out <- rep("", length(aesthetics)) + + themed <- vapply(defaults, FUN.VALUE = logical(1), function(x) { + is_quosure(x) && quo_is_call(x, name = "from_theme") + }) + defaults <- lapply(defaults, quo_text) + defaults[themed] <- "via \\code{theme()}" + defaults[!themed] <- paste0("\\code{", defaults[!themed], "}") + + i <- intersect(aesthetics, names(defaults)) + out[match(i, aesthetics)] <- defaults[i] + empty <- !nzchar(out) + out[!empty] <- paste0("\u2192 ", out[!empty]) + out[empty] <- " " + out[empty & aesthetics == "group"] <- "\u2192 inferred" + out } rd_match_docpage <- function(aes) { diff --git a/R/utilities-matrix.R b/R/utilities-matrix.R deleted file mode 100644 index dd35e082ba..0000000000 --- a/R/utilities-matrix.R +++ /dev/null @@ -1,25 +0,0 @@ -# Col union -# Form the union of columns in a and b. If there are columns of the same name in both a and b, take the column from a. -# -# @param data frame a -# @param data frame b -# @keyword internal -cunion <- function(a, b) { - if (length(a) == 0) return(b) - if (length(b) == 0) return(a) - - cbind(a, b[setdiff(names(b), names(a))]) -} - -# Interleave (or zip) multiple units into one vector -interleave <- function(...) UseMethod("interleave") -#' @export -interleave.unit <- function(...) { - units <- lapply(list(...), as.list) - interleaved_list <- interleave.default(!!!units) - inject(unit.c(!!!interleaved_list)) -} -#' @export -interleave.default <- function(...) { - vec_interleave(...) -} diff --git a/R/utilities.R b/R/utilities.R index 9f9133a0b5..8f0672c142 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -12,7 +12,7 @@ scales::alpha } "%|W|%" <- function(a, b) { - if (!is.waive(a)) a else b + if (!is.waiver(a)) a else b } # Check required aesthetics are present @@ -24,25 +24,53 @@ scales::alpha # @param name of object for error message # @keyword internal check_required_aesthetics <- function(required, present, name, call = caller_env()) { - if (is.null(required)) return() + if (is.null(required)) { + return() + } required <- strsplit(required, "|", fixed = TRUE) - if (any(lengths(required) > 1)) { - required <- lapply(required, rep_len, 2) - required <- list( - vapply(required, `[`, character(1), 1), - vapply(required, `[`, character(1), 2) + n <- lengths(required) + + is_present <- vapply( + required, + function(req) any(req %in% present), + logical(1) + ) + if (all(is_present)) { + return() + } + + # Deal with paired (bidirectional) aesthetics + pairs <- character() + missing_pairs <- n == 2 + if (any(missing_pairs)) { + pairs <- lapply(required[missing_pairs], rep_len, 2) + pairs <- list( + vapply(pairs, `[`, character(1), 1), + vapply(pairs, `[`, character(1), 2) ) - } else { - required <- list(unlist(required)) + pairs <- lapply(pairs, setdiff, present) + pairs <- vapply(pairs, function(x) { + as_cli("{.and {.field {x}}}") + }, character(1)) + pairs <- as_cli("{.or {pairs}}") } - missing_aes <- lapply(required, setdiff, present) - if (any(lengths(missing_aes) == 0)) return() - message <- "{.fn {name}} requires the following missing aesthetics: {.field {missing_aes[[1]]}}" - if (length(missing_aes) > 1) { - message <- paste0(message, " {.strong or} {.field {missing_aes[[2]]}}") + + other <- character() + 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)) } - cli::cli_abort(paste0(message, "."), call = call) + + missing <- c(other, pairs) + + cli::cli_abort( + "{.fn {name}} requires the following missing aesthetics: {.and {missing}}.", + call = call + ) } # Concatenate a named list for output @@ -56,16 +84,6 @@ clist <- function(l) { paste(paste(names(l), l, sep = " = ", collapse = ", "), sep = "") } -# Return unique columns -# This is used for figuring out which columns are constant within a group -# -# @keyword internal -uniquecols <- function(df) { - df <- df[1, sapply(df, is_unique), drop = FALSE] - rownames(df) <- seq_len(nrow(df)) - df -} - #' Convenience function to remove missing values from a data.frame #' #' Remove all non-complete rows, with a warning if `na.rm = FALSE`. @@ -164,21 +182,20 @@ should_stop <- function(expr) { #' A waiver is a "flag" object, similar to `NULL`, that indicates the #' calling function should just use the default value. It is used in certain #' functions to distinguish between displaying nothing (`NULL`) and -#' displaying a default value calculated elsewhere (`waiver()`) +#' displaying a default value calculated elsewhere (`waiver()`). +#' `is.waiver()` reports whether an object is a waiver. #' #' @export #' @keywords internal waiver <- function() structure(list(), class = "waiver") -is.waive <- function(x) inherits(x, "waiver") - - -rescale01 <- function(x) { - rng <- range(x, na.rm = TRUE) - (x - rng[1]) / (rng[2] - rng[1]) -} +#' @param x An object to test +#' @export +#' @rdname waiver +is.waiver <- function(x) inherits(x, "waiver") pal_binned <- function(palette) { + force(palette) function(x) { palette(length(x)) } @@ -219,15 +236,6 @@ gg_dep <- function(version, msg) { invisible() } -has_name <- function(x) { - nms <- names(x) - if (is.null(nms)) { - return(rep(FALSE, length(x))) - } - - !is.na(nms) & nms != "" -} - # Use chartr() for safety since toupper() fails to convert i to I in Turkish locale lower_ascii <- "abcdefghijklmnopqrstuvwxyz" upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -242,10 +250,20 @@ toupper <- function(x) { cli::cli_abort("Please use {.fn to_upper_ascii}, which works fine in all locales.") } +merge_attrs <- function(new, old) { + new_attr <- attributes(new) + new <- vec_restore(new, old) # copies old attributes to new + new_attr <- new_attr[setdiff(names(new_attr), names(attributes(new)))] + attributes(new) <- c(attributes(new), new_attr) + new +} + # Convert a snake_case string to camelCase camelize <- function(x, first = FALSE) { x <- gsub("_(.)", "\\U\\1", x, perl = TRUE) - if (first) x <- firstUpper(x) + if (first) { + x <- paste0(to_upper_ascii(substring(x, 1, 1)), substring(x, 2)) + } x } @@ -256,33 +274,41 @@ snakeize <- function(x) { to_lower_ascii(x) } -firstUpper <- function(s) { - paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2)) -} - snake_class <- function(x) { snakeize(class(x)[1]) } empty <- function(df) { - is.null(df) || nrow(df) == 0 || ncol(df) == 0 || is.waive(df) + is.null(df) || nrow(df) == 0 || ncol(df) == 0 || is.waiver(df) } is.discrete <- function(x) { is.factor(x) || is.character(x) || is.logical(x) } -# This function checks that all columns of a dataframe `x` are data and returns -# the names of any columns that are not. -# We define "data" as atomic types or lists, not functions or otherwise. -# The `inherits(x, "Vector")` check is for checking S4 classes from Bioconductor -# and whether they can be expected to follow behavior typical of vectors. See -# also #3835 -check_nondata_cols <- function(x) { - idx <- (vapply(x, function(x) { - is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") - }, logical(1))) - names(x)[which(!idx)] +check_nondata_cols <- function(data, mapping, problem = NULL, hint = NULL) { + # We define "data" as atomic types or lists, not functions or otherwise. + # 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 <- names(data)[invalid] + + if (length(invalid) < 1) { + return(invisible()) + } + + mapping <- vapply(mapping[invalid], as_label, character(1)) + issues <- paste0("{.code ", invalid, " = ", mapping, "}") + names(issues) <- rep("*", length(issues)) + issues <- c(x = "The following aesthetics are invalid:", issues) + + # Using 'call = NULL' here because `by_layer()` does a good job of indicating + # the origin of the error + cli::cli_abort(c(problem, issues, i = hint), call = NULL) } compact <- function(x) { @@ -292,15 +318,6 @@ compact <- function(x) { is.formula <- function(x) inherits(x, "formula") -deparse2 <- function(x) { - y <- deparse(x, backtick = TRUE) - if (length(y) == 1) { - y - } else { - paste0(y[[1]], "...") - } -} - dispatch_args <- function(f, ...) { args <- list(...) formals <- formals(f) @@ -309,7 +326,6 @@ dispatch_args <- function(f, ...) { f } -is_missing_arg <- function(x) identical(x, quote(expr = )) # Get all arguments in a function as a list. Will fail if an ellipsis argument # named .ignore # @param ... passed on in case enclosing function uses ellipsis in argument list @@ -318,7 +334,8 @@ find_args <- function(...) { args <- names(formals(sys.function(sys.parent(1)))) vals <- mget(args, envir = env) - vals <- vals[!vapply(vals, is_missing_arg, logical(1))] + # Remove missing arguments + vals <- vals[!vapply(vals, identical, logical(1), y = quote(expr = ))] modify_list(vals, dots_list(..., `...` = NULL, .ignore_empty = "all")) } @@ -335,18 +352,6 @@ with_seed_null <- function(seed, code) { } } -seq_asc <- function(to, from) { - if (to > from) { - integer() - } else { - to:from - } -} - -# Needed to trigger package loading -#' @importFrom tibble tibble -NULL - # Wrapping vctrs data_frame constructor with no name repair data_frame0 <- function(...) data_frame(..., .name_repair = "minimal") @@ -356,23 +361,19 @@ unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...) # Code readability checking for uniqueness is_unique <- function(x) vec_unique_count(x) == 1L -is_scalar_numeric <- function(x) is_bare_numeric(x, n = 1L) - # Check inputs with tibble but allow column vectors (see #2609 and #2374) as_gg_data_frame <- function(x) { - x <- lapply(x, validate_column_vec) + x <- lapply(x, drop_column_vec) data_frame0(!!!x) } -validate_column_vec <- function(x) { - if (is_column_vec(x)) { + +drop_column_vec <- function(x) { + dims <- dim(x) + if (length(dims) == 2L && dims[[2]] == 1L) { dim(x) <- NULL } x } -is_column_vec <- function(x) { - dims <- dim(x) - length(dims) == 2L && dims[[2]] == 1L -} # Parse takes a vector of n lines and returns m expressions. # See https://github.com/tidyverse/ggplot2/issues/2864 for discussion. @@ -476,6 +477,8 @@ switch_orientation <- function(aesthetics) { #' @param main_is_optional Is the main axis aesthetic optional and, if not #' given, set to `0` #' @param flip Logical. Is the layer flipped. +#' @param default The logical value to return if no orientation can be discerned +#' from the data. #' #' @return `has_flipped_aes()` returns `TRUE` if it detects a layer in the other #' orientation and `FALSE` otherwise. `flip_data()` will return the input @@ -492,7 +495,7 @@ switch_orientation <- function(aesthetics) { 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) { + 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)) @@ -561,8 +564,7 @@ has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA, } } - # default to no - FALSE + isTRUE(default) } #' @rdname bidirection #' @export @@ -661,24 +663,6 @@ is_bang <- function(x) { }) } -is_triple_bang <- function(x) { - if (!is_bang(x)) { - return(FALSE) - } - - x <- x[[2]] - if (!is_bang(x)) { - return(FALSE) - } - - x <- x[[2]] - if (!is_bang(x)) { - return(FALSE) - } - - TRUE -} - # Restart handler for using vec_rbind with mix of types # Ordered is coerced to factor # If a character vector is present the other is converted to character @@ -817,3 +801,161 @@ as_unordered_factor <- function(x) { class(x) <- setdiff(class(x), "ordered") x } + +size0 <- function(x) { + if (obj_is_vector(x)) { + vec_size(x) + } else if (is.vector(x)) { + length(x) + } else { + NULL + } +} + +fallback_palette <- function(scale) { + aes <- scale$aesthetics[1] + discrete <- scale$is_discrete() + if (discrete) { + pal <- switch( + aes, + 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(), + shape = pal_shape(), + size = function(n) sqrt(seq(4, 36, length.out = n)), + ggplot_global$theme_default[[paste0("palette.", aes, ".discrete")]] + ) + return(pal) + } + switch( + aes, + 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()), + shape = pal_binned(pal_shape()), + size = pal_area(), + ggplot_global$theme_default[[paste0("palette.", aes, ".continuous")]] + ) +} + +warn_dots_used <- function(env = caller_env(), call = caller_env()) { + check_dots_used( + env = env, call = call, + # Demote from error to warning + error = function(cnd) { + # cli uses \f as newlines, not \n + msg <- gsub("\n", "\f", cnd_message(cnd)) + cli::cli_warn(msg, call = call) + } + ) +} + +# TODO: delete shims when {scales} releases >1.3.0.9000 +# and bump {scales} version requirements +# Shim for scales/#424 +col_mix <- function(a, b, amount = 0.5) { + input <- vec_recycle_common(a = a, b = b, amount = amount) + a <- grDevices::col2rgb(input$a, TRUE) + b <- grDevices::col2rgb(input$b, TRUE) + new <- (a * (1 - input$amount) + b * input$amount) + grDevices::rgb( + new["red", ], new["green", ], new["blue", ], + alpha = new["alpha", ], maxColorValue = 255 + ) +} + +# Shim for scales/#427 +as_discrete_pal <- function(x, ...) { + if (is.function(x)) { + return(x) + } + pal_manual(x) +} + +# Shim for scales/#427 +as_continuous_pal <- function(x, ...) { + if (is.function(x)) { + return(x) + } + is_color <- grepl("^#(([[:xdigit:]]{2}){3,4}|([[:xdigit:]]){3,4})$", x) | + x %in% grDevices::colours() + if (all(is_color)) { + colour_ramp(x) + } else { + approxfun(seq(0, 1, length.out = length(x)), x) + } +} + +# Replace shims by actual scales function when available +on_load({ + nse <- getNamespaceExports("scales") + if ("col_mix" %in% nse) { + col_mix <- scales::col_mix + } + if ("as_discrete_pal" %in% nse) { + as_discrete_pal <- scales::as_discrete_pal + } + if ("as_continuous_pal" %in% nse) { + as_continuous_pal <- scales::as_continuous_pal + } +}) + +# TODO: Replace me if rlang/#1730 gets implemented +# Similar to `rlang::check_installed()` but returns boolean and misses +# features such as versions, comparisons and using {pak}. +prompt_install <- function(pkg, reason = NULL) { + if (length(pkg) < 1 || is_installed(pkg)) { + return(TRUE) + } + if (!interactive()) { + return(FALSE) + } + + pkg <- pkg[!vapply(pkg, is_installed, logical(1))] + + message <- "The {.pkg {pkg}} package{?s} {?is/are} required" + if (is.null(reason)) { + message <- paste0(message, ".") + } else { + message <- paste0(message, " ", reason) + } + question <- "Would you like to install {cli::qty(pkg)}{?it/them}?" + + cli::cli_bullets(c("!" = message, "i" = question)) + if (utils::menu(c("Yes", "No")) != 1) { + return(FALSE) + } + utils::install.packages(pkg) + is_installed(pkg) +} + +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) + } + + var <- if (target == "height") "y" else "x" + panels <- arg_match0(panels, c("across", "by", "ignore")) + + if (panels == "across") { + res <- split(data[[var]], data$PANEL, drop = FALSE) + 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, ...)) + } else { + res <- resolution(data[[var]], ...) + } + if (is_quosure(default)) { + default <- eval_tidy(default, data = data) + } + data[[target]] <- res * (default %||% 0.9) + data +} diff --git a/R/zxx.R b/R/zxx.R index 59b3812e56..7c10940491 100644 --- a/R/zxx.R +++ b/R/zxx.R @@ -36,9 +36,10 @@ scale_colour_datetime <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "colour") { datetime_scale( - aesthetics = "colour", transform = "time", name = name, + aesthetics = aesthetics, transform = "time", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -60,9 +61,10 @@ scale_colour_date <- function(name = waiver(), high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "colour") { datetime_scale( - aesthetics = "colour", transform = "date", name = name, + aesthetics = aesthetics, transform = "date", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -114,9 +116,10 @@ scale_fill_datetime <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "fill") { datetime_scale( - aesthetics = "fill", transform = "time", name = name, + aesthetics = aesthetics, transform = "time", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -132,9 +135,10 @@ scale_fill_date <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "fill") { datetime_scale( - aesthetics = "fill", 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 4d6755b53b..398cb7d7b6 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -9,7 +9,7 @@ random_tip <- function() { tips <- c( - "RStudio Community is a great place to get help: https://community.rstudio.com/c/tidyverse", + "RStudio Community is a great place to get help: https://forum.posit.co/c/tidyverse", "Learn more about the underlying theory at https://ggplot2-book.org/", "Keep up to date with changes at https://tidyverse.org/blog/", "Use suppressPackageStartupMessages() to eliminate package startup messages", diff --git a/README.Rmd b/README.Rmd index 4aaacc5d02..c85299bdc5 100644 --- a/README.Rmd +++ b/README.Rmd @@ -4,7 +4,8 @@ output: github_document -```{r, echo = FALSE} +```{r} +#| echo: false knitr::opts_chunk$set( collapse = TRUE, comment = "#>", @@ -12,12 +13,12 @@ knitr::opts_chunk$set( ) ``` -# ggplot2 +# ggplot2 ggplot2 website [![R-CMD-check](https://github.com/tidyverse/ggplot2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/tidyverse/ggplot2/actions/workflows/R-CMD-check.yaml) -[![Codecov test coverage](https://codecov.io/gh/tidyverse/ggplot2/branch/main/graph/badge.svg)](https://app.codecov.io/gh/tidyverse/ggplot2?branch=main) [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/ggplot2)](https://cran.r-project.org/package=ggplot2) +[![Codecov test coverage](https://codecov.io/gh/tidyverse/ggplot2/graph/badge.svg)](https://app.codecov.io/gh/tidyverse/ggplot2) ## Overview @@ -26,7 +27,8 @@ ggplot2 is a system for declaratively creating graphics, based on [The Grammar o ## Installation -```{r, eval = FALSE} +```{r} +#| eval: false # The easiest way to get ggplot2 is to install the whole tidyverse: install.packages("tidyverse") @@ -40,14 +42,15 @@ pak::pak("tidyverse/ggplot2") ## Cheatsheet - +ggplot2 cheatsheet ## Usage It's hard to succinctly describe how ggplot2 works because it embodies a deep philosophy of visualisation. However, in most cases you start with `ggplot()`, supply a dataset and aesthetic mapping (with `aes()`). You then add on layers (like `geom_point()` or `geom_histogram()`), scales (like `scale_colour_brewer()`), faceting specifications (like `facet_wrap()`) and coordinate systems (like `coord_flip()`). -```{r example} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +```{r} +#| label: example +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars coloured by 7 'types' of car. The displacement and miles #| per gallon are inversely correlated." library(ggplot2) @@ -67,7 +70,7 @@ If you are looking for innovation, look to ggplot2's rich ecosystem of extension ## Learning ggplot2 -If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual documentation pages. Currently, there are three good places to start: +If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual documentation pages. Currently, there are several good places to start: 1. The [Data Visualization][r4ds-vis] and [Communication][r4ds-comm] chapters in @@ -89,7 +92,12 @@ If you are new to ggplot2 you are better off starting with a systematic introduc by Winston Chang. It provides a set of recipes to solve common graphics problems. -If you've mastered the basics and want to learn more, read [ggplot2: Elegant Graphics for Data Analysis][ggplot2-book]. It describes the theoretical underpinnings of ggplot2 and shows you how all the pieces fit together. This book helps you understand the theory that underpins ggplot2, and will help you create new types of graphics specifically tailored to your needs. +1. If you've mastered the basics and want to learn more, read [ggplot2: Elegant Graphics for Data Analysis][ggplot2-book]. + It describes the theoretical underpinnings of ggplot2 and shows you how all the pieces fit together. + This book helps you understand the theory that underpins ggplot2, + and will help you create new types of graphics specifically tailored to your needs. + +1. For articles about announcements and deep-dives you can visit the [tidyverse blog][blog]. ## Getting help @@ -111,3 +119,4 @@ There are two main places to get help with ggplot2: [r4ds-vis]: https://r4ds.hadley.nz/data-visualize [r4ds-comm]: https://r4ds.hadley.nz/communication [oreilly]: https://learning.oreilly.com/videos/data-visualization-in/9781491963661/ +[blog]: https://www.tidyverse.org/tags/ggplot2/ diff --git a/README.md b/README.md index 59f357f0bb..eed37e27ec 100644 --- a/README.md +++ b/README.md @@ -1,14 +1,14 @@ -# ggplot2 +# ggplot2 ggplot2 website [![R-CMD-check](https://github.com/tidyverse/ggplot2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/tidyverse/ggplot2/actions/workflows/R-CMD-check.yaml) -[![Codecov test -coverage](https://codecov.io/gh/tidyverse/ggplot2/branch/main/graph/badge.svg)](https://app.codecov.io/gh/tidyverse/ggplot2?branch=main) [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/ggplot2)](https://cran.r-project.org/package=ggplot2) +[![Codecov test +coverage](https://codecov.io/gh/tidyverse/ggplot2/graph/badge.svg)](https://app.codecov.io/gh/tidyverse/ggplot2) ## Overview @@ -35,7 +35,7 @@ pak::pak("tidyverse/ggplot2") ## Cheatsheet - +ggplot2 cheatsheet ## Usage @@ -76,7 +76,7 @@ extensions. See a community maintained list at If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual -documentation pages. Currently, there are three good places to start: +documentation pages. Currently, there are several good places to start: 1. The [Data Visualization](https://r4ds.hadley.nz/data-visualize) and [Communication](https://r4ds.hadley.nz/communication) chapters in [R @@ -99,12 +99,15 @@ documentation pages. Currently, there are three good places to start: Cookbook](https://r-graphics.org) by Winston Chang. It provides a set of recipes to solve common graphics problems. -If you’ve mastered the basics and want to learn more, read [ggplot2: -Elegant Graphics for Data Analysis](https://ggplot2-book.org). It -describes the theoretical underpinnings of ggplot2 and shows you how all -the pieces fit together. This book helps you understand the theory that -underpins ggplot2, and will help you create new types of graphics -specifically tailored to your needs. +5. If you’ve mastered the basics and want to learn more, read [ggplot2: + Elegant Graphics for Data Analysis](https://ggplot2-book.org). It + describes the theoretical underpinnings of ggplot2 and shows you how + all the pieces fit together. This book helps you understand the + theory that underpins ggplot2, and will help you create new types of + graphics specifically tailored to your needs. + +6. For articles about announcements and deep-dives you can visit the + [tidyverse blog](https://www.tidyverse.org/tags/ggplot2/). ## Getting help diff --git a/_pkgdown.yml b/_pkgdown.yml index 1e4ea6a727..5b0505afd8 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -68,6 +68,8 @@ reference: - stat_summary_bin - stat_unique - stat_sf_coordinates + - stat_manual + - stat_connect - after_stat - subtitle: Position adjustment @@ -185,6 +187,7 @@ reference: - theme - theme_bw - theme_update + - subtheme - element_line - margin diff --git a/ggplot2.Rproj b/ggplot2.Rproj index 30db3b4433..5215454023 100644 --- a/ggplot2.Rproj +++ b/ggplot2.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: f500cb87-e0be-413f-b396-3eb022932f55 RestoreWorkspace: Default SaveWorkspace: Default diff --git a/man/aes.Rd b/man/aes.Rd index c49fbefada..ed77c5d39e 100644 --- a/man/aes.Rd +++ b/man/aes.Rd @@ -30,6 +30,13 @@ This function also standardises aesthetic names by converting \code{color} to \c (also in substrings, e.g., \code{point_color} to \code{point_colour}) and translating old style R names to ggplot names (e.g., \code{pch} to \code{shape} and \code{cex} to \code{size}). } +\note{ +Using \code{I()} to create objects of class 'AsIs' causes scales to ignore the +variable and assumes the wrapped variable is direct input for the grid +package. Please be aware that variables are sometimes combined, like in +some stats or position adjustments, that may yield unexpected results with +'AsIs' variables. +} \section{Quasiquotation}{ diff --git a/man/aes_eval.Rd b/man/aes_eval.Rd index 827bc6a876..aaf4c55277 100644 --- a/man/aes_eval.Rd +++ b/man/aes_eval.Rd @@ -5,6 +5,7 @@ \alias{after_stat} \alias{stat} \alias{after_scale} +\alias{from_theme} \alias{stage} \title{Control aesthetic evaluation} \usage{ @@ -16,6 +17,8 @@ after_stat(x) after_scale(x) +from_theme(x) + stage(start = NULL, after_stat = NULL, after_scale = NULL) } \arguments{ @@ -46,7 +49,7 @@ should be evaluated. \section{Staging}{ Below follows an overview of the three stages of evaluation and how aesthetic evaluation can be controlled. -\subsection{Stage 1: direct input}{ +\subsection{Stage 1: direct input at the start}{ The default is to map at the beginning, using the layer data provided by the user. If you want to map directly from the layer data you should not do @@ -105,16 +108,18 @@ ggplot(mpg, aes(cty, colour = factor(cyl))) + \subsection{Complex staging}{ -If you want to map the same aesthetic multiple times, e.g. map \code{x} to a -data column for the stat, but remap it for the geom, you can use the -\code{stage()} function to collect multiple mappings. +Sometimes, you may want to map the same aesthetic multiple times, e.g. map +\code{x} to a data column at the start for the layer stat, but remap it later to +a variable from the stat transformation for the layer geom. The \code{stage()} +function allows you to control multiple mappings for the same aesthetic +across all three stages of evaluation. \if{html}{\out{
}}\preformatted{# Use stage to modify the scaled fill ggplot(mpg, aes(class, hwy)) + geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4)))) # Using data for computing summary, but placing label elsewhere. -# Also, we're making our own computed variable to use for the label. +# Also, we're making our own computed variables to use for the label. ggplot(mpg, aes(class, displ)) + geom_violin() + stat_summary( @@ -126,6 +131,19 @@ ggplot(mpg, aes(class, displ)) + fun.data = ~ round(data.frame(mean = mean(.x), sd = sd(.x)), 2) ) }\if{html}{\out{
}} + +Conceptually, \code{aes(x)} is equivalent to \code{aes(stage(start = x))}, and +\code{aes(after_stat(count))} is equivalent to \code{aes(stage(after_stat = count))}, +and so on. \code{stage()} is most useful when at least two of its arguments are +specified. +} + +\subsection{Theme access}{ + +The \code{from_theme()} function can be used to acces the \code{\link[=element_geom]{element_geom()}} +fields of the \code{theme(geom)} argument. Using \code{aes(colour = from_theme(ink))} +and \code{aes(colour = from_theme(accent))} allows swapping between foreground and +accent colours. } } diff --git a/man/aes_position.Rd b/man/aes_position.Rd index 6777676b90..4f1cf4bbae 100644 --- a/man/aes_position.Rd +++ b/man/aes_position.Rd @@ -30,6 +30,18 @@ geometry that they're used in. These are \code{xintercept}, \code{yintercept}, \code{xmin_final}, \code{ymin_final}, \code{xmax_final}, \code{ymax_final}, \code{xlower}, \code{lower}, \code{xmiddle}, \code{middle}, \code{xupper}, \code{upper}, \code{x0} and \code{y0}. Many of these are used and automatically computed in \code{\link[=geom_boxplot]{geom_boxplot()}}. +\subsection{Relation to \code{width} and \code{height}}{ + +The position aesthetics mentioned above like \code{x} and \code{y} are all location +based. The \code{width} and \code{height} aesthetics are closely related length +based aesthetics, but are not position aesthetics. Consequently, \code{x} and \code{y} +aesthetics respond to scale transformations, whereas the length based +\code{width} and \code{height} aesthetics are not transformed by scales. For example, +if we have the pair \verb{x = 10, width = 2}, that gets translated to the +locations \verb{xmin = 9, xmax = 11} when using the default identity scales. +However, the same pair becomes \verb{xmin = 1, xmax = 100} when using log10 scales, +as \code{width = 2} in log10-space spans a 100-fold change. +} } \examples{ diff --git a/man/bidirection.Rd b/man/bidirection.Rd index f58460091c..be6ffec336 100644 --- a/man/bidirection.Rd +++ b/man/bidirection.Rd @@ -15,7 +15,8 @@ has_flipped_aes( group_has_equal = FALSE, ambiguous = FALSE, main_is_continuous = FALSE, - main_is_optional = FALSE + main_is_optional = FALSE, + default = FALSE ) flip_data(data, flip = NULL) @@ -48,6 +49,9 @@ the continuous one correspond to the main orientation?} \item{main_is_optional}{Is the main axis aesthetic optional and, if not given, set to \code{0}} +\item{default}{The logical value to return if no orientation can be discerned +from the data.} + \item{flip}{Logical. Is the layer flipped.} } \value{ diff --git a/man/binned_scale.Rd b/man/binned_scale.Rd index c1bbd50404..203cd66bb4 100644 --- a/man/binned_scale.Rd +++ b/man/binned_scale.Rd @@ -55,7 +55,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/borders.Rd b/man/borders.Rd index 1fcb3f2630..2f5e9f6841 100644 --- a/man/borders.Rd +++ b/man/borders.Rd @@ -53,7 +53,7 @@ will be used as the layer data. A \code{function} can be created from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{\code{stat}}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -79,7 +79,9 @@ to use \code{position_jitter()}, give the position as \code{"jitter"}. \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{\code{inherit.aes}}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions that define both data and aesthetics and shouldn't inherit behaviour from diff --git a/man/complete_theme.Rd b/man/complete_theme.Rd new file mode 100644 index 0000000000..b90e6abc9b --- /dev/null +++ b/man/complete_theme.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme.R +\name{complete_theme} +\alias{complete_theme} +\title{Complete a theme} +\usage{ +complete_theme(theme = NULL, default = theme_get()) +} +\arguments{ +\item{theme}{An incomplete \link[=theme]{theme} object to complete, or \code{NULL} +to complete the default theme.} + +\item{default}{A complete \link[=theme]{theme} to fill in missing pieces. +Defaults to the global theme settings.} +} +\value{ +A \link[=theme]{theme} object. +} +\description{ +This function takes a theme and completes it so that it can be used +downstream to render theme elements. Missing elements are filled in and +every item is validated to the specifications of the element tree. +} +\examples{ +my_theme <- theme(line = element_line(colour = "red")) +complete_theme(my_theme) +} +\keyword{internal} diff --git a/man/continuous_scale.Rd b/man/continuous_scale.Rd index dc4abffbce..76d7492ba6 100644 --- a/man/continuous_scale.Rd +++ b/man/continuous_scale.Rd @@ -56,13 +56,13 @@ Also accepts rlang \link[rlang:as_function]{lambda} function notation. \item{minor_breaks}{One of: \itemize{ \item \code{NULL} for no minor breaks -\item \code{waiver()} for the default breaks (one minor break between -each major break) +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) \item A numeric vector of positions \item A function that given the limits returns a vector of minor breaks. Also accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major -breaks. +break positions. }} \item{n.breaks}{An integer guiding the number of major breaks. The algorithm @@ -70,7 +70,9 @@ may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/coord_cartesian.Rd b/man/coord_cartesian.Rd index 5c39f4d288..15afad523a 100644 --- a/man/coord_cartesian.Rd +++ b/man/coord_cartesian.Rd @@ -9,7 +9,8 @@ coord_cartesian( ylim = NULL, expand = TRUE, default = FALSE, - clip = "on" + clip = "on", + reverse = "none" ) } \arguments{ @@ -17,7 +18,11 @@ coord_cartesian( \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} \item{default}{Is this the default coordinate system? If \code{FALSE} (the default), then replacing this coordinate system with another one creates a message alerting @@ -32,6 +37,11 @@ drawing of data points anywhere on the plot, including in the plot margins. If limits are set via \code{xlim} and \code{ylim} and some data points fall outside those limits, then those data points may show up in places such as the axes, the legend, the plot title, or the plot margins.} + +\item{reverse}{A string giving which directions to reverse. \code{"none"} +(default) keeps directions as is. \code{"x"} and \code{"y"} can be used to reverse +their respective directions. \code{"xy"} can be used to reverse both +directions.} } \description{ The Cartesian coordinate system is the most familiar, and common, type of diff --git a/man/coord_fixed.Rd b/man/coord_fixed.Rd index fc8c052506..a3d8d358b7 100644 --- a/man/coord_fixed.Rd +++ b/man/coord_fixed.Rd @@ -5,7 +5,14 @@ \alias{coord_equal} \title{Cartesian coordinates with fixed "aspect ratio"} \usage{ -coord_fixed(ratio = 1, xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") +coord_fixed( + ratio = 1, + xlim = NULL, + ylim = NULL, + expand = TRUE, + clip = "on", + reverse = "none" +) } \arguments{ \item{ratio}{aspect ratio, expressed as \code{y / x}} @@ -14,7 +21,11 @@ coord_fixed(ratio = 1, xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} \item{clip}{Should drawing be clipped to the extent of the plot panel? A setting of \code{"on"} (the default) means yes, and a setting of \code{"off"} @@ -24,6 +35,11 @@ drawing of data points anywhere on the plot, including in the plot margins. If limits are set via \code{xlim} and \code{ylim} and some data points fall outside those limits, then those data points may show up in places such as the axes, the legend, the plot title, or the plot margins.} + +\item{reverse}{A string giving which directions to reverse. \code{"none"} +(default) keeps directions as is. \code{"x"} and \code{"y"} can be used to reverse +their respective directions. \code{"xy"} can be used to reverse both +directions.} } \description{ A fixed scale coordinate system forces a specified ratio between the diff --git a/man/coord_flip.Rd b/man/coord_flip.Rd index be69644cf0..48ea2e1dba 100644 --- a/man/coord_flip.Rd +++ b/man/coord_flip.Rd @@ -11,7 +11,11 @@ coord_flip(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} \item{clip}{Should drawing be clipped to the extent of the plot panel? A setting of \code{"on"} (the default) means yes, and a setting of \code{"off"} diff --git a/man/coord_map.Rd b/man/coord_map.Rd index 3aacd167d7..913768f29e 100644 --- a/man/coord_map.Rd +++ b/man/coord_map.Rd @@ -40,7 +40,11 @@ means no. For details, please see \code{\link[=coord_cartesian]{coord_cartesian( \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} diff --git a/man/coord_polar.Rd b/man/coord_polar.Rd index 78265507d6..3bc579bcbc 100644 --- a/man/coord_polar.Rd +++ b/man/coord_polar.Rd @@ -11,12 +11,15 @@ coord_radial( theta = "x", start = 0, end = NULL, + thetalim = NULL, + rlim = NULL, expand = TRUE, - direction = 1, + direction = deprecated(), clip = "off", r.axis.inside = NULL, rotate.angle = FALSE, inner.radius = 0, + reverse = "none", r_axis_inside = deprecated(), rotate_angle = deprecated() ) @@ -37,21 +40,34 @@ means no. For details, please see \code{\link[=coord_cartesian]{coord_cartesian( for partial polar coordinates. The default, \code{NULL}, is set to \code{start + 2 * pi}.} -\item{expand}{If \code{TRUE}, the default, adds a small expansion factor the +\item{thetalim, rlim}{Limits for the theta and r axes.} + +\item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to prevent overlap between data and axes. If \code{FALSE}, limits are taken directly from the scale.} -\item{r.axis.inside}{If \code{TRUE}, places the radius axis inside the -panel. If \code{FALSE}, places the radius axis next to the panel. The default, -\code{NULL}, places the radius axis outside if the \code{start} and \code{end} arguments -form a full circle.} +\item{r.axis.inside}{One of the following: +\itemize{ +\item \code{NULL} (default) places the axis next to the panel if \code{start} and +\code{end} arguments form a full circle and inside the panel otherwise. +\item \code{TRUE} to place the radius axis inside the panel. +\item \code{FALSE} to place the radius axis next to the panel. +\item A numeric value, setting a theta axis value at which +the axis should be placed inside the panel. Can be given as a length 2 +vector to control primary and secondary axis placement separately. +}} \item{rotate.angle}{If \code{TRUE}, transforms the \code{angle} aesthetic in data in accordance with the computed \code{theta} position. If \code{FALSE} (default), no such transformation is performed. Can be useful to rotate text geoms in alignment with the coordinates.} -\item{inner.radius}{A \code{numeric} between 0 and 1 setting the size of a inner.radius hole.} +\item{inner.radius}{A \code{numeric} between 0 and 1 setting the size of a +inner radius hole.} + +\item{reverse}{A string giving which directions to reverse. \code{"none"} +(default) keep directions as is. \code{"theta"} reverses the angle and \code{"r"} +reverses the radius. \code{"thetar"} reverses both the angle and the radius.} \item{r_axis_inside, rotate_angle}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } @@ -61,10 +77,10 @@ are a stacked bar chart in polar coordinates. \code{coord_radial()} has extended options. } \note{ -In \code{coord_radial()}, position guides are can be defined by using +In \code{coord_radial()}, position guides can be defined by using \code{guides(r = ..., theta = ..., r.sec = ..., theta.sec = ...)}. Note that these guides require \code{r} and \code{theta} as available aesthetics. The classic -\code{guide_axis()} can be used for the \code{r} positions and \code{guide_axis_theta()} can +\code{\link[=guide_axis]{guide_axis()}} can be used for the \code{r} positions and \code{\link[=guide_axis_theta]{guide_axis_theta()}} can be used for the \code{theta} positions. Using the \code{theta.sec} position is only sensible when \code{inner.radius > 0}. } @@ -74,7 +90,7 @@ sensible when \code{inner.radius > 0}. # to demonstrate how these common plots can be described in the # grammar. Use with EXTREME caution. -#' # A pie chart = stacked bar chart + polar coordinates +# A pie chart = stacked bar chart + polar coordinates pie <- ggplot(mtcars, aes(x = factor(1), fill = factor(cyl))) + geom_bar(width = 1) pie + coord_polar(theta = "y") @@ -119,6 +135,16 @@ doh + geom_bar(width = 0.9, position = "fill") + coord_polar(theta = "y") ggplot(mtcars, aes(disp, mpg)) + geom_point() + coord_radial(start = -0.4 * pi, end = 0.4 * pi, inner.radius = 0.3) + +# Similar with coord_cartesian(), you can set limits. +ggplot(mtcars, aes(disp, mpg)) + + geom_point() + + coord_radial( + start = -0.4 * pi, + end = 0.4 * pi, inner.radius = 0.3, + thetalim = c(200, 300), + rlim = c(15, 30), + ) } \seealso{ The \href{https://ggplot2-book.org/coord#polar-coordinates-with-coord_polar}{polar coordinates section} of the online ggplot2 book. diff --git a/man/coord_trans.Rd b/man/coord_trans.Rd index bea5b54716..0d9d2d6f79 100644 --- a/man/coord_trans.Rd +++ b/man/coord_trans.Rd @@ -12,7 +12,8 @@ coord_trans( limx = deprecated(), limy = deprecated(), clip = "on", - expand = TRUE + expand = TRUE, + reverse = "none" ) } \arguments{ @@ -33,7 +34,16 @@ legend, the plot title, or the plot margins.} \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} + +\item{reverse}{A string giving which directions to reverse. \code{"none"} +(default) keeps directions as is. \code{"x"} and \code{"y"} can be used to reverse +their respective directions. \code{"xy"} can be used to reverse both +directions.} } \description{ \code{coord_trans()} is different to scale transformations in that it occurs after diff --git a/man/datetime_scale.Rd b/man/datetime_scale.Rd index d0a1afeec2..c843dc0706 100644 --- a/man/datetime_scale.Rd +++ b/man/datetime_scale.Rd @@ -61,7 +61,9 @@ values between 0 and 1 returns the corresponding output values output }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/discrete_scale.Rd b/man/discrete_scale.Rd index 0fd213cd30..cf76226a67 100644 --- a/man/discrete_scale.Rd +++ b/man/discrete_scale.Rd @@ -10,6 +10,7 @@ discrete_scale( palette, name = waiver(), breaks = waiver(), + minor_breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), @@ -47,7 +48,21 @@ as output. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{minor_breaks}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/element.Rd b/man/element.Rd index 054a7aff6d..b8dfbf6a7b 100644 --- a/man/element.Rd +++ b/man/element.Rd @@ -6,8 +6,12 @@ \alias{element_line} \alias{element_text} \alias{is_theme_element} +\alias{element_point} +\alias{element_geom} \alias{rel} \alias{margin} +\alias{margin_part} +\alias{margin_auto} \title{Theme elements} \usage{ element_blank() @@ -29,6 +33,7 @@ element_line( lineend = NULL, color = NULL, arrow = NULL, + arrow.fill = NULL, inherit.blank = FALSE, size = deprecated() ) @@ -50,21 +55,54 @@ element_text( is_theme_element(x, type = "any") +element_point( + colour = NULL, + shape = NULL, + size = NULL, + fill = NULL, + stroke = NULL, + color = NULL, + inherit.blank = FALSE +) + +element_geom( + 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 +) + rel(x) margin(t = 0, r = 0, b = 0, l = 0, unit = "pt") + +margin_part(t = NA, r = NA, b = NA, l = NA, unit = "pt") + +margin_auto(t = 0, r = t, b = t, l = r, unit = "pt") } \arguments{ -\item{fill}{Fill colour.} +\item{fill}{Fill colour. \code{fill_alpha()} can be used to set the transparency +of the fill.} -\item{colour, color}{Line/border colour. Color is an alias for colour.} +\item{colour, color}{Line/border colour. Color is an alias for colour. +\code{alpha()} can be used to set the transparency of the colour.} -\item{linewidth}{Line/border size in mm.} +\item{linewidth, borderwidth, stroke}{Line/border size in mm.} -\item{linetype}{Line type. An integer (0:8), a name (blank, solid, -dashed, dotted, dotdash, longdash, twodash), or a string with -an even number (up to eight) of hexadecimal digits which give the -lengths in consecutive positions in the string.} +\item{linetype, bordertype}{Line type for lines and borders respectively. An +integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, +twodash), or a string with an even number (up to eight) of hexadecimal +digits which give the lengths in consecutive positions in the string.} \item{inherit.blank}{Should this element inherit the existence of an \code{element_blank} among its parents? If \code{TRUE} the existence of @@ -72,12 +110,14 @@ a blank element among its parents will cause this element to be blank as well. If \code{FALSE} any blank parent element will be ignored when calculating final element state.} -\item{size}{text size in pts.} +\item{size, fontsize, pointsize}{text size in pts, point size in mm.} \item{lineend}{Line end Line end style (round, butt, square)} \item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}} +\item{arrow.fill}{Fill colour for arrows.} + \item{family}{Font family} \item{face}{Font face ("plain", "italic", "bold", "bold.italic")} @@ -103,6 +143,14 @@ is anchored.} \item{type}{For testing elements: the type of element to expect. One of \code{"blank"}, \code{"rect"}, \code{"line"} or \code{"text"}.} +\item{shape, pointshape}{Shape for points (1-25).} + +\item{ink}{Foreground colour.} + +\item{paper}{Background colour.} + +\item{accent}{Accent colour.} + \item{t, r, b, l}{Dimensions of each margin. (To remember order, think trouble).} \item{unit}{Default units of dimensions. Defaults to "pt" so it @@ -119,34 +167,54 @@ specify the display of how non-data components of the plot are drawn. \item \code{element_rect()}: borders and backgrounds. \item \code{element_line()}: lines. \item \code{element_text()}: text. +\item \code{element_polygon()}: polygons. +\item \code{element_point()}: points. +\item \code{element_geom()}: defaults for drawing layers. } \code{rel()} is used to specify sizes relative to the parent, -\code{margin()} is used to specify the margins of elements. +\code{margin()}, \code{margin_part()} and \code{margin_auto()} are all used to specify the +margins of elements. +} +\details{ +The \code{element_polygon()} and \code{element_point()} functions are not rendered +in standard plots and just serve as extension points. } \examples{ +# A standard plot plot <- ggplot(mpg, aes(displ, hwy)) + geom_point() +# Turning off theme elements by setting them to blank plot + theme( panel.background = element_blank(), axis.text = element_blank() ) +# Text adjustments plot + theme( axis.text = element_text(colour = "red", size = rel(1.5)) ) +# Turning on the axis line with an arrow plot + theme( axis.line = element_line(arrow = arrow()) ) plot + theme( panel.background = element_rect(fill = "white"), - plot.margin = margin(2, 2, 2, 2, "cm"), + plot.margin = margin_auto(2, unit = "cm"), plot.background = element_rect( fill = "grey90", colour = "black", linewidth = 1 ) ) + +ggplot(mpg, aes(displ, hwy)) + + geom_point() + + geom_smooth(formula = y ~ x, method = "lm") + + theme(geom = element_geom( + ink = "red", accent = "black", + pointsize = 1, linewidth = 2 + )) } diff --git a/man/facet_grid.Rd b/man/facet_grid.Rd index e0a3cd1e1b..df687239a1 100644 --- a/man/facet_grid.Rd +++ b/man/facet_grid.Rd @@ -100,6 +100,20 @@ faceting variables. It is most useful when you have two discrete variables, and all combinations of the variables exist in the data. If you have only one variable with many levels, try \code{\link[=facet_wrap]{facet_wrap()}}. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_grid()} can take +the following values: +\itemize{ +\item \code{NULL} (default) to use the faceting variables to assign panels. +\item An integer vector to include selected panels. Panel numbers not included in +the integer vector are excluded. +\item \code{"fixed"} to repeat data across every panel. +\item \code{"fixed_rows"} to repeat data across rows. +\item \code{"fixed_cols"} to repeat data across columns. +} +} + \examples{ p <- ggplot(mpg, aes(displ, cty)) + geom_point() diff --git a/man/facet_null.Rd b/man/facet_null.Rd index 3e1c058771..9e0f0ba3d6 100644 --- a/man/facet_null.Rd +++ b/man/facet_null.Rd @@ -14,6 +14,12 @@ before statistical summary.} \description{ Facet specification: a single panel. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_null()} is +completely ignored. +} + \examples{ # facet_null is the default faceting specification if you # don't override it with facet_grid or facet_wrap diff --git a/man/facet_wrap.Rd b/man/facet_wrap.Rd index b765efe1dd..4cfcf1284e 100644 --- a/man/facet_wrap.Rd +++ b/man/facet_wrap.Rd @@ -9,6 +9,7 @@ facet_wrap( nrow = NULL, ncol = NULL, scales = "fixed", + space = "fixed", shrink = TRUE, labeller = "label_value", as.table = TRUE, @@ -35,6 +36,13 @@ or a character vector, \code{c("a", "b")}.} free (\code{"free"}), or free in one dimension (\code{"free_x"}, \code{"free_y"})?} +\item{space}{If \code{"fixed"} (default), all panels have the same size and +the number of rows and columns in the layout can be arbitrary. If +\code{"free_x"}, panels have widths proportional to the length of the x-scale, +but the layout is constrained to one row. If \code{"free_y"}, panels have +heights proportional to the length of the y-scale, but the layout is +constrained to one column.} + \item{shrink}{If \code{TRUE}, will shrink scales to fit output of statistics, not raw data. If \code{FALSE}, will be range of raw data before statistical summary.} @@ -65,7 +73,12 @@ data will automatically be dropped. If \code{FALSE}, all factor levels will be shown, regardless of whether or not they appear in the data.} \item{dir}{Direction: either \code{"h"} for horizontal, the default, or \code{"v"}, -for vertical.} +for vertical. When \code{"h"} or \code{"v"} will be combined with \code{as.table} to +set final layout. Alternatively, a combination of \code{"t"} (top) or +\code{"b"} (bottom) with \code{"l"} (left) or \code{"r"} (right) to set a layout directly. +These two letters give the starting position and the first letter gives +the growing direction. For example \code{"rt"} will place the first panel in +the top-right and starts filling in panels right-to-left.} \item{strip.position}{By default, the labels are displayed on the top of the plot. Using \code{strip.position} it is possible to place the labels on @@ -89,6 +102,18 @@ x- or y-direction respectively.} a better use of screen space than \code{\link[=facet_grid]{facet_grid()}} because most displays are roughly rectangular. } +\section{Layer layout}{ + +The \code{\link[=layer]{layer(layout)}} argument in context of \code{facet_wrap()} can take +the following values: +\itemize{ +\item \code{NULL} (default) to use the faceting variables to assign panels. +\item An integer vector to include selected panels. Panel numbers not included in +the integer vector are excluded. +\item \code{"fixed"} to repeat data across every panel. +} +} + \examples{ p <- ggplot(mpg, aes(displ, hwy)) + geom_point() @@ -146,6 +171,14 @@ ggplot(economics_long, aes(date, value)) + facet_wrap(vars(variable), scales = "free_y", nrow = 2, strip.position = "top") + theme(strip.background = element_blank(), strip.placement = "outside") } + +# The two letters determine the starting position, so 'tr' starts +# in the top-right. +# The first letter determines direction, so 'tr' fills top-to-bottom. +# `dir = "tr"` is equivalent to `dir = "v", as.table = FALSE` +ggplot(mpg, aes(displ, hwy)) + + geom_point() + + facet_wrap(vars(class), dir = "tr") } \seealso{ The \href{https://ggplot2-book.org/facet#sec-facet-wrap}{facet wrap section} of the online ggplot2 book. diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg index 4baaee01cd..b61c57c3f9 100644 --- a/man/figures/lifecycle-deprecated.svg +++ b/man/figures/lifecycle-deprecated.svg @@ -1 +1,21 @@ -lifecyclelifecycledeprecateddeprecated \ No newline at end of file + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg index d1d060e923..5d88fc2c65 100644 --- a/man/figures/lifecycle-experimental.svg +++ b/man/figures/lifecycle-experimental.svg @@ -1 +1,21 @@ -lifecyclelifecycleexperimentalexperimental \ No newline at end of file + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg index e015dc8110..9bf21e76bc 100644 --- a/man/figures/lifecycle-stable.svg +++ b/man/figures/lifecycle-stable.svg @@ -1 +1,29 @@ -lifecyclelifecyclestablestable \ No newline at end of file + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg index 75f24f5534..db8d757f70 100644 --- a/man/figures/lifecycle-superseded.svg +++ b/man/figures/lifecycle-superseded.svg @@ -1 +1,21 @@ - lifecyclelifecyclesupersededsuperseded \ No newline at end of file + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/figures/linetype_table.pdf b/man/figures/linetype_table.pdf new file mode 100644 index 0000000000..29710c0883 Binary files /dev/null and b/man/figures/linetype_table.pdf differ diff --git a/man/figures/linetype_table.svg b/man/figures/linetype_table.svg new file mode 100644 index 0000000000..9ea0a7ea82 --- /dev/null +++ b/man/figures/linetype_table.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + +"blank"/NA +"solid" +"dashed" +"dotted" +"dotdash" +"longdash" +"twodash" +0/NA +1 +2 +3 +4 +5 +6 +"44" +"13" +"1343" +"73" +"2262" + + + + + + + + +Number +Name +Hex code +Display + + diff --git a/man/figures/logo.png b/man/figures/logo.png index 719583f619..8007389c72 100644 Binary files a/man/figures/logo.png and b/man/figures/logo.png differ diff --git a/man/figures/shape_table.pdf b/man/figures/shape_table.pdf new file mode 100644 index 0000000000..8e7f539dc2 Binary files /dev/null and b/man/figures/shape_table.pdf differ diff --git a/man/figures/shape_table.svg b/man/figures/shape_table.svg new file mode 100644 index 0000000000..b94a3471fc --- /dev/null +++ b/man/figures/shape_table.svg @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0: +square open +1: +circle open +2: +triangle open +3: +plus +4: +cross +5: +diamond open +6: +triangle down open +7: +square cross +8: +asterisk +9: +diamond plus +10: +circle plus +11: +star +12: +square plus +13: +circle cross +14: +square triangle +15: +square +16: +circle small +17: +triangle +18: +diamond +19: +circle +20: +bullet +21: +circle filled +22: +square filled +23: +diamond filled +24: +triangle filled +25: +triangle down filled + + diff --git a/man/fortify-multcomp.Rd b/man/fortify-multcomp.Rd index a52dec001c..654e5bbe9a 100644 --- a/man/fortify-multcomp.Rd +++ b/man/fortify-multcomp.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fortify-multcomp.R +% Please edit documentation in R/fortify-models.R \name{fortify-multcomp} \alias{fortify-multcomp} \alias{fortify.glht} @@ -23,29 +23,41 @@ \item{data, ...}{other arguments to the generic ignored in this method.} } \description{ -Fortify methods for objects produced by \pkg{multcomp} +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + +This function is deprecated because using \code{broom::tidy()} is a better +solution to convert model objects. } \examples{ -if (require("multcomp")) { +\dontshow{if (require("multcomp") && require("broom")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} amod <- aov(breaks ~ wool + tension, data = warpbreaks) -wht <- glht(amod, linfct = mcp(tension = "Tukey")) +wht <- multcomp::glht(amod, linfct = multcomp::mcp(tension = "Tukey")) +tidy(wht) # recommended fortify(wht) -ggplot(wht, aes(lhs, estimate)) + geom_point() -CI <- confint(wht) -fortify(CI) -ggplot(CI, aes(lhs, estimate, ymin = lwr, ymax = upr)) + +ggplot(tidy(wht), aes(contrast, estimate)) + geom_point() + +ci <- confint(wht) +tidy(ci) # recommended +fortify(ci) + +ggplot(tidy(confint(wht)), + aes(contrast, estimate, ymin = conf.low, ymax = conf.high)) + geom_pointrange() -fortify(summary(wht)) -ggplot(mapping = aes(lhs, estimate)) + - geom_linerange(aes(ymin = lwr, ymax = upr), data = CI) + - geom_point(aes(size = p), data = summary(wht)) + +smry <- summary(wht) +tidy(smry) # recommended +fortify(smry) + +ggplot(mapping = aes(contrast, estimate)) + + geom_linerange(aes(ymin = conf.low, ymax = conf.high), data = tidy(ci)) + + geom_point(aes(size = adj.p.value), data = tidy(smry)) + scale_size(transform = "reverse") -cld <- cld(wht) +cld <- multcomp::cld(wht) +tidy(cld) # recommended fortify(cld) -} +\dontshow{\}) # examplesIf} } \keyword{internal} diff --git a/man/fortify.Rd b/man/fortify.Rd index 59dcfea9ec..36d1837025 100644 --- a/man/fortify.Rd +++ b/man/fortify.Rd @@ -11,7 +11,7 @@ fortify(model, data, ...) \item{data}{original dataset, if needed} -\item{...}{other arguments passed to methods} +\item{...}{Arguments passed to methods.} } \description{ Rather than using this function, I now recommend using the \pkg{broom} diff --git a/man/fortify.lm.Rd b/man/fortify.lm.Rd index 4a994a6c56..d98b28a07f 100644 --- a/man/fortify.lm.Rd +++ b/man/fortify.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fortify-lm.R +% Please edit documentation in R/fortify-models.R \name{fortify.lm} \alias{fortify.lm} \title{Supplement the data fitted to a linear model with model fit statistics.} @@ -24,65 +24,30 @@ corresponding observation is dropped from model} \item{.stdresid}{Standardised residuals} } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + +This method is deprecated because using \code{broom::augment()} is a better +solution to supplement data from a linear model. If you have missing values in your model data, you may need to refit the model with \code{na.action = na.exclude}. } \examples{ +\dontshow{if (require("broom")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} mod <- lm(mpg ~ wt, data = mtcars) -head(fortify(mod)) -head(fortify(mod, mtcars)) - -plot(mod, which = 1) -ggplot(mod, aes(.fitted, .resid)) + - geom_point() + - geom_hline(yintercept = 0) + - geom_smooth(se = FALSE) +# Show augmented model +head(augment(mod)) +head(fortify(mod)) -ggplot(mod, aes(.fitted, .stdresid)) + +# Using augment to convert model to ready-to-plot data +ggplot(augment(mod), aes(.fitted, .resid)) + geom_point() + geom_hline(yintercept = 0) + geom_smooth(se = FALSE) -ggplot(fortify(mod, mtcars), aes(.fitted, .stdresid)) + - geom_point(aes(colour = factor(cyl))) - -ggplot(fortify(mod, mtcars), aes(mpg, .stdresid)) + - geom_point(aes(colour = factor(cyl))) - -plot(mod, which = 2) -ggplot(mod) + - stat_qq(aes(sample = .stdresid)) + - geom_abline() - -plot(mod, which = 3) -ggplot(mod, aes(.fitted, sqrt(abs(.stdresid)))) + - geom_point() + - geom_smooth(se = FALSE) - -plot(mod, which = 4) -ggplot(mod, aes(seq_along(.cooksd), .cooksd)) + - geom_col() - -plot(mod, which = 5) -ggplot(mod, aes(.hat, .stdresid)) + - geom_vline(linewidth = 2, colour = "white", xintercept = 0) + - geom_hline(linewidth = 2, colour = "white", yintercept = 0) + - geom_point() + geom_smooth(se = FALSE) - -ggplot(mod, aes(.hat, .stdresid)) + - geom_point(aes(size = .cooksd)) + - geom_smooth(se = FALSE, linewidth = 0.5) - -plot(mod, which = 6) -ggplot(mod, aes(.hat, .cooksd)) + - geom_vline(xintercept = 0, colour = NA) + - geom_abline(slope = seq(0, 3, by = 0.5), colour = "white") + - geom_smooth(se = FALSE) + +# Colouring by original data not included in the model +ggplot(augment(mod, mtcars), aes(.fitted, .std.resid, colour = factor(cyl))) + geom_point() - -ggplot(mod, aes(.hat, .cooksd)) + - geom_point(aes(size = .cooksd / .hat)) + - scale_size_area() +\dontshow{\}) # examplesIf} } \keyword{internal} diff --git a/man/fortify.map.Rd b/man/fortify.map.Rd index 6ed4d9cd1b..ba1c5fbc63 100644 --- a/man/fortify.map.Rd +++ b/man/fortify.map.Rd @@ -14,6 +14,8 @@ \item{...}{not used by this method} } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + This function turns a map into a data frame that can more easily be plotted with ggplot2. } diff --git a/man/fortify.sp.Rd b/man/fortify.sp.Rd index af1a587f5d..0603c1ee05 100644 --- a/man/fortify.sp.Rd +++ b/man/fortify.sp.Rd @@ -35,6 +35,8 @@ \item{...}{not used by this method} } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + To figure out the correct variable name for region, inspect \code{as.data.frame(model)}. } diff --git a/man/geom_abline.Rd b/man/geom_abline.Rd index 9e13bc3de8..0c3bd12b24 100644 --- a/man/geom_abline.Rd +++ b/man/geom_abline.Rd @@ -19,6 +19,7 @@ geom_abline( geom_hline( mapping = NULL, data = NULL, + position = "identity", ..., yintercept, na.rm = FALSE, @@ -28,6 +29,7 @@ geom_hline( geom_vline( mapping = NULL, data = NULL, + position = "identity", ..., xintercept, na.rm = FALSE, @@ -87,7 +89,22 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} + +\item{position}{A position adjustment to use on the data for this layer. This +can be used in various ways, including to prevent overplotting and +improving the display. The \code{position} argument accepts the following: +\itemize{ +\item The result of calling a position function, such as \code{position_jitter()}. +This method allows for passing extra arguments to the position. +\item A string naming the position adjustment. To give the position as a +string, strip the function name of the \code{position_} prefix. For example, +to use \code{position_jitter()}, give the position as \code{"jitter"}. +\item For more information and other ways to specify the position, see the +\link[=layer_positions]{layer position} documentation. +}} \item{xintercept, yintercept, slope, intercept}{Parameters that control the position of the line. If these are set, \code{data}, \code{mapping} and diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index a974f9824e..1d19ff8f90 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -13,7 +13,6 @@ geom_bar( position = "stack", ..., just = 0.5, - width = NULL, na.rm = FALSE, orientation = NA, show.legend = NA, @@ -26,7 +25,6 @@ geom_col( position = "stack", ..., just = 0.5, - width = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -38,7 +36,6 @@ stat_count( geom = "bar", position = "stack", ..., - width = NULL, na.rm = FALSE, orientation = NA, show.legend = NA, @@ -113,9 +110,6 @@ columns to the left/right of axis breaks. Note that this argument may have unintended behaviour when used with alternative positions, e.g. \code{position_dodge()}.} -\item{width}{Bar width. By default, set to 90\% of the \code{\link[=resolution]{resolution()}} of the -data.} - \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -128,7 +122,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -172,39 +168,41 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_bar()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_bar()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{width} \tab → \code{0.9} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{geom_col()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_col()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{width} \tab → \code{0.9} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{stat_count()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} -\item \code{\link[=aes_group_order]{group}} -\item \code{weight} +\code{stat_count()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_bin_2d.Rd b/man/geom_bin_2d.Rd index 38341bf063..16b0fa4dad 100644 --- a/man/geom_bin_2d.Rd +++ b/man/geom_bin_2d.Rd @@ -26,6 +26,9 @@ stat_bin_2d( ..., bins = 30, binwidth = NULL, + center = NULL, + boundary = NULL, + breaks = NULL, drop = TRUE, na.rm = FALSE, show.legend = NA, @@ -101,7 +104,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -113,11 +118,33 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} + +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} + +\item{center, boundary}{bin position specifiers. Only one, \code{center} or +\code{boundary}, may be specified for a single plot. \code{center} specifies the +center of one of the bins. \code{boundary} specifies the boundary between two +bins. Note that if either is above or below the range of the data, things +will be shifted by the appropriate integer multiple of \code{binwidth}. +For example, to center on integers use \code{binwidth = 1} and \code{center = 0}, even +if \code{0} is outside the range of the data. Alternatively, this same alignment +can be specified with \code{binwidth = 1} and \code{boundary = 0.5}, even if \code{0.5} is +outside the range of the data.} + +\item{breaks}{Alternatively, you can supply a numeric vector giving +the bin boundaries. Overrides \code{binwidth}, \code{bins}, \code{center}, +and \code{boundary}. Can also be a function that takes group-wise values as input and returns bin boundaries.} \item{drop}{if \code{TRUE} removes all cells with 0 counts.} } @@ -129,13 +156,13 @@ in the presence of overplotting. } \section{Aesthetics}{ -\code{stat_bin_2d()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{weight} +\code{stat_bin_2d()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → \code{after_stat(count)} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -151,6 +178,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins}, \code{binwidth}, \code{breaks}, \code{center}, and \code{boundary} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(x, y)) + xlim(4, 10) + ylim(4, 10) d + geom_bin_2d() @@ -158,7 +195,7 @@ d + geom_bin_2d() # You can control the size of the bins by specifying the number of # bins in each direction: d + geom_bin_2d(bins = 10) -d + geom_bin_2d(bins = 30) +d + geom_bin_2d(bins = list(x = 30, y = 10)) # Or by specifying the width of the bins d + geom_bin_2d(binwidth = c(0.1, 0.1)) diff --git a/man/geom_blank.Rd b/man/geom_blank.Rd index c547845953..a8d4a2613d 100644 --- a/man/geom_blank.Rd +++ b/man/geom_blank.Rd @@ -37,7 +37,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -93,7 +93,9 @@ lists which parameters it can accept. \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index e995aa6635..d96c576da0 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -15,10 +15,26 @@ geom_boxplot( outlier.colour = NULL, outlier.color = NULL, outlier.fill = NULL, - outlier.shape = 19, - outlier.size = 1.5, + 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, @@ -112,10 +128,20 @@ only, not the full data range. If outliers need to be hidden and the axes needs to show the full data range, please use \code{outlier.shape = NA} instead.} \item{outlier.colour, outlier.color, outlier.fill, outlier.shape, outlier.size, outlier.stroke, outlier.alpha}{Default aesthetics for outliers. Set to \code{NULL} to inherit from the -aesthetics used for the box. +data's aesthetics.} -In the unlikely event you specify both US and UK spellings of colour, the -US spelling will take precedence.} +\item{whisker.colour, whisker.color, whisker.linetype, whisker.linewidth}{Default aesthetics for the whiskers. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{staple.colour, staple.color, staple.linetype, staple.linewidth}{Default aesthetics for the staples. Set to \code{NULL} to inherit from the +data's aesthetics. Note that staples don't appear unless the \code{staplewidth} +argument is set to a non-zero size.} + +\item{median.colour, median.color, median.linetype, median.linewidth}{Default aesthetics for the median line. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{box.colour, box.color, box.linetype, box.linewidth}{Default aesthetics for the boxes. Set to \code{NULL} to inherit from the +data's aesthetics.} \item{notch}{If \code{FALSE} (default) make a standard box plot. If \code{TRUE}, make a notched box plot. Notches are used to compare groups; @@ -145,7 +171,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -164,6 +192,10 @@ The boxplot compactly displays the distribution of a continuous variable. It visualises five summary statistics (the median, two hinges and two whiskers), and all "outlying" points individually. } +\note{ +In the unlikely event you specify both US and UK spellings of colour, +the US spelling will take precedence. +} \section{Orientation}{ This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. @@ -191,23 +223,24 @@ See McGill et al. (1978) for more details. \section{Aesthetics}{ -\code{geom_boxplot()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} -\item \strong{\code{lower} \emph{or} \code{xlower}} -\item \strong{\code{upper} \emph{or} \code{xupper}} -\item \strong{\code{middle} \emph{or} \code{xmiddle}} -\item \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} -\item \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{\link[=aes_linetype_size_shape]{shape}} -\item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{weight} +\code{geom_boxplot()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{lower} \emph{or} \code{xlower}} \tab \cr\cr +• \tab \strong{\code{upper} \emph{or} \code{xupper}} \tab \cr\cr +• \tab \strong{\code{middle} \emph{or} \code{xmiddle}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{shape}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr +• \tab \code{width} \tab → \code{0.9} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_contour.Rd b/man/geom_contour.Rd index d53e300a79..2336ec973f 100644 --- a/man/geom_contour.Rd +++ b/man/geom_contour.Rd @@ -89,7 +89,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -169,7 +169,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -202,54 +204,54 @@ using \code{\link[interp:interp]{interp::interp()}}, \code{\link[akima:bilinear] } \section{Aesthetics}{ -\code{geom_contour()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{weight} +\code{geom_contour()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{geom_contour_filled()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{subgroup} +\code{geom_contour_filled()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{subgroup} \tab → \code{NULL} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{stat_contour()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \strong{\code{z}} -\item \code{\link[=aes_group_order]{group}} -\item \code{order} +\code{stat_contour()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{z}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{order} \tab → \code{after_stat(level)} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{stat_contour_filled()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \strong{\code{z}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{order} +\code{stat_contour_filled()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{z}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → \code{after_stat(level)} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{order} \tab → \code{after_stat(level)} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_count.Rd b/man/geom_count.Rd index 370db388ed..753ec70728 100644 --- a/man/geom_count.Rd +++ b/man/geom_count.Rd @@ -96,7 +96,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -115,17 +117,17 @@ useful when you have discrete data and overplotting. } \section{Aesthetics}{ -\code{geom_point()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{shape}} -\item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{stroke} +\code{geom_point()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{shape}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr\cr +• \tab \code{stroke} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_density.Rd b/man/geom_density.Rd index cd119edcb3..1cb1b80b07 100644 --- a/man/geom_density.Rd +++ b/man/geom_density.Rd @@ -110,7 +110,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -167,17 +169,17 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_density()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{weight} +\code{geom_density()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -188,6 +190,7 @@ These are calculated by the 'stat' part of layers and can be accessed with \link \itemize{ \item \code{after_stat(density)}\cr density estimate. \item \code{after_stat(count)}\cr density * number of points - useful for stacked density plots. +\item \code{after_stat(wdensity)}\cr density * sum of weights. In absence of weights, the same as \code{count}. \item \code{after_stat(scaled)}\cr density estimate, scaled to maximum of 1. \item \code{after_stat(n)}\cr number of points. \item \code{after_stat(ndensity)}\cr alias for \code{scaled}, to mirror the syntax of \code{\link[=stat_bin]{stat_bin()}}. diff --git a/man/geom_density_2d.Rd b/man/geom_density_2d.Rd index 68f1353262..18e423d60e 100644 --- a/man/geom_density_2d.Rd +++ b/man/geom_density_2d.Rd @@ -138,7 +138,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -172,30 +174,30 @@ bands. } \section{Aesthetics}{ -\code{geom_density_2d()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_density_2d()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{geom_density_2d_filled()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{subgroup} +\code{geom_density_2d_filled()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{subgroup} \tab → \code{NULL} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_dotplot.Rd b/man/geom_dotplot.Rd index 1a57df3233..b8b68c2146 100644 --- a/man/geom_dotplot.Rd +++ b/man/geom_dotplot.Rd @@ -131,7 +131,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -158,17 +160,18 @@ to match the number of dots. } \section{Aesthetics}{ -\code{geom_dotplot()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{stroke} -\item \code{weight} +\code{geom_dotplot()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{stroke} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr +• \tab \code{width} \tab → \code{0.9} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_function.Rd b/man/geom_function.Rd index 529f552d11..be0a23541d 100644 --- a/man/geom_function.Rd +++ b/man/geom_function.Rd @@ -41,7 +41,7 @@ mapping.} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -100,7 +100,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -139,15 +141,15 @@ drawn (by default) with a line. } \section{Aesthetics}{ -\code{geom_function()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_function()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_hex.Rd b/man/geom_hex.Rd index 1876bf19fe..bbe58dd8f5 100644 --- a/man/geom_hex.Rd +++ b/man/geom_hex.Rd @@ -99,7 +99,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -110,11 +112,19 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \code{stat_bin_hex()}. For more information about overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} } \description{ Divides the plane into regular hexagons, counts the number of cases in @@ -124,16 +134,27 @@ the very regular alignment of \code{\link[=geom_bin_2d]{geom_bin_2d()}}. } \section{Aesthetics}{ -\code{geom_hex()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_hex()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. + + +\code{stat_binhex()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → \code{after_stat(count)} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -149,6 +170,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins} and \code{binwidth} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(carat, price)) d + geom_hex() diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index 7cd907daed..f0532d8b25 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -46,6 +46,7 @@ stat_bin( closed = c("right", "left"), pad = FALSE, na.rm = FALSE, + drop = "none", orientation = NA, show.legend = NA, inherit.aes = TRUE @@ -120,7 +121,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -128,10 +131,9 @@ that define both data and aesthetics and shouldn't inherit behaviour from the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \item{binwidth}{The width of the bins. Can be specified as a numeric value -or as a function that calculates width from unscaled x. Here, "unscaled x" -refers to the original x values in the data, before application of any -scale transformation. When specifying a function along with a grouping -structure, the function will be called once per group. +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. The default is to use the number of bins in \code{bins}, covering the range of the data. You should always override this value, exploring multiple widths to find the best to illustrate the @@ -164,13 +166,19 @@ outside the range of the data.} \item{breaks}{Alternatively, you can supply a numeric vector giving the bin boundaries. Overrides \code{binwidth}, \code{bins}, \code{center}, -and \code{boundary}.} +and \code{boundary}. Can also be a function that takes group-wise values as input and returns bin boundaries.} \item{closed}{One of \code{"right"} or \code{"left"} indicating whether right or left edges of bins are included in the bin.} \item{pad}{If \code{TRUE}, adds empty bins at either end of x. This ensures frequency polygons touch 0. Defaults to \code{FALSE}.} + +\item{drop}{Treatment of zero count bins. If \code{"none"} (default), such +bins are kept as-is. If \code{"all"}, all zero count bins are filtered out. +If \code{"extremes"} only zero count bins at the flanks are filtered out, but +not in the middle. \code{TRUE} is shorthand for \code{"all"} and \code{FALSE} is shorthand +for \code{"none"}.} } \description{ Visualise the distribution of a single continuous variable by dividing @@ -191,6 +199,12 @@ different number of bins. You can also experiment modifying the \code{binwidth} one change at a time. You may need to look at a few options to uncover the full story behind your data. +By default, the \emph{height} of the bars represent the counts within each bin. +However, there are situations where this behavior might produce misleading +plots (e.g., when non-equal-width bins are used), in which case it might be +preferable to have the \emph{area} of the bars represent the counts (by setting +\code{aes(y = after_stat(count / width))}). See example below. + In addition to \code{geom_histogram()}, you can create a histogram plot by using \code{scale_x_binned()} with \code{\link[=geom_bar]{geom_bar()}}. This method by default plots tick marks in between each bar. @@ -254,6 +268,18 @@ ggplot(diamonds, aes(price, colour = cut)) + ggplot(diamonds, aes(price, after_stat(density), colour = cut)) + geom_freqpoly(binwidth = 500) + +# When using the non-equal-width bins, we should set the area of the bars to +# represent the counts (not the height). +# Here we're using 10 equi-probable bins: +price_bins <- quantile(diamonds$price, probs = seq(0, 1, length = 11)) + +ggplot(diamonds, aes(price)) + + geom_histogram(breaks = price_bins, color = "black") # misleading (height = count) + +ggplot(diamonds, aes(price, after_stat(count / width))) + + geom_histogram(breaks = price_bins, color = "black") # area = count + if (require("ggplot2movies")) { # Often we don't want the height of the bar to represent the # count of observations, but the sum of some other variable. diff --git a/man/geom_jitter.Rd b/man/geom_jitter.Rd index 4ca3577792..afcb05e39e 100644 --- a/man/geom_jitter.Rd +++ b/man/geom_jitter.Rd @@ -40,7 +40,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -108,7 +108,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -123,17 +125,17 @@ overplotting caused by discreteness in smaller datasets. } \section{Aesthetics}{ -\code{geom_point()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{shape}} -\item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{stroke} +\code{geom_point()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{shape}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr\cr +• \tab \code{stroke} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 03eb82f896..e5208dce61 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -4,6 +4,7 @@ \name{geom_crossbar} \alias{geom_crossbar} \alias{geom_errorbar} +\alias{geom_errorbarh} \alias{geom_linerange} \alias{geom_pointrange} \title{Vertical intervals: lines, crossbars & errorbars} @@ -14,7 +15,15 @@ geom_crossbar( stat = "identity", position = "identity", ..., - fatten = 2.5, + 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, @@ -33,6 +42,18 @@ geom_errorbar( inherit.aes = TRUE ) +geom_errorbarh( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + orientation = "y", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) + geom_linerange( mapping = NULL, data = NULL, @@ -51,7 +72,7 @@ geom_pointrange( stat = "identity", position = "identity", ..., - fatten = 4, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -81,7 +102,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -133,9 +154,15 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{fatten}{A multiplicative factor used to increase the size of the -middle bar in \code{geom_crossbar()} and the middle point in -\code{geom_pointrange()}.} +\item{middle.colour, middle.color, middle.linetype, middle.linewidth}{Default aesthetics for the middle line. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{box.colour, box.color, box.linetype, box.linewidth}{Default aesthetics for the boxes. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{fatten}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A multiplicative factor +used to increase the size of the middle bar in \code{geom_crossbar()} and the +middle point in \code{geom_pointrange()}.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -149,7 +176,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -160,6 +189,10 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} Various ways of representing a vertical interval defined by \code{x}, \code{ymin} and \code{ymax}. Each case draws a single graphical object. } +\note{ +\code{geom_errorbarh()} is \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}. Use +\code{geom_errorbar(orientation = "y")} instead. +} \section{Orientation}{ This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. @@ -167,16 +200,16 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_linerange()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} -\item \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} -\item \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_linerange()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Note that \code{geom_pointrange()} also understands \code{size} for the size of the points. @@ -233,6 +266,5 @@ geom_errorbar( } \seealso{ \code{\link[=stat_summary]{stat_summary()}} for examples of these guys in use, -\code{\link[=geom_smooth]{geom_smooth()}} for continuous analogue, -\code{\link[=geom_errorbarh]{geom_errorbarh()}} for a horizontal error bar. +\code{\link[=geom_smooth]{geom_smooth()}} for continuous analogue } diff --git a/man/geom_map.Rd b/man/geom_map.Rd index f6aaf69dca..561a297161 100644 --- a/man/geom_map.Rd +++ b/man/geom_map.Rd @@ -38,7 +38,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -89,7 +89,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -105,16 +107,16 @@ it can be used in conjunction with \code{geom_sf()} layers and/or } \section{Aesthetics}{ -\code{geom_map()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{map_id}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{subgroup} +\code{geom_map()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{map_id}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{subgroup} \tab → \code{NULL} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -124,7 +126,7 @@ Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. # how `geom_map()` works. It requires two data frames: # One contains the coordinates of each polygon (`positions`), and is # provided via the `map` argument. The other contains the -# other the values associated with each polygon (`values`). An id +# values associated with each polygon (`values`). An id # variable links the two together. ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3")) diff --git a/man/geom_path.Rd b/man/geom_path.Rd index 4a59e4a081..6d0f30ec8d 100644 --- a/man/geom_path.Rd +++ b/man/geom_path.Rd @@ -16,6 +16,7 @@ geom_path( linejoin = "round", linemitre = 10, arrow = NULL, + arrow.fill = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -40,6 +41,7 @@ geom_step( position = "identity", direction = "hv", na.rm = FALSE, + orientation = NA, show.legend = NA, inherit.aes = TRUE, ... @@ -68,7 +70,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -128,6 +130,9 @@ lists which parameters it can accept. \item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}.} +\item{arrow.fill}{fill colour to use for the arrow head (if closed). \code{NULL} +means use \code{colour} aesthetic.} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -135,7 +140,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -169,15 +176,15 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_path()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_path()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -198,8 +205,9 @@ the \code{NA} is removed silently, without warning. \examples{ # geom_line() is suitable for time series ggplot(economics, aes(date, unemploy)) + geom_line() +# separate by colour and use "timeseries" legend key glyph ggplot(economics_long, aes(date, value01, colour = variable)) + - geom_line() + geom_line(key_glyph = "timeseries") # You can get a timeseries that run vertically by setting the orientation ggplot(economics, aes(unemploy, date)) + geom_line(orientation = "y") diff --git a/man/geom_point.Rd b/man/geom_point.Rd index 88e06e22aa..ea7975762d 100644 --- a/man/geom_point.Rd +++ b/man/geom_point.Rd @@ -38,7 +38,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -97,7 +97,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -136,18 +138,20 @@ Another technique is to make the points transparent (e.g. \section{Aesthetics}{ -\code{geom_point()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{shape}} -\item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{stroke} +\code{geom_point()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{shape}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr\cr +• \tab \code{stroke} \tab → via \code{theme()} \cr\cr } +The \code{fill} aesthetic only applies to shapes 21-25. + Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -178,6 +182,13 @@ d + geom_point(alpha = 1/100) ggplot(mtcars, aes(wt, mpg)) + geom_point(shape = 21, colour = "black", fill = "white", size = 5, stroke = 5) +# The default shape in legends is not filled, but you can override the shape +# in the guide to reflect the fill in the legend +ggplot(mtcars, aes(wt, mpg, fill = factor(carb), shape = factor(cyl))) + + geom_point(size = 5, stroke = 1) + + scale_shape_manual(values = 21:25) + + scale_fill_ordinal(guide = guide_legend(override.aes = list(shape = 21))) + \donttest{ # You can create interesting shapes by layering multiple points of # different sizes diff --git a/man/geom_polygon.Rd b/man/geom_polygon.Rd index 5e69742056..1c76e21995 100644 --- a/man/geom_polygon.Rd +++ b/man/geom_polygon.Rd @@ -39,7 +39,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -103,7 +103,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -121,17 +123,17 @@ polygon. } \section{Aesthetics}{ -\code{geom_polygon()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{subgroup} +\code{geom_polygon()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{subgroup} \tab → \code{NULL} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_qq.Rd b/man/geom_qq.Rd index 62ff813561..7915f29e47 100644 --- a/man/geom_qq.Rd +++ b/man/geom_qq.Rd @@ -10,7 +10,7 @@ geom_qq_line( mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, @@ -25,7 +25,7 @@ geom_qq_line( stat_qq_line( mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, @@ -156,7 +156,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -170,22 +172,22 @@ points at specified quartiles of the theoretical and sample distributions. } \section{Aesthetics}{ -\code{stat_qq()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{sample}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_position]{x}} -\item \code{\link[=aes_position]{y}} +\code{stat_qq()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{sample}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_position]{x}} \tab → \code{after_stat(theoretical)} \cr\cr +• \tab \code{\link[=aes_position]{y}} \tab → \code{after_stat(sample)} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. -\code{stat_qq_line()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{sample}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_position]{x}} -\item \code{\link[=aes_position]{y}} +\code{stat_qq_line()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{sample}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_position]{x}} \tab → \code{after_stat(x)} \cr\cr +• \tab \code{\link[=aes_position]{y}} \tab → \code{after_stat(y)} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -203,6 +205,8 @@ Variables computed by \code{stat_qq_line()}: \itemize{ \item \code{after_stat(x)}\cr x-coordinates of the endpoints of the line segment connecting the points at the chosen quantiles of the theoretical and the sample distributions. \item \code{after_stat(y)}\cr y-coordinates of the endpoints. +\item \code{after_stat(slope)}\cr Amount of change in \code{y} across 1 unit of \code{x}. +\item \code{after_stat(intercept)}\cr Value of \code{y} at \code{x == 0}. } } @@ -212,8 +216,12 @@ df <- data.frame(y = rt(200, df = 5)) p <- ggplot(df, aes(sample = y)) p + stat_qq() + stat_qq_line() -# Use fitdistr from MASS to estimate distribution params -params <- as.list(MASS::fitdistr(df$y, "t")$estimate) +# Use fitdistr from MASS to estimate distribution params: +# if (requireNamespace("MASS", quietly = TRUE)) { +# params <- as.list(MASS::fitdistr(df$y, "t")$estimate) +# } +# Here, we use pre-computed params +params <- list(m = -0.02505057194115, s = 1.122568610124, df = 6.63842653897) ggplot(df, aes(sample = y)) + stat_qq(distribution = qt, dparams = params["df"]) + stat_qq_line(distribution = qt, dparams = params["df"]) diff --git a/man/geom_quantile.Rd b/man/geom_quantile.Rd index a3aa6ac3c0..495e6b22cd 100644 --- a/man/geom_quantile.Rd +++ b/man/geom_quantile.Rd @@ -109,7 +109,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -137,16 +139,16 @@ with lines. This is as a continuous analogue to \code{\link[=geom_boxplot]{geom_ } \section{Aesthetics}{ -\code{geom_quantile()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{weight} +\code{geom_quantile()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_ribbon.Rd b/man/geom_ribbon.Rd index 418c759f8c..256e821e6b 100644 --- a/man/geom_ribbon.Rd +++ b/man/geom_ribbon.Rd @@ -66,7 +66,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -130,7 +130,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -178,17 +180,17 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_ribbon()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} -\item \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} -\item \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_ribbon()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{xmin}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{ymax}} \emph{or} \code{\link[=aes_position]{xmax}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_rug.Rd b/man/geom_rug.Rd index db5b200b76..e77826c7e9 100644 --- a/man/geom_rug.Rd +++ b/man/geom_rug.Rd @@ -41,7 +41,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -108,7 +108,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -128,15 +130,15 @@ any data points under the default settings. } \section{Aesthetics}{ -\code{geom_rug()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{\link[=aes_position]{x}} -\item \code{\link[=aes_position]{y}} +\code{geom_rug()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_position]{x}} \tab \cr\cr +• \tab \code{\link[=aes_position]{y}} \tab \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -168,7 +170,7 @@ p + p + geom_rug(outside = TRUE, sides = "tr") + coord_cartesian(clip = "off") + - theme(plot.margin = margin(1, 1, 1, 1, "cm")) + theme(plot.margin = margin_auto(1, unit = "cm")) # increase the line length and # expand axis to avoid overplotting diff --git a/man/geom_segment.Rd b/man/geom_segment.Rd index 05ecf827e8..8cddae4dc2 100644 --- a/man/geom_segment.Rd +++ b/man/geom_segment.Rd @@ -60,7 +60,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -128,7 +128,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -160,16 +162,16 @@ need to connect points across multiple cases. } \section{Aesthetics}{ -\code{geom_segment()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \strong{\code{\link[=aes_position]{xend}} \emph{or} \code{\link[=aes_position]{yend}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_segment()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{xend}} \emph{or} \code{\link[=aes_position]{yend}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_smooth.Rd b/man/geom_smooth.Rd index ece17611a4..4a02999e73 100644 --- a/man/geom_smooth.Rd +++ b/man/geom_smooth.Rd @@ -125,7 +125,7 @@ model that \code{method = NULL} would use, then set \code{method = NULL} implies \code{formula = y ~ x} when there are fewer than 1,000 observations and \code{formula = y ~ s(x, bs = "cs")} otherwise.} -\item{se}{Display confidence interval around smooth? (\code{TRUE} by default, see +\item{se}{Display confidence band around smooth? (\code{TRUE} by default, see \code{level} to control.)} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with @@ -140,7 +140,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -168,7 +170,7 @@ created by \code{expansion}.} When \code{NULL} (default), \code{xseq} is internally evaluated as a sequence of \code{n} equally spaced points for continuous data.} -\item{level}{Level of confidence interval to use (0.95 by default).} +\item{level}{Level of confidence band to use (0.95 by default).} \item{method.args}{List of additional arguments passed on to the modelling function defined by \code{method}.} @@ -184,7 +186,7 @@ Calculation is performed by the (currently undocumented) \code{predictdf()} generic and its methods. For most methods the standard error bounds are computed using the \code{\link[=predict]{predict()}} method -- the exceptions are \code{loess()}, which uses a t-based approximation, and -\code{glm()}, where the normal confidence interval is constructed on the link +\code{glm()}, where the normal confidence band is constructed on the link scale and then back-transformed to the response scale. } \section{Orientation}{ @@ -194,19 +196,19 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_smooth()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{weight} -\item \code{\link[=aes_position]{ymax}} -\item \code{\link[=aes_position]{ymin}} +\code{geom_smooth()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{0.4} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr +• \tab \code{\link[=aes_position]{ymax}} \tab \cr\cr +• \tab \code{\link[=aes_position]{ymin}} \tab \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -216,8 +218,8 @@ Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. These are calculated by the 'stat' part of layers and can be accessed with \link[=aes_eval]{delayed evaluation}. \code{stat_smooth()} provides the following variables, some of which depend on the orientation: \itemize{ \item \code{after_stat(y)} \emph{or} \code{after_stat(x)}\cr Predicted value. -\item \code{after_stat(ymin)} \emph{or} \code{after_stat(xmin)}\cr Lower pointwise confidence interval around the mean. -\item \code{after_stat(ymax)} \emph{or} \code{after_stat(xmax)}\cr Upper pointwise confidence interval around the mean. +\item \code{after_stat(ymin)} \emph{or} \code{after_stat(xmin)}\cr Lower pointwise confidence band around the mean. +\item \code{after_stat(ymax)} \emph{or} \code{after_stat(xmax)}\cr Upper pointwise confidence band around the mean. \item \code{after_stat(se)}\cr Standard error. } } diff --git a/man/geom_spoke.Rd b/man/geom_spoke.Rd index 216686f8ec..ffebfbe589 100644 --- a/man/geom_spoke.Rd +++ b/man/geom_spoke.Rd @@ -39,7 +39,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -98,7 +98,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -112,17 +114,17 @@ The angles start from east and increase counterclockwise. } \section{Aesthetics}{ -\code{geom_spoke()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \strong{\code{angle}} -\item \strong{\code{radius}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{geom_spoke()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{angle}} \tab \cr\cr +• \tab \strong{\code{radius}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_text.Rd b/man/geom_text.Rd index 9c64a258d5..4293217066 100644 --- a/man/geom_text.Rd +++ b/man/geom_text.Rd @@ -9,14 +9,16 @@ geom_label( mapping = NULL, data = NULL, stat = "identity", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, label.padding = unit(0.25, "lines"), label.r = unit(0.15, "lines"), - label.size = 0.25, + label.size = deprecated(), + border.colour = NULL, + border.color = NULL, + text.colour = NULL, + text.color = NULL, size.unit = "mm", na.rm = FALSE, show.legend = NA, @@ -27,11 +29,9 @@ geom_text( mapping = NULL, data = NULL, stat = "identity", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, size.unit = "mm", na.rm = FALSE, @@ -62,7 +62,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -73,13 +73,13 @@ give the stat as \code{"count"}. \link[=layer_stats]{layer stat} documentation. }} -\item{position}{A position adjustment to use on the data for this layer. -Cannot be jointy specified with \code{nudge_x} or \code{nudge_y}. This +\item{position}{A position adjustment to use on the data for this layer. This can be used in various ways, including to prevent overplotting and improving the display. The \code{position} argument accepts the following: \itemize{ \item The result of calling a position function, such as \code{position_jitter()}. -\item A string nameing the position adjustment. To give the position as a +This method allows for passing extra arguments to the position. +\item A string naming the position adjustment. To give the position as a string, strip the function name of the \code{position_} prefix. For example, to use \code{position_jitter()}, give the position as \code{"jitter"}. \item For more information and other ways to specify the position, see the @@ -117,15 +117,20 @@ lists which parameters it can accept. \item{parse}{If \code{TRUE}, the labels will be parsed into expressions and displayed as described in \code{?plotmath}.} -\item{nudge_x, nudge_y}{Horizontal and vertical adjustment to nudge labels by. -Useful for offsetting text from points, particularly on discrete scales. -Cannot be jointly specified with \code{position}.} - \item{label.padding}{Amount of padding around label. Defaults to 0.25 lines.} \item{label.r}{Radius of rounded corners. Defaults to 0.15 lines.} -\item{label.size}{Size of label border, in mm.} +\item{label.size}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Replaced by the +\code{linewidth} aesthetic. Size of label border, in mm.} + +\item{border.colour, border.color}{Colour of label border. When \code{NULL} +(default), the \code{colour} aesthetic determines the colour of the label border. +\code{border.color} is an alias for \code{border.colour}.} + +\item{text.colour, text.color}{Colour of the text. When \code{NULL} (default), the +\code{colour} aesthetic determines the colour of the text. \code{text.color} is an +alias for \code{text.colour}.} \item{size.unit}{How the \code{size} aesthetic is interpreted: as millimetres (\code{"mm"}, default), points (\code{"pt"}), centimetres (\code{"cm"}), inches (\code{"in"}), @@ -138,7 +143,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -178,21 +185,21 @@ package. } \section{Aesthetics}{ -\code{geom_text()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \strong{\code{label}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{angle} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{family} -\item \code{fontface} -\item \code{\link[=aes_group_order]{group}} -\item \code{hjust} -\item \code{lineheight} -\item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{vjust} +\code{geom_text()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \strong{\code{label}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{angle} \tab → \code{0} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{family} \tab → via \code{theme()} \cr\cr +• \tab \code{fontface} \tab → \code{1} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{hjust} \tab → \code{0.5} \cr\cr +• \tab \code{lineheight} \tab → \code{1.2} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr\cr +• \tab \code{vjust} \tab → \code{0.5} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -207,8 +214,8 @@ the background colour of the label. \section{Alignment}{ You can modify text alignment with the \code{vjust} and \code{hjust} -aesthetics. These can either be a number between 0 (right/bottom) and -1 (top/left) or a character (\code{"left"}, \code{"middle"}, \code{"right"}, \code{"bottom"}, +aesthetics. These can either be a number between 0 (left/bottom) and +1 (right/top) or a character (\code{"left"}, \code{"middle"}, \code{"right"}, \code{"bottom"}, \code{"center"}, \code{"top"}). There are two special alignments: \code{"inward"} and \code{"outward"}. Inward always aligns text towards the center, and outward aligns it away from the center. @@ -244,13 +251,14 @@ p + # Add aesthetic mappings p + geom_text(aes(colour = factor(cyl))) p + geom_text(aes(colour = factor(cyl))) + - scale_colour_discrete(l = 40) + scale_colour_hue(l = 40) p + geom_label(aes(fill = factor(cyl)), colour = "white", fontface = "bold") -p + geom_text(aes(size = wt)) +# Scale size of text, and change legend key glyph from a to point +p + geom_text(aes(size = wt), key_glyph = "point") # Scale height of text, rather than sqrt(height) p + - geom_text(aes(size = wt)) + + geom_text(aes(size = wt), key_glyph = "point") + scale_radius(range = c(3,6)) # You can display expressions by setting parse = TRUE. The diff --git a/man/geom_tile.Rd b/man/geom_tile.Rd index a45ca07008..d0638772b5 100644 --- a/man/geom_tile.Rd +++ b/man/geom_tile.Rd @@ -67,7 +67,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -133,7 +133,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -144,35 +146,31 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} } \description{ \code{geom_rect()} and \code{geom_tile()} do the same thing, but are -parameterised differently: \code{geom_rect()} uses the locations of the four -corners (\code{xmin}, \code{xmax}, \code{ymin} and \code{ymax}), while -\code{geom_tile()} uses the center of the tile and its size (\code{x}, -\code{y}, \code{width}, \code{height}). \code{geom_raster()} is a high -performance special case for when all the tiles are the same size, and no -pattern fills are applied. +parameterised differently: \code{geom_tile()} uses the center of the tile and its +size (\code{x}, \code{y}, \code{width}, \code{height}), while \code{geom_rect()} can use those or the +locations of the corners (\code{xmin}, \code{xmax}, \code{ymin} and \code{ymax}). +\code{geom_raster()} is a high performance special case for when all the tiles +are the same size, and no pattern fills are applied. } \details{ -\code{geom_rect()} and \code{geom_tile()}'s respond differently to scale -transformations due to their parameterisation. In \code{geom_rect()}, the scale -transformation is applied to the corners of the rectangles. In \code{geom_tile()}, -the transformation is applied only to the centres and its size is determined -after transformation. +Please note that the \code{width} and \code{height} aesthetics are not true position +aesthetics and therefore are not subject to scale transformation. It is +only after transformation that these aesthetics are applied. } \section{Aesthetics}{ -\code{geom_tile()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{height} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{width} +\code{geom_rect()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{width} \emph{or} \code{\link[=aes_position]{xmin}} \emph{or} \code{\link[=aes_position]{xmax}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}} \emph{or} \code{height} \emph{or} \code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{ymax}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr } +\code{geom_tile()} understands only the \code{x}/\code{width} and \code{y}/\code{height} combinations. Note that \code{geom_raster()} ignores \code{colour}. Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 4041d770c7..590ebface6 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -11,9 +11,13 @@ geom_violin( stat = "ydensity", position = "dodge", ..., - draw_quantiles = NULL, 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, @@ -27,6 +31,7 @@ stat_ydensity( geom = "violin", position = "dodge", ..., + quantiles = c(0.25, 0.5, 0.75), bw = "nrd0", adjust = 1, kernel = "gaussian", @@ -102,9 +107,6 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{draw_quantiles}{If \code{not(NULL)} (default), draw horizontal lines -at the given quantiles of the density estimate.} - \item{trim}{If \code{TRUE} (default), trim the tails of the violins to the range of the data. If \code{FALSE}, don't trim the tails.} @@ -114,6 +116,13 @@ finite, boundary effect of default density estimation will be corrected by reflecting tails outside \code{bounds} around their closest edge. Data points outside of bounds are removed with a warning.} +\item{quantile.colour, quantile.color, quantile.linewidth, quantile.linetype}{Default aesthetics for the quantile lines. Set to \code{NULL} to inherit from +the data's aesthetics. By default, quantile lines are hidden and can be +turned on by changing \code{quantile.linetype}.} + +\item{draw_quantiles}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Previous +specification of drawing quantiles.} + \item{scale}{if "area" (default), all violins have the same area (before trimming the tails). If "count", areas are scaled proportionally to the number of observations. If "width", all violins have the same maximum width.} @@ -130,7 +139,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -142,6 +153,9 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} +\item{quantiles}{If not \code{NULL} (default), compute the \code{quantile} variable +and draw horizontal lines at the given quantiles in \code{geom_violin()}.} + \item{bw}{The smoothing bandwidth to be used. If numeric, the standard deviation of the smoothing kernel. If character, a rule to choose the bandwidth, as listed in @@ -171,17 +185,18 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{geom_violin()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_colour_fill_alpha]{fill}} -\item \code{\link[=aes_group_order]{group}} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{weight} +\code{geom_violin()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linetype}} \tab → via \code{theme()} \cr\cr +• \tab \code{\link[=aes_linetype_size_shape]{linewidth}} \tab → via \code{theme()} \cr\cr +• \tab \code{weight} \tab → \code{1} \cr\cr +• \tab \code{width} \tab → \code{0.9} \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } @@ -196,6 +211,7 @@ These are calculated by the 'stat' part of layers and can be accessed with \link \item \code{after_stat(violinwidth)}\cr Density scaled for the violin plot, according to area, counts or to a constant maximum width. \item \code{after_stat(n)}\cr Number of points. \item \code{after_stat(width)}\cr Width of violin bounding box. +\item \code{after_stat(quantile)}\cr Whether the row is part of the \code{quantiles} computation. } } diff --git a/man/get_alt_text.Rd b/man/get_alt_text.Rd index b0da28a783..c9f6bdeb1e 100644 --- a/man/get_alt_text.Rd +++ b/man/get_alt_text.Rd @@ -10,7 +10,7 @@ get_alt_text(p, ...) \arguments{ \item{p}{a ggplot object} -\item{...}{Currently ignored} +\item{...}{Arguments passed to methods.} } \value{ A text string diff --git a/man/get_geom_defaults.Rd b/man/get_geom_defaults.Rd index bd538eeda0..ae1a7e5b63 100644 --- a/man/get_geom_defaults.Rd +++ b/man/get_geom_defaults.Rd @@ -4,7 +4,7 @@ \alias{get_geom_defaults} \title{Resolve and get geom defaults} \usage{ -get_geom_defaults(geom, theme = theme_get()) +get_geom_defaults(geom, theme = get_theme()) } \arguments{ \item{geom}{Some definition of a geom: @@ -36,5 +36,8 @@ get_geom_defaults("density_2d") # Using a class get_geom_defaults(GeomPoint) + +# Changed theme +get_geom_defaults("point", theme(geom = element_geom(ink = "purple"))) } \keyword{internal} diff --git a/man/get_guide_data.Rd b/man/get_guide_data.Rd index ece14cf284..5b15ad2b50 100644 --- a/man/get_guide_data.Rd +++ b/man/get_guide_data.Rd @@ -4,7 +4,7 @@ \alias{get_guide_data} \title{Extract tick information from guides} \usage{ -get_guide_data(plot = last_plot(), aesthetic, panel = 1L) +get_guide_data(plot = get_last_plot(), aesthetic, panel = 1L) } \arguments{ \item{plot}{A \code{ggplot} or \code{ggplot_build} object.} diff --git a/man/last_plot.Rd b/man/get_last_plot.Rd similarity index 84% rename from man/last_plot.Rd rename to man/get_last_plot.Rd index 6d47629391..0da1c83a54 100644 --- a/man/last_plot.Rd +++ b/man/get_last_plot.Rd @@ -1,9 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot-last.R -\name{last_plot} +\name{get_last_plot} +\alias{get_last_plot} \alias{last_plot} \title{Retrieve the last plot to be modified or created.} \usage{ +get_last_plot() + last_plot() } \description{ diff --git a/man/get_strip_labels.Rd b/man/get_strip_labels.Rd new file mode 100644 index 0000000000..10c3c3c01b --- /dev/null +++ b/man/get_strip_labels.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/facet-.R +\name{get_strip_labels} +\alias{get_strip_labels} +\title{Accessing a plot's facet strip labels} +\usage{ +get_strip_labels(plot = get_last_plot()) +} +\arguments{ +\item{plot}{A ggplot or build ggplot object.} +} +\value{ +\code{NULL} if there are no labels, otherwise a list of data.frames +containing the labels. +} +\description{ +This functions retrieves labels from facet strips with the labeller applied. +} +\examples{ +# Basic plot +p <- ggplot(mpg, aes(displ, hwy)) + + geom_point() + +get_strip_labels(p) # empty facets +get_strip_labels(p + facet_wrap(year ~ cyl)) +get_strip_labels(p + facet_grid(year ~ cyl)) +} +\keyword{internal} diff --git a/man/theme_get.Rd b/man/get_theme.Rd similarity index 60% rename from man/theme_get.Rd rename to man/get_theme.Rd index 2246f1146b..d3283d0e67 100644 --- a/man/theme_get.Rd +++ b/man/get_theme.Rd @@ -1,19 +1,31 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/theme-current.R -\name{theme_get} +\name{get_theme} +\alias{get_theme} \alias{theme_get} +\alias{set_theme} \alias{theme_set} +\alias{update_theme} \alias{theme_update} +\alias{replace_theme} \alias{theme_replace} \alias{\%+replace\%} \title{Get, set, and modify the active theme} \usage{ +get_theme() + theme_get() +set_theme(new) + theme_set(new) +update_theme(...) + theme_update(...) +replace_theme(...) + theme_replace(...) e1 \%+replace\% e2 @@ -26,14 +38,14 @@ e1 \%+replace\% e2 \item{e1, e2}{Theme and element to combine} } \value{ -\code{theme_set()}, \code{theme_update()}, and \code{theme_replace()} +\code{set_theme()}, \code{update_theme()}, and \code{replace_theme()} invisibly return the previous theme so you can easily save it, then later restore it. } \description{ The current/active theme (see \code{\link[=theme]{theme()}}) is automatically applied to every -plot you draw. Use \code{theme_get()} to get the current theme, and \code{theme_set()} to -completely override it. \code{theme_update()} and \code{theme_replace()} are shorthands for +plot you draw. Use \code{get_theme()} to get the current theme, and \code{set_theme()} to +completely override it. \code{update_theme()} and \code{replace_theme()} are shorthands for changing individual elements. } \section{Adding on to a theme}{ @@ -42,26 +54,26 @@ changing individual elements. \code{+} and \verb{\%+replace\%} can be used to modify elements in themes. \code{+} updates the elements of e1 that differ from elements specified (not -NULL) in e2. Thus this operator can be used to incrementally add or modify +\code{NULL}) in e2. Thus this operator can be used to incrementally add or modify attributes of a ggplot theme. In contrast, \verb{\%+replace\%} replaces the entire element; any element of a theme not specified in e2 will not be present in the resulting theme (i.e. -NULL). Thus this operator can be used to overwrite an entire theme. +\code{NULL}). Thus this operator can be used to overwrite an entire theme. -\code{theme_update()} uses the \code{+} operator, so that any unspecified values in the +\code{update_theme()} uses the \code{+} operator, so that any unspecified values in the theme element will default to the values they are set in the theme. -\code{theme_replace()} uses \verb{\%+replace\%} to completely replace the element, so any +\code{replace_theme()} uses \verb{\%+replace\%} to completely replace the element, so any unspecified values will overwrite the current value in the theme with \code{NULL}. -In summary, the main differences between \code{theme_set()}, \code{theme_update()}, -and \code{theme_replace()} are: +In summary, the main differences between \code{set_theme()}, \code{update_theme()}, +and \code{replace_theme()} are: \itemize{ -\item \code{theme_set()} completely overrides the current theme. -\item \code{theme_update()} modifies a particular element of the current theme +\item \code{set_theme()} completely overrides the current theme. +\item \code{update_theme()} modifies a particular element of the current theme using the \code{+} operator. -\item \code{theme_replace()} modifies a particular element of the current theme +\item \code{replace_theme()} modifies a particular element of the current theme using the \verb{\%+replace\%} operator. } } @@ -71,25 +83,25 @@ p <- ggplot(mtcars, aes(mpg, wt)) + geom_point() p -# Use theme_set() to completely override the current theme. -# theme_update() and theme_replace() are similar except they +# Use set_theme() to completely override the current theme. +# update_theme() and replace_theme() are similar except they # apply directly to the current/active theme. -# theme_update() modifies a particular element of the current theme. +# update_theme() modifies a particular element of the current theme. # Here we have the old theme so we can later restore it. # Note that the theme is applied when the plot is drawn, not # when it is created. -old <- theme_set(theme_bw()) +old <- set_theme(theme_bw()) p -theme_set(old) -theme_update(panel.grid.minor = element_line(colour = "red")) +set_theme(old) +update_theme(panel.grid.minor = element_line(colour = "red")) p -theme_set(old) -theme_replace(panel.grid.minor = element_line(colour = "red")) +set_theme(old) +replace_theme(panel.grid.minor = element_line(colour = "red")) p -theme_set(old) +set_theme(old) p diff --git a/man/gg_par.Rd b/man/gg_par.Rd new file mode 100644 index 0000000000..90594cdb3e --- /dev/null +++ b/man/gg_par.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities-grid.R +\name{gg_par} +\alias{gg_par} +\title{Interpreter for graphical parameters} +\usage{ +gg_par(..., stroke = NULL, pointsize = NULL) +} +\arguments{ +\item{...}{Named arguments passed on to \code{gpar()}.} + +\item{stroke}{Linewidth for points. Populates the \code{lwd} grid parameter.} + +\item{pointsize}{Size for points. Populates the \code{fontsize} grid parameter.} +} +\value{ +An object of class 'gpar'. +} +\description{ +This is a wrapper for \code{\link[grid:gpar]{grid::gpar()}} that applies ggplot2's interpretation +of graphical parameters. +} +\keyword{internal} diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index f0d0caf12d..9ba1fdfdce 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -5,28 +5,28 @@ % R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, R/coord-map.R, % R/coord-polar.R, R/coord-quickmap.R, R/coord-radial.R, R/coord-transform.R, % R/facet-.R, R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, -% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-blank.R, -% R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.R, -% R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, R/geom-ribbon.R, -% R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, R/geom-errorbar.R, -% R/geom-errorbarh.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, +% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, R/geom-bin2d.R, +% R/geom-blank.R, R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, +% R/geom-contour.R, R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, +% R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, +% R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, % R/geom-label.R, R/geom-linerange.R, R/geom-point.R, R/geom-pointrange.R, % R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, R/geom-spoke.R, -% R/geom-text.R, R/geom-tile.R, R/geom-violin.R, R/geom-vline.R, -% R/guide-.R, R/guide-axis.R, R/guide-axis-logticks.R, R/guide-axis-stack.R, -% R/guide-axis-theta.R, R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, -% R/guide-colorsteps.R, R/guide-custom.R, R/guide-none.R, R/guide-old.R, -% R/layout.R, R/position-.R, R/position-dodge.R, R/position-dodge2.R, -% R/position-identity.R, R/position-jitter.R, R/position-jitterdodge.R, -% R/position-nudge.R, R/position-stack.R, R/scale-.R, R/scale-binned.R, -% R/scale-continuous.R, R/scale-date.R, R/scale-discrete-.R, -% R/scale-identity.R, R/stat-align.R, R/stat-bin.R, R/stat-bin2d.R, -% R/stat-bindot.R, R/stat-binhex.R, R/stat-boxplot.R, R/stat-contour.R, +% R/geom-text.R, R/geom-violin.R, R/geom-vline.R, R/guide-.R, R/guide-axis.R, +% R/guide-axis-logticks.R, R/guide-axis-stack.R, R/guide-axis-theta.R, +% R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, R/guide-colorsteps.R, +% R/guide-custom.R, R/guide-none.R, R/guide-old.R, R/layout.R, R/position-.R, +% R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, +% R/position-jitter.R, R/position-jitterdodge.R, R/position-nudge.R, +% R/position-stack.R, R/scale-.R, R/scale-binned.R, R/scale-continuous.R, +% R/scale-date.R, R/scale-discrete-.R, R/scale-identity.R, R/stat-align.R, +% R/stat-bin.R, R/stat-summary-2d.R, R/stat-bin2d.R, R/stat-bindot.R, +% R/stat-binhex.R, R/stat-boxplot.R, R/stat-connect.R, R/stat-contour.R, % R/stat-count.R, R/stat-density-2d.R, R/stat-density.R, R/stat-ecdf.R, -% R/stat-ellipse.R, R/stat-function.R, R/stat-identity.R, R/stat-qq-line.R, -% R/stat-qq.R, R/stat-quantilemethods.R, R/stat-smooth.R, R/stat-sum.R, -% R/stat-summary-2d.R, R/stat-summary-bin.R, R/stat-summary-hex.R, -% R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R +% R/stat-ellipse.R, R/stat-function.R, R/stat-identity.R, R/stat-manual.R, +% R/stat-qq-line.R, R/stat-qq.R, R/stat-quantilemethods.R, R/stat-smooth.R, +% R/stat-sum.R, R/stat-summary-bin.R, R/stat-summary-hex.R, R/stat-summary.R, +% R/stat-unique.R, R/stat-ydensity.R \docType{data} \name{ggplot2-ggproto} \alias{ggplot2-ggproto} @@ -56,6 +56,8 @@ \alias{GeomAbline} \alias{GeomRect} \alias{GeomBar} +\alias{GeomTile} +\alias{GeomBin2d} \alias{GeomBlank} \alias{GeomBoxplot} \alias{GeomCol} @@ -87,7 +89,6 @@ \alias{GeomSmooth} \alias{GeomSpoke} \alias{GeomText} -\alias{GeomTile} \alias{GeomViolin} \alias{GeomVline} \alias{Guide} @@ -125,10 +126,12 @@ \alias{ScaleContinuousIdentity} \alias{StatAlign} \alias{StatBin} +\alias{StatSummary2d} \alias{StatBin2d} \alias{StatBindot} \alias{StatBinhex} \alias{StatBoxplot} +\alias{StatConnect} \alias{StatContour} \alias{StatContourFilled} \alias{StatCount} @@ -139,12 +142,12 @@ \alias{StatEllipse} \alias{StatFunction} \alias{StatIdentity} +\alias{StatManual} \alias{StatQqLine} \alias{StatQq} \alias{StatQuantile} \alias{StatSmooth} \alias{StatSum} -\alias{StatSummary2d} \alias{StatSummaryBin} \alias{StatSummaryHex} \alias{StatSummary} @@ -306,6 +309,8 @@ In addition to the methods described above, it is also possible to override the default behaviour of one or more of the following methods: \itemize{ \item \code{setup_params}: +\item \code{setup_panel_params}: modifies the x and y ranges for each panel. This is +used to allow the \code{Facet} to interact with the \code{panel_params}. \item \code{init_scales}: Given a master scale for x and y, create panel specific scales for each panel defined in the layout. The default is to simply clone the master scale. diff --git a/man/ggplot_add.Rd b/man/ggplot_add.Rd index 0bd2e2a698..c71d6f863e 100644 --- a/man/ggplot_add.Rd +++ b/man/ggplot_add.Rd @@ -20,4 +20,29 @@ A modified ggplot object This generic allows you to add your own methods for adding custom objects to a ggplot with \link{+.gg}. } +\details{ +Custom methods for \code{ggplot_add()} are intended to update the \code{plot} variable +using information from a custom \code{object}. This can become convenient when +writing extensions that don't build on the pre-existing grammar like +layers, facets, coords and themes. The \code{ggplot_add()} function is never +intended to be used directly, but it is triggered when an object is added +to a plot via the \code{+} operator. Please note that the full \code{plot} object is +exposed at this point, which comes with the responsibility of returning +the plot intact. +} +\examples{ +# making a new method for the generic +# in this example, we apply a text element to the text theme setting +ggplot_add.element_text <- function(object, plot, object_name) { + plot + theme(text = object) +} + +# we can now use `+` to add our object to a plot +ggplot(mpg, aes(displ, cty)) + + geom_point() + + element_text(colour = "red") + +# clean-up +rm(ggplot_add.element_text) +} \keyword{internal} diff --git a/man/ggplot_build.Rd b/man/ggplot_build.Rd index 0c03c1c0b4..239677f6ce 100644 --- a/man/ggplot_build.Rd +++ b/man/ggplot_build.Rd @@ -2,27 +2,36 @@ % Please edit documentation in R/plot-build.R \name{ggplot_build} \alias{ggplot_build} +\alias{get_layer_data} \alias{layer_data} +\alias{get_panel_scales} \alias{layer_scales} +\alias{get_layer_grob} \alias{layer_grob} \title{Build ggplot for rendering.} \usage{ ggplot_build(plot) -layer_data(plot = last_plot(), i = 1L) +get_layer_data(plot = get_last_plot(), i = 1L) -layer_scales(plot = last_plot(), i = 1L, j = 1L) +layer_data(plot = get_last_plot(), i = 1L) -layer_grob(plot = last_plot(), i = 1L) +get_panel_scales(plot = get_last_plot(), i = 1L, j = 1L) + +layer_scales(plot = get_last_plot(), i = 1L, j = 1L) + +get_layer_grob(plot = get_last_plot(), i = 1L) + +layer_grob(plot = get_last_plot(), i = 1L) } \arguments{ \item{plot}{ggplot object} -\item{i}{An integer. In \code{layer_data()}, the data to return (in the order added to the -plot). In \code{layer_grob()}, the grob to return (in the order added to the -plot). In \code{layer_scales()}, the row of a facet to return scales for.} +\item{i}{An integer. In \code{get_layer_data()}, the data to return (in the order added to the +plot). In \code{get_layer_grob()}, the grob to return (in the order added to the +plot). In \code{get_panel_scales()}, the row of a facet to return scales for.} -\item{j}{An integer. In \code{layer_scales()}, the column of a facet to return +\item{j}{An integer. In \code{get_panel_scales()}, the column of a facet to return scales for.} } \description{ @@ -32,7 +41,7 @@ a list of data frames (one for each layer), and a panel object, which contain all information about axis limits, breaks etc. } \details{ -\code{layer_data()}, \code{layer_grob()}, and \code{layer_scales()} are helper +\code{get_layer_data()}, \code{get_layer_grob()}, and \code{get_panel_scales()} are helper functions that return the data, grob, or scales associated with a given layer. These are useful for tests. } diff --git a/man/ggsave.Rd b/man/ggsave.Rd index 97b50458cc..2e06df38ea 100644 --- a/man/ggsave.Rd +++ b/man/ggsave.Rd @@ -6,7 +6,7 @@ \usage{ ggsave( filename, - plot = last_plot(), + plot = get_last_plot(), device = NULL, path = NULL, scale = 1, @@ -43,7 +43,8 @@ If not supplied, uses the size of the current graphics device.} arguments are expressed: \code{"in"}, \code{"cm"}, \code{"mm"} or \code{"px"}.} \item{dpi}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{limitsize}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of diff --git a/man/ggsf.Rd b/man/ggsf.Rd index 3b8ff90bd7..f7790f5abb 100644 --- a/man/ggsf.Rd +++ b/man/ggsf.Rd @@ -25,7 +25,8 @@ coord_sf( lims_method = "cross", ndiscr = 100, default = FALSE, - clip = "on" + clip = "on", + reverse = "none" ) geom_sf( @@ -43,14 +44,16 @@ geom_sf_label( mapping = aes(), data = NULL, stat = "sf_coordinates", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, label.padding = unit(0.25, "lines"), label.r = unit(0.15, "lines"), - label.size = 0.25, + label.size = deprecated(), + border.colour = NULL, + border.color = NULL, + text.colour = NULL, + text.color = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, @@ -61,11 +64,9 @@ geom_sf_text( mapping = aes(), data = NULL, stat = "sf_coordinates", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, na.rm = FALSE, show.legend = NA, @@ -99,7 +100,11 @@ though they would be visible in the final plot region.} \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to ensure that data and axes don't overlap. If \code{FALSE}, -limits are taken exactly from the data or \code{xlim}/\code{ylim}.} +limits are taken exactly from the data or \code{xlim}/\code{ylim}. +Giving a logical vector will separately control the expansion for the four +directions (top, left, bottom and right). The \code{expand} argument will be +recycled to length 4 if necessary. Alternatively, can be a named logical +vector to control a single direction, e.g. \code{expand = c(bottom = FALSE)}.} \item{crs}{The coordinate reference system (CRS) into which all data should be projected before plotting. If not specified, will use the CRS defined @@ -175,6 +180,11 @@ limits are set via \code{xlim} and \code{ylim} and some data points fall outside limits, then those data points may show up in places such as the axes, the legend, the plot title, or the plot margins.} +\item{reverse}{A string giving which directions to reverse. \code{"none"} +(default) keeps directions as is. \code{"x"} and \code{"y"} can be used to reverse +their respective directions. \code{"xy"} can be used to reverse both +directions.} + \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}}. If specified and \code{inherit.aes = TRUE} (the default), it is combined with the default mapping at the top level of the plot. You must supply \code{mapping} if there is no plot @@ -197,7 +207,7 @@ from a \code{formula} (e.g. \code{~ head(.x, 10)}).} \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -267,15 +277,20 @@ lists which parameters it can accept. \item{parse}{If \code{TRUE}, the labels will be parsed into expressions and displayed as described in \code{?plotmath}.} -\item{nudge_x, nudge_y}{Horizontal and vertical adjustment to nudge labels by. -Useful for offsetting text from points, particularly on discrete scales. -Cannot be jointly specified with \code{position}.} - \item{label.padding}{Amount of padding around label. Defaults to 0.25 lines.} \item{label.r}{Radius of rounded corners. Defaults to 0.15 lines.} -\item{label.size}{Size of label border, in mm.} +\item{label.size}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Replaced by the +\code{linewidth} aesthetic. Size of label border, in mm.} + +\item{border.colour, border.color}{Colour of label border. When \code{NULL} +(default), the \code{colour} aesthetic determines the colour of the label border. +\code{border.color} is an alias for \code{border.colour}.} + +\item{text.colour, text.color}{Colour of the text. When \code{NULL} (default), the +\code{colour} aesthetic determines the colour of the text. \code{text.color} is an +alias for \code{text.colour}.} \item{fun.geometry}{A function that takes a \code{sfc} object and returns a \code{sfc_POINT} with the same length as the input. If \code{NULL}, \code{function(x) sf::st_point_on_surface(sf::st_zm(x))} diff --git a/man/ggtheme.Rd b/man/ggtheme.Rd index b3594db3f2..c306fef405 100644 --- a/man/ggtheme.Rd +++ b/man/ggtheme.Rd @@ -16,71 +16,101 @@ theme_grey( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_gray( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_bw( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_linedraw( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_light( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_dark( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_minimal( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_classic( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) theme_void( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = alpha(ink, 0) ) theme_test( base_size = 11, base_family = "", + header_family = NULL, base_line_size = base_size/22, - base_rect_size = base_size/22 + base_rect_size = base_size/22, + ink = "black", + paper = "white" ) } \arguments{ @@ -88,9 +118,15 @@ theme_test( \item{base_family}{base font family} +\item{header_family}{font family for titles and headers. The default, \code{NULL}, +uses theme inheritance to set the font. This setting affects axis titles, +legend titles, the plot title and tag text.} + \item{base_line_size}{base size for line elements} \item{base_rect_size}{base size for rect elements} + +\item{ink, paper}{colour for foreground and background elements respectively.} } \description{ These are complete themes which control all non-data display. Use diff --git a/man/guide_axis.Rd b/man/guide_axis.Rd index 4d4ba4f166..baf05cebe6 100644 --- a/man/guide_axis.Rd +++ b/man/guide_axis.Rd @@ -24,7 +24,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{check.overlap}{silently remove overlapping labels, (recursively) prioritizing the first, last, and middle labels.} diff --git a/man/guide_axis_logticks.Rd b/man/guide_axis_logticks.Rd index b6f7d55737..7398f24890 100644 --- a/man/guide_axis_logticks.Rd +++ b/man/guide_axis_logticks.Rd @@ -51,7 +51,7 @@ and \code{FALSE} are shorthand for \code{"both"} and \code{"none"} respectively. \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{prescale_base, negative_small, short_theme}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} diff --git a/man/guide_axis_stack.Rd b/man/guide_axis_stack.Rd index a001a35ac2..542f4eb44b 100644 --- a/man/guide_axis_stack.Rd +++ b/man/guide_axis_stack.Rd @@ -30,7 +30,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{spacing}{A \code{\link[=unit]{unit()}} objects that determines how far separate guides are spaced apart.} @@ -53,7 +53,7 @@ The \code{first} guide will be placed closest to the panel and any subsequent guides provided through \code{...} will follow in the given order. } \examples{ -#' # A standard plot +# A standard plot p <- ggplot(mpg, aes(displ, hwy)) + geom_point() + theme(axis.line = element_line()) diff --git a/man/guide_axis_theta.Rd b/man/guide_axis_theta.Rd index 6e18e57a60..79f4b61cad 100644 --- a/man/guide_axis_theta.Rd +++ b/man/guide_axis_theta.Rd @@ -22,7 +22,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{angle}{Compared to setting the angle in \code{\link[=theme]{theme()}} / \code{\link[=element_text]{element_text()}}, this also uses some heuristics to automatically pick the \code{hjust} and \code{vjust} that diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 8633915f2d..d9fd873cdb 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -7,6 +7,7 @@ guide_bins( title = waiver(), theme = NULL, + angle = NULL, position = NULL, direction = NULL, override.aes = list(), @@ -24,13 +25,22 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} + +\item{angle}{Overrules the theme settings to automatically apply appropriate +\code{hjust} and \code{vjust} for angled legend text. Can be a single number +representing the text angle in degrees, or \code{NULL} to not overrule the +settings (default).} \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} \item{direction}{A character string indicating the direction of the guide. -One of "horizontal" or "vertical."} +One of "horizontal" or "vertical".} \item{override.aes}{A list specifying aesthetic parameters of legend key. See details and examples.} diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index c1f75a3b2f..bba0e628c0 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -14,6 +14,7 @@ guide_colourbar( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + angle = NULL, position = NULL, direction = NULL, reverse = FALSE, @@ -31,6 +32,7 @@ guide_colorbar( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + angle = NULL, position = NULL, direction = NULL, reverse = FALSE, @@ -47,7 +49,11 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{nbin}{A numeric specifying the number of bins for drawing the colourbar. A smoother colourbar results from a larger value.} @@ -77,6 +83,11 @@ be visible.} \item{draw.llim}{A logical specifying if the lower limit tick marks should be visible.} +\item{angle}{Overrules the theme settings to automatically apply appropriate +\code{hjust} and \code{vjust} for angled legend text. Can be a single number +representing the text angle in degrees, or \code{NULL} to not overrule the +settings (default).} + \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index 97e66d6207..dc5806929a 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -9,9 +9,11 @@ guide_coloursteps( title = waiver(), theme = NULL, alpha = NA, + angle = NULL, even.steps = TRUE, show.limits = NULL, direction = NULL, + position = NULL, reverse = FALSE, order = 0, available_aes = c("colour", "color", "fill"), @@ -22,9 +24,11 @@ guide_colorsteps( title = waiver(), theme = NULL, alpha = NA, + angle = NULL, even.steps = TRUE, show.limits = NULL, direction = NULL, + position = NULL, reverse = FALSE, order = 0, available_aes = c("colour", "color", "fill"), @@ -39,12 +43,21 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{alpha}{A numeric between 0 and 1 setting the colour transparency of the bar. Use \code{NA} to preserve the alpha encoded in the colour itself (default).} +\item{angle}{Overrules the theme settings to automatically apply appropriate +\code{hjust} and \code{vjust} for angled legend text. Can be a single number +representing the text angle in degrees, or \code{NULL} to not overrule the +settings (default).} + \item{even.steps}{Should the rendered size of the bins be equal, or should they be proportional to their length in the data space? Defaults to \code{TRUE}} @@ -57,6 +70,9 @@ shown irrespective of the value of \code{show.limits}.} \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} +\item{position}{A character string indicating where the legend should be +placed relative to the plot panels.} + \item{reverse}{logical. If \code{TRUE} the colourbar is reversed. By default, the highest value is on the top and the lowest value is on the bottom} diff --git a/man/guide_custom.Rd b/man/guide_custom.Rd index 74c8a9f00a..f13559cae2 100644 --- a/man/guide_custom.Rd +++ b/man/guide_custom.Rd @@ -25,7 +25,11 @@ If \code{NULL} (default), no title is shown.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} diff --git a/man/guide_legend.Rd b/man/guide_legend.Rd index d2db3b2da4..366005c99f 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.Rd @@ -25,13 +25,17 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} \item{direction}{A character string indicating the direction of the guide. -One of "horizontal" or "vertical."} +One of "horizontal" or "vertical".} \item{override.aes}{A list specifying aesthetic parameters of legend key. See details and examples.} diff --git a/man/labeller.Rd b/man/labeller.Rd index 52481179f9..2c863d2aee 100644 --- a/man/labeller.Rd +++ b/man/labeller.Rd @@ -42,7 +42,7 @@ for the argument \code{labeller}. \description{ This function makes it easy to assign different labellers to different factors. The labeller can be a function or it can be a -named character vectors that will serve as a lookup table. +named character vector that will serve as a lookup table. } \details{ In case of functions, if the labeller has class \code{labeller}, it diff --git a/man/labellers.Rd b/man/labellers.Rd index 63a4980eb7..09f160bf40 100644 --- a/man/labellers.Rd +++ b/man/labellers.Rd @@ -108,6 +108,9 @@ p + facet_grid(am ~ vs+cyl, labeller = label_context) # Interpreting the labels as plotmath expressions p + facet_grid(. ~ cyl2) p + facet_grid(. ~ cyl2, labeller = label_parsed) + +# Include optional argument in label function +p + facet_grid(. ~ cyl, labeller = function(x) label_both(x, sep = "=")) } } \seealso{ diff --git a/man/labs.Rd b/man/labs.Rd index 86b71a98aa..18cd7690f6 100644 --- a/man/labs.Rd +++ b/man/labs.Rd @@ -14,6 +14,7 @@ labs( subtitle = waiver(), caption = waiver(), tag = waiver(), + dictionary = waiver(), alt = waiver(), alt_insight = waiver() ) @@ -24,7 +25,7 @@ ylab(label) ggtitle(label, subtitle = waiver()) -get_labs(plot = last_plot()) +get_labs(plot = get_last_plot()) } \arguments{ \item{...}{A list of new name-value pairs. The name should be an aesthetic.} @@ -40,8 +41,15 @@ bottom-right of the plot by default.} \item{tag}{The text for the tag label which will be displayed at the top-left of the plot by default.} +\item{dictionary}{A named character vector to serve as dictionary. +Automatically derived labels, such as those based on variables will +be matched with \code{names(dictionary)} and replaced by the matching +entry in \code{dictionary}.} + \item{alt, alt_insight}{Text used for the generation of alt-text for the plot. -See \link{get_alt_text} for examples.} +See \link{get_alt_text} for examples. \code{alt} can also be a function that +takes the plot as input and returns text as output. \code{alt} also accepts +rlang \link[rlang:as_function]{lambda} function notation.} \item{label}{The title of the respective axis (for \code{xlab()} or \code{ylab()}) or of the plot (for \code{ggtitle()}).} @@ -73,6 +81,14 @@ p <- ggplot(mtcars, aes(mpg, wt, colour = cyl)) + geom_point() p + labs(colour = "Cylinders") p + labs(x = "New x label") +# Set labels by variable name instead of aesthetic +p + labs(dict = c( + disp = "Displacment", # Not in use + cyl = "Number of cylinders", + mpg = "Miles per gallon", + wt = "Weight (1000 lbs)" +)) + # The plot title appears at the top-left, with the subtitle # display in smaller text underneath it p + labs(title = "New plot title") diff --git a/man/layer.Rd b/man/layer.Rd index 8ce4e49715..79d9afbe57 100644 --- a/man/layer.Rd +++ b/man/layer.Rd @@ -16,6 +16,7 @@ layer( check.param = TRUE, show.legend = NA, key_glyph = NULL, + layout = NULL, layer_class = Layer ) } @@ -35,7 +36,7 @@ give the geom as \code{"point"}. \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -94,11 +95,16 @@ supplied parameters and aesthetics are understood by the \code{geom} or \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{key_glyph}{A legend key drawing function or a string providing the function name minus the \code{draw_key_} prefix. See \link{draw_key} for details.} +\item{layout}{Argument to control layout at the layer level. Consult the +faceting documentation to view appropriate values.} + \item{layer_class}{The type of layer object to be constructed. This is intended for ggplot2 internal use only.} } diff --git a/man/layer_sf.Rd b/man/layer_sf.Rd index 8da9547aed..a10dfa8805 100644 --- a/man/layer_sf.Rd +++ b/man/layer_sf.Rd @@ -33,7 +33,7 @@ give the geom as \code{"point"}. \item{stat}{The statistical transformation to use on the data for this layer. When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and +argument can be used to override the default coupling between geoms and stats. The \code{stat} argument accepts the following: \itemize{ \item A \code{Stat} ggproto subclass, for example \code{StatCount}. @@ -92,7 +92,9 @@ supplied parameters and aesthetics are understood by the \code{geom} or \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} } \description{ The \code{layer_sf()} function is a variant of \code{\link[=layer]{layer()}} meant to be used by diff --git a/man/lims.Rd b/man/lims.Rd index b6d6559f65..c0a137058e 100644 --- a/man/lims.Rd +++ b/man/lims.Rd @@ -31,7 +31,9 @@ This is a shortcut for supplying the \code{limits} argument to the individual scales. By default, any values outside the limits specified are replaced with \code{NA}. Be warned that this will remove data outside the limits and this can produce unintended results. For changing x or y axis limits \strong{without} -dropping data observations, see \code{\link[=coord_cartesian]{coord_cartesian()}}. +dropping data observations, see +\code{\link[=coord_cartesian]{coord_cartesian(xlim, ylim)}}, or use a full scale with +\code{\link[scales:oob]{oob = scales::oob_keep}}. } \examples{ # Zoom into a specified area diff --git a/man/map_data.Rd b/man/map_data.Rd index 5f8d2d2078..37832d29ca 100644 --- a/man/map_data.Rd +++ b/man/map_data.Rd @@ -8,10 +8,10 @@ map_data(map, region = ".", exact = FALSE, ...) } \arguments{ \item{map}{name of map provided by the \pkg{maps} package. These -include \code{\link[maps:county]{maps::county()}}, \code{\link[maps:france]{maps::france()}}, -\code{\link[maps:italy]{maps::italy()}}, \code{\link[maps:nz]{maps::nz()}}, -\code{\link[maps:state]{maps::state()}}, \code{\link[maps:usa]{maps::usa()}}, -\code{\link[maps:world]{maps::world()}}, \code{\link[maps:world2]{maps::world2()}}.} +include \code{\link[maps:county]{"county"}}, \code{\link[maps:france]{"france"}}, +\code{\link[maps:italy]{"italy"}}, \code{\link[maps:nz]{"nz"}}, +\code{\link[maps:state]{"state"}}, \code{\link[maps:usa]{"usa"}}, +\code{\link[maps:world]{"world"}}, or \code{\link[maps:world2]{"world2"}}.} \item{region}{name(s) of subregion(s) to include. Defaults to \code{.} which includes all subregions. See documentation for \code{\link[maps:map]{maps::map()}} diff --git a/man/merge_element.Rd b/man/merge_element.Rd index 4071e6c69a..ca993eeec3 100644 --- a/man/merge_element.Rd +++ b/man/merge_element.Rd @@ -5,6 +5,7 @@ \alias{merge_element.default} \alias{merge_element.element_blank} \alias{merge_element.element} +\alias{merge_element.margin} \title{Merge a parent element into a child element} \usage{ merge_element(new, old) @@ -14,6 +15,8 @@ merge_element(new, old) \method{merge_element}{element_blank}(new, old) \method{merge_element}{element}(new, old) + +\method{merge_element}{margin}(new, old) } \arguments{ \item{new}{The child element in the theme hierarchy} diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index b42353b35e..0f957b4182 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -5,7 +5,12 @@ \alias{position_dodge2} \title{Dodge overlapping objects side-to-side} \usage{ -position_dodge(width = NULL, preserve = "total") +position_dodge( + width = NULL, + preserve = "total", + orientation = "x", + reverse = FALSE +) position_dodge2( width = NULL, @@ -22,11 +27,15 @@ geoms. See the examples.} \item{preserve}{Should dodging preserve the \code{"total"} width of all elements at a position, or the width of a \code{"single"} element?} -\item{padding}{Padding between elements at the same position. Elements are -shrunk by this proportion to allow space between them. Defaults to 0.1.} +\item{orientation}{Fallback orientation when the layer or the data does not +indicate an explicit orientation, like \code{geom_point()}. Can be \code{"x"} +(default) or \code{"y"}.} \item{reverse}{If \code{TRUE}, will reverse the default stacking order. This is useful if you're rotating both the plot and legend.} + +\item{padding}{Padding between elements at the same position. Elements are +shrunk by this proportion to allow space between them. Defaults to 0.1.} } \description{ Dodging preserves the vertical position of an geom while adjusting the @@ -37,6 +46,15 @@ be specified in the global or \verb{geom_*} layer. Unlike \code{position_dodge() particularly useful for arranging box plots, which can have variable widths. } +\section{Aesthetics}{ + +\code{position_dodge()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \code{order} \tab → \code{NULL} \cr\cr +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar(position = "dodge2") diff --git a/man/position_jitter.Rd b/man/position_jitter.Rd index d0531116d6..b43f4ade40 100644 --- a/man/position_jitter.Rd +++ b/man/position_jitter.Rd @@ -49,7 +49,7 @@ ggplot(mtcars, aes(am, vs)) + geom_jitter(position = position_jitter(width = 0.1, height = 0.1)) # Create a jitter object for reproducible jitter: -jitter <- position_jitter(width = 0.1, height = 0.1) +jitter <- position_jitter(width = 0.1, height = 0.1, seed = 0) ggplot(mtcars, aes(am, vs)) + geom_point(position = jitter) + geom_point(position = jitter, color = "red", aes(am + 0.2, vs + 0.2)) diff --git a/man/position_jitterdodge.Rd b/man/position_jitterdodge.Rd index d158162211..ca5bb8e30c 100644 --- a/man/position_jitterdodge.Rd +++ b/man/position_jitterdodge.Rd @@ -8,6 +8,7 @@ position_jitterdodge( jitter.width = NULL, jitter.height = 0, dodge.width = 0.75, + reverse = FALSE, seed = NA ) } @@ -20,6 +21,9 @@ resolution of the data.} \item{dodge.width}{the amount to dodge in the x direction. Defaults to 0.75, the default \code{position_dodge()} width.} +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} + \item{seed}{A random seed to make the jitter reproducible. Useful if you need to apply the same jitter twice, e.g., for a point and a corresponding label. diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index 3b2b2573cb..07fcd63447 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -4,7 +4,7 @@ \alias{position_nudge} \title{Nudge points a fixed distance} \usage{ -position_nudge(x = 0, y = 0) +position_nudge(x = NULL, y = NULL) } \arguments{ \item{x, y}{Amount of vertical and horizontal distance to move.} @@ -15,6 +15,16 @@ items on discrete scales by a small amount. Nudging is built in to \code{\link[=geom_text]{geom_text()}} because it's so useful for moving labels a small distance from what they're labelling. } +\section{Aesthetics}{ + +\code{position_nudge()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \code{nudge_x} \tab → \code{0} \cr\cr +• \tab \code{nudge_y} \tab → \code{0} \cr\cr +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ df <- data.frame( x = c(1,3,2,5), @@ -33,6 +43,11 @@ ggplot(df, aes(x, y)) + ggplot(df, aes(x, y)) + geom_point() + geom_text(aes(label = y), nudge_y = -0.1) + +# For each text individually +ggplot(df, aes(x, y)) + + geom_point() + + geom_text(aes(label = y, nudge_y = c(-0.1, 0.1, -0.1, 0.1))) } \seealso{ Other position adjustments: diff --git a/man/position_stack.Rd b/man/position_stack.Rd index 024bfd80a4..646ab3c515 100644 --- a/man/position_stack.Rd +++ b/man/position_stack.Rd @@ -126,14 +126,12 @@ ggplot(series, aes(time, value, group = type)) + # Negative values ----------------------------------------------------------- -df <- tibble::tribble( - ~x, ~y, ~grp, - "a", 1, "x", - "a", 2, "y", - "b", 1, "x", - "b", 3, "y", - "b", -1, "y" +df <- data.frame( + x = rep(c("a", "b"), 2:3), + y = c(1, 2, 1, 3, -1), + grp = c("x", "y", "x", "y", "y") ) + ggplot(data = df, aes(x, y, group = grp)) + geom_col(aes(fill = grp), position = position_stack(reverse = TRUE)) + geom_hline(yintercept = 0) diff --git a/man/print.ggplot.Rd b/man/print.ggplot.Rd index 07b2a68942..1d558a3e9e 100644 --- a/man/print.ggplot.Rd +++ b/man/print.ggplot.Rd @@ -28,18 +28,17 @@ to call \code{print()} explicitly if you want to draw a plot inside a function or for loop. } \examples{ -colours <- list(~class, ~drv, ~fl) +colours <- c("class", "drv", "fl") # Doesn't seem to do anything! for (colour in colours) { - ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + + ggplot(mpg, aes(displ, hwy, colour = .data[[colour]])) + geom_point() } -# Works when we explicitly print the plots for (colour in colours) { - print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + - geom_point()) + print(ggplot(mpg, aes(displ, hwy, colour = .data[[colour]])) + + geom_point()) } } \keyword{hplot} diff --git a/man/render_strips.Rd b/man/render_strips.Rd index b62a836c8d..468caf6899 100644 --- a/man/render_strips.Rd +++ b/man/render_strips.Rd @@ -4,7 +4,7 @@ \alias{render_strips} \title{Render panel strips} \usage{ -render_strips(x = NULL, y = NULL, labeller, theme) +render_strips(x = NULL, y = NULL, labeller = identity, theme) } \arguments{ \item{x, y}{A data.frame with a column for each variable and a row for each diff --git a/man/scale_alpha.Rd b/man/scale_alpha.Rd index 28defef0de..7c4a5784df 100644 --- a/man/scale_alpha.Rd +++ b/man/scale_alpha.Rd @@ -10,15 +10,20 @@ \alias{scale_alpha_date} \title{Alpha transparency scales} \usage{ -scale_alpha(name = waiver(), ..., range = c(0.1, 1)) +scale_alpha(name = waiver(), ..., range = NULL, aesthetics = "alpha") -scale_alpha_continuous(name = waiver(), ..., range = c(0.1, 1)) +scale_alpha_continuous( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) -scale_alpha_binned(name = waiver(), ..., range = c(0.1, 1)) +scale_alpha_binned(name = waiver(), ..., range = NULL, aesthetics = "alpha") scale_alpha_discrete(...) -scale_alpha_ordinal(name = waiver(), ..., range = c(0.1, 1)) +scale_alpha_ordinal(name = waiver(), ..., range = NULL, aesthetics = "alpha") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -31,6 +36,8 @@ or \code{\link[=discrete_scale]{discrete_scale()}} as appropriate, to control na breaks, labels and so forth.} \item{range}{Output range of alpha values. Must lie between 0 and 1.} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ Alpha-transparency scales are not tremendously useful, but can be a diff --git a/man/scale_binned.Rd b/man/scale_binned.Rd index ad98d61969..f75f8a16f9 100644 --- a/man/scale_binned.Rd +++ b/man/scale_binned.Rd @@ -68,7 +68,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_colour_continuous.Rd b/man/scale_colour_continuous.Rd index 36f3427746..b7b482cb92 100644 --- a/man/scale_colour_continuous.Rd +++ b/man/scale_colour_continuous.Rd @@ -9,17 +9,61 @@ \alias{scale_color_binned} \title{Continuous and binned colour scales} \usage{ -scale_colour_continuous(..., type = getOption("ggplot2.continuous.colour")) - -scale_fill_continuous(..., type = getOption("ggplot2.continuous.fill")) - -scale_colour_binned(..., type = getOption("ggplot2.binned.colour")) - -scale_fill_binned(..., type = getOption("ggplot2.binned.fill")) +scale_colour_continuous( + ..., + palette = NULL, + aesthetics = "colour", + guide = "colourbar", + na.value = "grey50", + type = getOption("ggplot2.continuous.colour") +) + +scale_fill_continuous( + ..., + palette = NULL, + aesthetics = "fill", + guide = "colourbar", + na.value = "grey50", + type = getOption("ggplot2.continuous.fill") +) + +scale_colour_binned( + ..., + palette = NULL, + aesthetics = "colour", + guide = "coloursteps", + na.value = "grey50", + type = getOption("ggplot2.binned.colour") +) + +scale_fill_binned( + ..., + palette = NULL, + aesthetics = "fill", + guide = "coloursteps", + na.value = "grey50", + type = getOption("ggplot2.binned.fill") +) } \arguments{ \item{...}{Additional parameters passed on to the scale type} +\item{palette}{One of the following: +\itemize{ +\item \code{NULL} for the default palette stored in the theme. +\item a character vector of colours. +\item a single string naming a palette. +\item a palette function that when called with a numeric vector with values +between 0 and 1 returns the corresponding output values. +}} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} + +\item{guide}{A function used to create a guide or its name. See +\code{\link[=guides]{guides()}} for more information.} + +\item{na.value}{Missing values will be replaced with this value.} + \item{type}{One of the following: \itemize{ \item "gradient" (the default) @@ -76,26 +120,28 @@ and references therein. } \examples{ -v <- ggplot(faithfuld, aes(waiting, eruptions, fill = density)) + -geom_tile() -v - -v + scale_fill_continuous(type = "gradient") -v + scale_fill_continuous(type = "viridis") - -# The above are equivalent to -v + scale_fill_gradient() -v + scale_fill_viridis_c() - -# To make a binned version of this plot -v + scale_fill_binned(type = "viridis") - -# Set a different default scale using the options -# mechanism -tmp <- getOption("ggplot2.continuous.fill") # store current setting -options(ggplot2.continuous.fill = scale_fill_distiller) -v -options(ggplot2.continuous.fill = tmp) # restore previous setting +# A standard plot +p <- ggplot(mpg, aes(displ, hwy, colour = cty)) + + geom_point() + +# You can use the scale to give a palette directly +p + scale_colour_continuous(palette = c("#FEE0D2", "#FC9272", "#DE2D26")) + +# The default colours are encoded into the theme +p + theme(palette.colour.continuous = c("#DEEBF7", "#9ECAE1", "#3182BD")) + +# You can globally set default colour palette via the theme +old <- update_theme(palette.colour.continuous = c("#E5F5E0", "#A1D99B", "#31A354")) + +# Plot now shows new global default +p + +# The default binned colour scale uses the continuous palette +p + scale_colour_binned() + + theme(palette.colour.continuous = c("#EFEDF5", "#BCBDDC", "#756BB1")) + +# Restoring the previous theme +theme_set(old) } \seealso{ \code{\link[=scale_colour_gradient]{scale_colour_gradient()}}, \code{\link[=scale_colour_viridis_c]{scale_colour_viridis_c()}}, diff --git a/man/scale_colour_discrete.Rd b/man/scale_colour_discrete.Rd index 0c7883fb6e..c86fd7b33c 100644 --- a/man/scale_colour_discrete.Rd +++ b/man/scale_colour_discrete.Rd @@ -1,18 +1,45 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/scale-hue.R, R/zxx.R +% Please edit documentation in R/scale-colour.R, R/zxx.R \name{scale_colour_discrete} \alias{scale_colour_discrete} \alias{scale_fill_discrete} \alias{scale_color_discrete} \title{Discrete colour scales} \usage{ -scale_colour_discrete(..., type = getOption("ggplot2.discrete.colour")) +scale_colour_discrete( + ..., + palette = NULL, + aesthetics = "colour", + na.value = "grey50", + type = getOption("ggplot2.discrete.colour") +) -scale_fill_discrete(..., type = getOption("ggplot2.discrete.fill")) +scale_fill_discrete( + ..., + palette = NULL, + aesthetics = "fill", + na.value = "grey50", + type = getOption("ggplot2.discrete.fill") +) } \arguments{ \item{...}{Additional parameters passed on to the scale type,} +\item{palette}{One of the following: +\itemize{ +\item \code{NULL} for the default palette stored in the theme. +\item a character vector of colours. +\item a single string naming a palette. +\item a palette function that when called with a single integer argument (the +number of levels in the scale) returns the values that they should take. +}} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} + +\item{na.value}{If \code{na.translate = TRUE}, what aesthetic value should the +missing values be displayed as? Does not apply to position scales +where \code{NA} is always placed at the far right.} + \item{type}{One of the following: \itemize{ \item A character vector of color codes. The codes are used for a 'manual' color @@ -34,38 +61,24 @@ unless \code{type} (which defaults to the \code{ggplot2.discrete.fill}/\code{ggp is specified. } \examples{ -# Template function for creating densities grouped by a variable -cty_by_var <- function(var) { - ggplot(mpg, aes(cty, colour = factor({{var}}), fill = factor({{var}}))) + - geom_density(alpha = 0.2) -} +# A standard plot +p <- ggplot(mpg, aes(displ, hwy, colour = class)) + + geom_point() -# The default, scale_fill_hue(), is not colour-blind safe -cty_by_var(class) +# You can use the scale to give a palette directly +p + scale_colour_discrete(palette = scales::pal_brewer(palette = "Dark2")) -# (Temporarily) set the default to Okabe-Ito (which is colour-blind safe) -okabe <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7") -withr::with_options( - list(ggplot2.discrete.fill = okabe), - print(cty_by_var(class)) -) +# The default colours are encoded into the theme +p + theme(palette.colour.discrete = scales::pal_grey()) -# Define a collection of palettes to alter the default based on number of levels to encode -discrete_palettes <- list( - c("skyblue", "orange"), - RColorBrewer::brewer.pal(3, "Set2"), - RColorBrewer::brewer.pal(6, "Accent") -) -withr::with_options( - list(ggplot2.discrete.fill = discrete_palettes), { - # 1st palette is used when there 1-2 levels (e.g., year) - print(cty_by_var(year)) - # 2nd palette is used when there are 3 levels - print(cty_by_var(drv)) - # 3rd palette is used when there are 4-6 levels - print(cty_by_var(fl)) -}) +# You can globally set default colour palette via the theme +old <- update_theme(palette.colour.discrete = scales::pal_viridis()) + +# Plot now shows new global default +p +# Restoring the previous theme +theme_set(old) } \seealso{ The \href{https://ggplot2-book.org/scales-colour#sec-colour-discrete}{discrete colour scales section} of the online ggplot2 book. diff --git a/man/scale_continuous.Rd b/man/scale_continuous.Rd index 56c23639a6..5fa4a0fb44 100644 --- a/man/scale_continuous.Rd +++ b/man/scale_continuous.Rd @@ -78,13 +78,13 @@ Also accepts rlang \link[rlang:as_function]{lambda} function notation. \item{minor_breaks}{One of: \itemize{ \item \code{NULL} for no minor breaks -\item \code{waiver()} for the default breaks (one minor break between -each major break) +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) \item A numeric vector of positions \item A function that given the limits returns a vector of minor breaks. Also accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major -breaks. +break positions. }} \item{n.breaks}{An integer guiding the number of major breaks. The algorithm @@ -92,7 +92,9 @@ may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_date.Rd b/man/scale_date.Rd index 86c82e0271..9eb6643130 100644 --- a/man/scale_date.Rd +++ b/man/scale_date.Rd @@ -78,8 +78,11 @@ scale_y_datetime( scale_x_time( 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, @@ -92,8 +95,11 @@ scale_x_time( scale_y_time( 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, @@ -122,7 +128,9 @@ weeks", or "10 years". If both \code{breaks} and \code{date_breaks} are specified, \code{date_breaks} wins. Valid specifications are 'sec', 'min', 'hour', 'day', 'week', 'month' or 'year', optionally followed by 's'.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_discrete.Rd b/man/scale_discrete.Rd index 1b4c19710f..d6a3b99378 100644 --- a/man/scale_discrete.Rd +++ b/man/scale_discrete.Rd @@ -8,17 +8,23 @@ scale_x_discrete( name = waiver(), ..., + palette = seq_len, expand = waiver(), guide = waiver(), - position = "bottom" + position = "bottom", + sec.axis = waiver(), + continuous.limits = NULL ) scale_y_discrete( name = waiver(), ..., + palette = seq_len, expand = waiver(), guide = waiver(), - position = "left" + position = "left", + sec.axis = waiver(), + continuous.limits = NULL ) } \arguments{ @@ -30,9 +36,6 @@ omitted.} \item{...}{ Arguments passed on to \code{\link[=discrete_scale]{discrete_scale}} \describe{ - \item{\code{palette}}{A palette function that when called with a single integer -argument (the number of levels in the scale) returns the values that -they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -62,7 +65,20 @@ from a discrete scale, specify \code{na.translate = FALSE}.} missing values be displayed as? Does not apply to position scales where \code{NA} is always placed at the far right.} \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -77,6 +93,10 @@ notation. \item{\code{super}}{The super class to use for the constructed scale} }} +\item{palette}{A palette function that when called with a single integer +argument (the number of levels in the scale) returns the numerical values +that they should take.} + \item{expand}{For position scales, a vector of range expansion constants used to add some padding around the data to ensure that they are placed some distance away from the axes. Use the convenience function \code{\link[=expansion]{expansion()}} @@ -89,6 +109,17 @@ expand the scale by 5\% on each side for continuous variables, and by \item{position}{For position scales, The position of the axis. \code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} + +\item{sec.axis}{\code{\link[=dup_axis]{dup_axis()}} is used to specify a secondary axis.} + +\item{continuous.limits}{One of: +\itemize{ +\item \code{NULL} to use the default scale range +\item A numeric vector of length two providing a display range for the scale. +Use \code{NA} to refer to the existing minimum or maximum. +\item A function that accepts the limits and returns a numeric vector of +length two. +}} } \description{ \code{scale_x_discrete()} and \code{scale_y_discrete()} are used to set the values for diff --git a/man/scale_gradient.Rd b/man/scale_gradient.Rd index cbc5427282..6d0b5c8c15 100644 --- a/man/scale_gradient.Rd +++ b/man/scale_gradient.Rd @@ -103,9 +103,6 @@ omitted.} \describe{ \item{\code{scale_name}}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} The name of the scale that should be used for error messages associated with this scale.} - \item{\code{palette}}{A palette function that when called with a numeric vector with -values between 0 and 1 returns the corresponding output values -(e.g., \code{\link[scales:pal_area]{scales::pal_area()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -120,19 +117,21 @@ Also accepts rlang \link[rlang:as_function]{lambda} function notation. \item{\code{minor_breaks}}{One of: \itemize{ \item \code{NULL} for no minor breaks -\item \code{waiver()} for the default breaks (one minor break between -each major break) +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) \item A numeric vector of positions \item A function that given the limits returns a vector of minor breaks. Also accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major -breaks. +break positions. }} \item{\code{n.breaks}}{An integer guiding the number of major breaks. The algorithm may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -260,6 +259,14 @@ ggplot(df, aes(x, y)) + geom_point(aes(colour = z1)) + scale_colour_gradientn(colours = terrain.colors(10)) +# The gradientn scale can be centered by using a rescaler +ggplot(df, aes(x, y)) + + geom_point(aes(colour = z1)) + + scale_colour_gradientn( + colours = c("blue", "dodgerblue", "white", "orange", "red"), + rescaler = ~ scales::rescale_mid(.x, mid = 0) + ) + # Equivalent fill scales do the same job for the fill aesthetic ggplot(faithfuld, aes(waiting, eruptions)) + geom_raster(aes(fill = density)) + diff --git a/man/scale_grey.Rd b/man/scale_grey.Rd index e085fa0016..9d838508dc 100644 --- a/man/scale_grey.Rd +++ b/man/scale_grey.Rd @@ -33,9 +33,6 @@ omitted.} \item{...}{ Arguments passed on to \code{\link[=discrete_scale]{discrete_scale}} \describe{ - \item{\code{palette}}{A palette function that when called with a single integer -argument (the number of levels in the scale) returns the values that -they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -61,7 +58,20 @@ every level in a legend, the layer should use \code{show.legend = TRUE}.} \item{\code{na.translate}}{Unlike continuous scales, discrete scales can easily show missing values, and do so by default. If you want to remove missing values from a discrete scale, specify \code{na.translate = FALSE}.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_hue.Rd b/man/scale_hue.Rd index 0ec49fd123..0a0aba8fcd 100644 --- a/man/scale_hue.Rd +++ b/man/scale_hue.Rd @@ -39,9 +39,6 @@ omitted.} \item{...}{ Arguments passed on to \code{\link[=discrete_scale]{discrete_scale}} \describe{ - \item{\code{palette}}{A palette function that when called with a single integer -argument (the number of levels in the scale) returns the values that -they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -67,7 +64,20 @@ every level in a legend, the layer should use \code{show.legend = TRUE}.} \item{\code{na.translate}}{Unlike continuous scales, discrete scales can easily show missing values, and do so by default. If you want to remove missing values from a discrete scale, specify \code{na.translate = FALSE}.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_identity.Rd b/man/scale_identity.Rd index 2f3a877cfd..68100940e0 100644 --- a/man/scale_identity.Rd +++ b/man/scale_identity.Rd @@ -22,15 +22,35 @@ scale_colour_identity( scale_fill_identity(name = waiver(), ..., guide = "none", aesthetics = "fill") -scale_shape_identity(name = waiver(), ..., guide = "none") +scale_shape_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "shape" +) -scale_linetype_identity(name = waiver(), ..., guide = "none") +scale_linetype_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "linetype" +) -scale_linewidth_identity(name = waiver(), ..., guide = "none") +scale_linewidth_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "linewidth" +) -scale_alpha_identity(name = waiver(), ..., guide = "none") +scale_alpha_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "alpha" +) -scale_size_identity(name = waiver(), ..., guide = "none") +scale_size_identity(name = waiver(), ..., guide = "none", aesthetics = "size") scale_discrete_identity(aesthetics, name = waiver(), ..., guide = "none") diff --git a/man/scale_linetype.Rd b/man/scale_linetype.Rd index 94eeb93927..5c6e9a691f 100644 --- a/man/scale_linetype.Rd +++ b/man/scale_linetype.Rd @@ -7,13 +7,13 @@ \alias{scale_linetype_discrete} \title{Scale for line patterns} \usage{ -scale_linetype(name = waiver(), ..., na.value = "blank") +scale_linetype(name = waiver(), ..., aesthetics = "linetype") -scale_linetype_binned(name = waiver(), ..., na.value = "blank") +scale_linetype_binned(name = waiver(), ..., aesthetics = "linetype") scale_linetype_continuous(...) -scale_linetype_discrete(name = waiver(), ..., na.value = "blank") +scale_linetype_discrete(name = waiver(), ..., aesthetics = "linetype") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -24,9 +24,6 @@ omitted.} \item{...}{ Arguments passed on to \code{\link[=discrete_scale]{discrete_scale}} \describe{ - \item{\code{palette}}{A palette function that when called with a single integer -argument (the number of levels in the scale) returns the values that -they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -52,8 +49,20 @@ every level in a legend, the layer should use \code{show.legend = TRUE}.} \item{\code{na.translate}}{Unlike continuous scales, discrete scales can easily show missing values, and do so by default. If you want to remove missing values from a discrete scale, specify \code{na.translate = FALSE}.} - \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -70,7 +79,7 @@ notation. \item{\code{super}}{The super class to use for the constructed scale} }} -\item{na.value}{The linetype to use for \code{NA} values.} +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ Default line types based on a set supplied by Richard Pearson, @@ -78,6 +87,13 @@ University of Manchester. Continuous values can not be mapped to line types unless \code{scale_linetype_binned()} is used. Still, as linetypes has no inherent order, this use is not advised. } +\details{ +Lines can be referred to by number, name or hex code. Contrary to base R +graphics, \code{NA}s are interpreted as blanks. + +\if{html}{\figure{linetype_table.svg}{Named linetypes by number and name}} +\if{latex}{\figure{linetype_table.pdf}} +} \examples{ base <- ggplot(economics_long, aes(date, value01)) base + geom_line(aes(group = variable)) diff --git a/man/scale_linewidth.Rd b/man/scale_linewidth.Rd index 275f860582..ffce8ffa0f 100644 --- a/man/scale_linewidth.Rd +++ b/man/scale_linewidth.Rd @@ -15,10 +15,11 @@ scale_linewidth( breaks = waiver(), labels = waiver(), limits = NULL, - range = c(1, 6), + range = NULL, transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "linewidth" ) scale_linewidth_binned( @@ -26,12 +27,13 @@ scale_linewidth_binned( breaks = waiver(), labels = waiver(), limits = NULL, - range = c(1, 6), + range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", trans = deprecated(), - guide = "bins" + guide = "bins", + aesthetics = "linewidth" ) } \arguments{ @@ -52,7 +54,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -99,6 +103,8 @@ You can create your own transformation with \code{\link[scales:new_transform]{sc \item{guide}{A function used to create a guide or its name. See \code{\link[=guides]{guides()}} for more information.} +\item{aesthetics}{The names of the aesthetics that this scale works with.} + \item{n.breaks}{An integer guiding the number of major breaks. The algorithm may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default @@ -113,7 +119,7 @@ breaks are given explicitly.} \description{ \code{scale_linewidth} scales the width of lines and polygon strokes. Due to historical reasons, it is also possible to control this with the \code{size} -aesthetic, but using \code{linewidth} is encourage to clearly differentiate area +aesthetic, but using \code{linewidth} is encouraged to clearly differentiate area aesthetics from stroke width aesthetics. } \examples{ diff --git a/man/scale_manual.Rd b/man/scale_manual.Rd index 9857dcbc65..75677d54d0 100644 --- a/man/scale_manual.Rd +++ b/man/scale_manual.Rd @@ -28,15 +28,45 @@ scale_fill_manual( na.value = "grey50" ) -scale_size_manual(..., values, breaks = waiver(), na.value = NA) +scale_size_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "size" +) -scale_shape_manual(..., values, breaks = waiver(), na.value = NA) +scale_shape_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "shape" +) -scale_linetype_manual(..., values, breaks = waiver(), na.value = "blank") +scale_linetype_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linetype" +) -scale_linewidth_manual(..., values, breaks = waiver(), na.value = NA) +scale_linewidth_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linewidth" +) -scale_alpha_manual(..., values, breaks = waiver(), na.value = NA) +scale_alpha_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "alpha" +) scale_discrete_manual(aesthetics, ..., values, breaks = waiver()) } @@ -64,7 +94,20 @@ from a discrete scale, specify \code{na.translate = FALSE}.} \code{waiver()}, the default, the name of the scale is taken from the first mapping used for that aesthetic. If \code{NULL}, the legend title will be omitted.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_shape.Rd b/man/scale_shape.Rd index 65deec3ea2..4ec9ba9894 100644 --- a/man/scale_shape.Rd +++ b/man/scale_shape.Rd @@ -8,9 +8,9 @@ \alias{scale_shape_continuous} \title{Scales for shapes, aka glyphs} \usage{ -scale_shape(name = waiver(), ..., solid = TRUE) +scale_shape(name = waiver(), ..., solid = NULL, aesthetics = "shape") -scale_shape_binned(name = waiver(), ..., solid = TRUE) +scale_shape_binned(name = waiver(), ..., solid = TRUE, aesthetics = "shape") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -21,9 +21,6 @@ omitted.} \item{...}{ Arguments passed on to \code{\link[=discrete_scale]{discrete_scale}} \describe{ - \item{\code{palette}}{A palette function that when called with a single integer -argument (the number of levels in the scale) returns the values that -they should take (e.g., \code{\link[scales:pal_hue]{scales::pal_hue()}}).} \item{\code{breaks}}{One of: \itemize{ \item \code{NULL} for no breaks @@ -52,8 +49,20 @@ from a discrete scale, specify \code{na.translate = FALSE}.} \item{\code{na.value}}{If \code{na.translate = TRUE}, what aesthetic value should the missing values be displayed as? Does not apply to position scales where \code{NA} is always placed at the far right.} - \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} - \item{\code{labels}}{One of: + \item{\code{minor_breaks}}{One of: +\itemize{ +\item \code{NULL} for no minor breaks +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) +\item A numeric vector of positions +\item A function that given the limits returns a vector of minor breaks. Also +accepts rlang \link[rlang:as_function]{lambda} function notation. When +the function has two arguments, it will be given the limits and major +break positions. +}} + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -72,6 +81,8 @@ notation. \item{solid}{Should the shapes be solid, \code{TRUE}, or hollow, \code{FALSE}?} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ \code{scale_shape()} maps discrete variables to six easily discernible shapes. @@ -81,6 +92,13 @@ seventh and subsequent levels will not appear on the plot. Use a continuous variable to shape unless \code{scale_shape_binned()} is used. Still, as shape has no inherent order, this use is not advised. } +\details{ +Shapes can be referred to by number or name. Shapes in [0, 20] do not +support a fill aesthetic, whereas shapes in [21, 25] do. + +\if{html}{\figure{shape_table.svg}{All shapes by number and name}} +\if{latex}{\figure{shape_table.pdf}} +} \examples{ set.seed(596) dsmall <- diamonds[sample(nrow(diamonds), 100), ] diff --git a/man/scale_size.Rd b/man/scale_size.Rd index c1c7d8dd05..0756ed4483 100644 --- a/man/scale_size.Rd +++ b/man/scale_size.Rd @@ -18,10 +18,11 @@ scale_size( breaks = waiver(), labels = waiver(), limits = NULL, - range = c(1, 6), + range = NULL, transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "size" ) scale_radius( @@ -32,7 +33,8 @@ scale_radius( range = c(1, 6), transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "size" ) scale_size_binned( @@ -40,17 +42,18 @@ scale_size_binned( breaks = waiver(), labels = waiver(), limits = NULL, - range = c(1, 6), + range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", trans = deprecated(), - guide = "bins" + guide = "bins", + aesthetics = "size" ) -scale_size_area(name = waiver(), ..., max_size = 6) +scale_size_area(name = waiver(), ..., max_size = 6, aesthetics = "size") -scale_size_binned_area(name = waiver(), ..., max_size = 6) +scale_size_binned_area(name = waiver(), ..., max_size = 6, aesthetics = "size") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -70,7 +73,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the @@ -117,6 +122,8 @@ You can create your own transformation with \code{\link[scales:new_transform]{sc \item{guide}{A function used to create a guide or its name. See \code{\link[=guides]{guides()}} for more information.} +\item{aesthetics}{The names of the aesthetics that this scale works with.} + \item{n.breaks}{An integer guiding the number of major breaks. The algorithm may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default @@ -134,13 +141,13 @@ breaks are given explicitly.} \item{\code{minor_breaks}}{One of: \itemize{ \item \code{NULL} for no minor breaks -\item \code{waiver()} for the default breaks (one minor break between -each major break) +\item \code{waiver()} for the default breaks (none for discrete, one minor break +between each major break for continuous) \item A numeric vector of positions \item A function that given the limits returns a vector of minor breaks. Also accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major -breaks. +break positions. }} \item{\code{oob}}{One of: \itemize{ diff --git a/man/scale_steps.Rd b/man/scale_steps.Rd index 1206c159f9..9f6740a561 100644 --- a/man/scale_steps.Rd +++ b/man/scale_steps.Rd @@ -129,7 +129,9 @@ as output (e.g., a function returned by \code{\link[scales:breaks_extended]{scal Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/sec_axis.Rd b/man/sec_axis.Rd index c3e273f7f3..e54bbf502c 100644 --- a/man/sec_axis.Rd +++ b/man/sec_axis.Rd @@ -16,7 +16,7 @@ sec_axis( ) dup_axis( - transform = ~., + transform = identity, name = derive(), breaks = derive(), labels = derive(), diff --git a/man/geom_errorbarh.Rd b/man/stat_connect.Rd similarity index 62% rename from man/geom_errorbarh.Rd rename to man/stat_connect.Rd index f72ccd5a2a..24166744d8 100644 --- a/man/geom_errorbarh.Rd +++ b/man/stat_connect.Rd @@ -1,15 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-errorbarh.R -\name{geom_errorbarh} -\alias{geom_errorbarh} -\title{Horizontal error bars} +% Please edit documentation in R/stat-connect.R +\name{stat_connect} +\alias{stat_connect} +\title{Connect observations} \usage{ -geom_errorbarh( +stat_connect( mapping = NULL, data = NULL, - stat = "identity", + geom = "path", position = "identity", ..., + connection = "hv", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE @@ -36,17 +37,17 @@ the plot data. The return value must be a \code{data.frame}, and will be used as the layer data. A \code{function} can be created from a \code{formula} (e.g. \code{~ head(.x, 10)}).} -\item{stat}{The statistical transformation to use on the data for this layer. -When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and -stats. The \code{stat} argument accepts the following: +\item{geom}{The geometric object to use to display the data for this layer. +When using a \verb{stat_*()} function to construct a layer, the \code{geom} argument +can be used to override the default coupling between stats and geoms. The +\code{geom} argument accepts the following: \itemize{ -\item A \code{Stat} ggproto subclass, for example \code{StatCount}. -\item A string naming the stat. To give the stat as a string, strip the -function name of the \code{stat_} prefix. For example, to use \code{stat_count()}, -give the stat as \code{"count"}. -\item For more information and other ways to specify the stat, see the -\link[=layer_stats]{layer stat} documentation. +\item A \code{Geom} ggproto subclass, for example \code{GeomPoint}. +\item A string naming the geom. To give the geom as a string, strip the +function name of the \code{geom_} prefix. For example, to use \code{geom_point()}, +give the geom as \code{"point"}. +\item For more information and other ways to specify the geom, see the +\link[=layer_geoms]{layer geom} documentation. }} \item{position}{A position adjustment to use on the data for this layer. This @@ -90,6 +91,22 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{connection}{A specification of how two points are connected. Can be one +of the folloing: +\itemize{ +\item A string giving a named connection. These options are: +\itemize{ +\item \code{"hv"} to first jump horizontally, then vertically. +\item \code{"vh"} to first jump vertically, then horizontally. +\item \code{"mid"} to step half-way between adjacent x-values. +\item \code{"linear"} to use a straight segment. +} +\item A numeric matrix with two columns giving x and y coordinates respectively. +The coordinates should describe points on a path that connect point A +at location (0, 0) and point B at location (1, 1). At least one of these +two points is expected to be included in the coordinates. +}} + \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} @@ -97,7 +114,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -105,41 +124,30 @@ that define both data and aesthetics and shouldn't inherit behaviour from the default plot specification, e.g. \code{\link[=borders]{borders()}}.} } \description{ -A rotated version of \code{\link[=geom_errorbar]{geom_errorbar()}}. +Connect successive points with lines of different shapes. } \section{Aesthetics}{ -\code{geom_errorbarh()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{xmin}}} -\item \strong{\code{\link[=aes_position]{xmax}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_colour_fill_alpha]{alpha}} -\item \code{\link[=aes_colour_fill_alpha]{colour}} -\item \code{\link[=aes_group_order]{group}} -\item \code{height} -\item \code{\link[=aes_linetype_size_shape]{linetype}} -\item \code{\link[=aes_linetype_size_shape]{linewidth}} +\code{stat_connect()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{xmin}} \emph{or} \code{\link[=aes_position]{xmax}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}} \emph{or} \code{\link[=aes_position]{ymin}} \emph{or} \code{\link[=aes_position]{ymax}}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } \examples{ -df <- data.frame( - trt = factor(c(1, 1, 2, 2)), - resp = c(1, 5, 3, 4), - group = factor(c(1, 2, 1, 2)), - se = c(0.1, 0.3, 0.3, 0.2) -) +ggplot(head(economics, 20), aes(date, unemploy)) + + stat_connect(connection = "hv") -# Define the top and bottom of the errorbars - -p <- ggplot(df, aes(resp, trt, colour = group)) -p + - geom_point() + - geom_errorbarh(aes(xmax = resp + se, xmin = resp - se)) +# Setup custom connections +x <- seq(0, 1, length.out = 20)[-1] +smooth <- cbind(x, scales::rescale(1 / (1 + exp(-(x * 10 - 5))))) +zigzag <- cbind(c(0.4, 0.6, 1), c(0.75, 0.25, 1)) -p + +ggplot(head(economics, 10), aes(date, unemploy)) + geom_point() + - geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2)) + stat_connect(aes(colour = "zigzag"), connection = zigzag) + + stat_connect(aes(colour = "smooth"), connection = smooth) } diff --git a/man/stat_ecdf.Rd b/man/stat_ecdf.Rd index 2a8e6c80e7..a341ce6543 100644 --- a/man/stat_ecdf.Rd +++ b/man/stat_ecdf.Rd @@ -105,7 +105,9 @@ a warning. If \code{TRUE} silently removes missing values.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -125,7 +127,22 @@ The statistic relies on the aesthetics assignment to guess which variable to use as the input and which to use as the output. Either x or y must be provided and one of them must be unused. The ECDF will be calculated on the given aesthetic and will be output on the unused one. + +If the \code{weight} aesthetic is provided, a weighted ECDF will be computed. In +this case, the ECDF is incremented by \code{weight / sum(weight)} instead of +\code{1 / length(x)} for each observation. +} +\section{Aesthetics}{ + +\code{stat_ecdf()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}} \emph{or} \code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{weight} \tab → \code{NULL} \cr\cr } +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \section{Computed variables}{ These are calculated by the 'stat' part of layers and can be accessed with \link[=aes_eval]{delayed evaluation}. @@ -135,6 +152,14 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Dropped variables}{ + +\describe{ +\item{weight}{After calculation, weights of individual observations (if +supplied), are no longer available.} +} +} + \examples{ set.seed(1) df <- data.frame( @@ -151,4 +176,15 @@ ggplot(df, aes(x)) + # Multiple ECDFs ggplot(df, aes(x, colour = g)) + stat_ecdf() + +# Using weighted eCDF +weighted <- data.frame(x = 1:10, weights = c(1:5, 5:1)) +plain <- data.frame(x = rep(weighted$x, weighted$weights)) + +ggplot(plain, aes(x)) + + stat_ecdf(linewidth = 1) + + stat_ecdf( + aes(weight = weights), + data = weighted, colour = "green" + ) } diff --git a/man/stat_ellipse.Rd b/man/stat_ellipse.Rd index f428b3fbac..ca8e448603 100644 --- a/man/stat_ellipse.Rd +++ b/man/stat_ellipse.Rd @@ -112,7 +112,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -123,6 +125,18 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} The method for calculating the ellipses has been modified from \code{car::dataEllipse} (Fox and Weisberg 2011, Friendly and Monette 2013) } +\section{Aesthetics}{ + +\code{stat_ellipse()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +• \tab \code{weight} \tab \cr\cr +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ ggplot(faithful, aes(waiting, eruptions)) + geom_point() + diff --git a/man/stat_identity.Rd b/man/stat_identity.Rd index 945eaafd87..f5dd6e1a5d 100644 --- a/man/stat_identity.Rd +++ b/man/stat_identity.Rd @@ -93,7 +93,9 @@ lists which parameters it can accept. \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions diff --git a/man/stat_manual.Rd b/man/stat_manual.Rd new file mode 100644 index 0000000000..de64b21a31 --- /dev/null +++ b/man/stat_manual.Rd @@ -0,0 +1,199 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stat-manual.R +\name{stat_manual} +\alias{stat_manual} +\title{Manually compute transformations} +\usage{ +stat_manual( + mapping = NULL, + data = NULL, + geom = "point", + position = "identity", + ..., + fun = identity, + args = list(), + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) +} +\arguments{ +\item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}}. If specified and +\code{inherit.aes = TRUE} (the default), it is combined with the default mapping +at the top level of the plot. You must supply \code{mapping} if there is no plot +mapping.} + +\item{data}{The data to be displayed in this layer. There are three +options: + +If \code{NULL}, the default, the data is inherited from the plot +data as specified in the call to \code{\link[=ggplot]{ggplot()}}. + +A \code{data.frame}, or other object, will override the plot +data. All objects will be fortified to produce a data frame. See +\code{\link[=fortify]{fortify()}} for which variables will be created. + +A \code{function} will be called with a single argument, +the plot data. The return value must be a \code{data.frame}, and +will be used as the layer data. A \code{function} can be created +from a \code{formula} (e.g. \code{~ head(.x, 10)}).} + +\item{geom}{The geometric object to use to display the data for this layer. +When using a \verb{stat_*()} function to construct a layer, the \code{geom} argument +can be used to override the default coupling between stats and geoms. The +\code{geom} argument accepts the following: +\itemize{ +\item A \code{Geom} ggproto subclass, for example \code{GeomPoint}. +\item A string naming the geom. To give the geom as a string, strip the +function name of the \code{geom_} prefix. For example, to use \code{geom_point()}, +give the geom as \code{"point"}. +\item For more information and other ways to specify the geom, see the +\link[=layer_geoms]{layer geom} documentation. +}} + +\item{position}{A position adjustment to use on the data for this layer. This +can be used in various ways, including to prevent overplotting and +improving the display. The \code{position} argument accepts the following: +\itemize{ +\item The result of calling a position function, such as \code{position_jitter()}. +This method allows for passing extra arguments to the position. +\item A string naming the position adjustment. To give the position as a +string, strip the function name of the \code{position_} prefix. For example, +to use \code{position_jitter()}, give the position as \code{"jitter"}. +\item For more information and other ways to specify the position, see the +\link[=layer_positions]{layer position} documentation. +}} + +\item{...}{Other arguments passed on to \code{\link[=layer]{layer()}}'s \code{params} argument. These +arguments broadly fall into one of 4 categories below. Notably, further +arguments to the \code{position} argument, or aesthetics that are required +can \emph{not} be passed through \code{...}. Unknown arguments that are not part +of the 4 categories below are ignored. +\itemize{ +\item Static aesthetics that are not mapped to a scale, but are at a fixed +value and apply to the layer as a whole. For example, \code{colour = "red"} +or \code{linewidth = 3}. The geom's documentation has an \strong{Aesthetics} +section that lists the available options. The 'required' aesthetics +cannot be passed on to the \code{params}. Please note that while passing +unmapped aesthetics as vectors is technically possible, the order and +required length is not guaranteed to be parallel to the input data. +\item When constructing a layer using +a \verb{stat_*()} function, the \code{...} argument can be used to pass on +parameters to the \code{geom} part of the layer. An example of this is +\code{stat_density(geom = "area", outline.type = "both")}. The geom's +documentation lists which parameters it can accept. +\item Inversely, when constructing a layer using a +\verb{geom_*()} function, the \code{...} argument can be used to pass on parameters +to the \code{stat} part of the layer. An example of this is +\code{geom_area(stat = "density", adjust = 0.5)}. The stat's documentation +lists which parameters it can accept. +\item The \code{key_glyph} argument of \code{\link[=layer]{layer()}} may also be passed on through +\code{...}. This can be one of the functions described as +\link[=draw_key]{key glyphs}, to change the display of the layer in the legend. +}} + +\item{fun}{Function that takes a data frame as input and returns a data +frame or data frame-like list as output. The default (\code{identity()}) returns +the data unchanged.} + +\item{args}{A list of arguments to pass to the function given in \code{fun}.} + +\item{na.rm}{If \code{FALSE}, the default, missing values are removed with +a warning. If \code{TRUE}, missing values are silently removed.} + +\item{show.legend}{logical. Should this layer be included in the legends? +\code{NA}, the default, includes if any aesthetics are mapped. +\code{FALSE} never includes, and \code{TRUE} always includes. +It can also be a named logical vector to finely select the aesthetics to +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} + +\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, +rather than combining with them. This is most useful for helper functions +that define both data and aesthetics and shouldn't inherit behaviour from +the default plot specification, e.g. \code{\link[=borders]{borders()}}.} +} +\description{ +\code{stat_manual()} takes a function that computes a data transformation for +every group. +} +\section{Aesthetics}{ + +\code{stat_manual()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. + + +Input aesthetics are determined by the \code{fun} argument. Output aesthetics must +include those required by \code{geom}. Any aesthetic that is constant within a +group will be preserved even if dropped by \code{fun}. +} + +\examples{ +# A standard scatterplot +p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + + geom_point() + +# The default just displays points as-is +p + stat_manual() + +# Using a custom function +make_hull <- function(data) { + hull <- chull(x = data$x, y = data$y) + data.frame(x = data$x[hull], y = data$y[hull]) +} + +p + stat_manual( + geom = "polygon", + fun = make_hull, + fill = NA +) + +# Using the `with` function with quoting +p + stat_manual( + fun = with, + args = list(expr = quote({ + hull <- chull(x, y) + list(x = x[hull], y = y[hull]) + })), + geom = "polygon", fill = NA +) + +# Using the `transform` function with quoting +p + stat_manual( + geom = "segment", + fun = transform, + args = list( + xend = quote(mean(x)), + yend = quote(mean(y)) + ) +) + +# Using dplyr verbs with `vars()` +if (requireNamespace("dplyr", quietly = TRUE)) { + + # Get centroids with `summarise()` + p + stat_manual( + size = 10, shape = 21, + fun = dplyr::summarise, + args = vars(x = mean(x), y = mean(y)) + ) + + # Connect to centroid with `mutate` + p + stat_manual( + geom = "segment", + fun = dplyr::mutate, + args = vars(xend = mean(x), yend = mean(y)) + ) + + # Computing hull with `reframe()` + p + stat_manual( + geom = "polygon", fill = NA, + fun = dplyr::reframe, + args = vars(hull = chull(x, y), x = x[hull], y = y[hull]) + ) +} +} diff --git a/man/stat_sf_coordinates.Rd b/man/stat_sf_coordinates.Rd index 35ce136a6c..1a8aef4440 100644 --- a/man/stat_sf_coordinates.Rd +++ b/man/stat_sf_coordinates.Rd @@ -72,7 +72,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions diff --git a/man/stat_summary.Rd b/man/stat_summary.Rd index 034e11afdb..20326b840f 100644 --- a/man/stat_summary.Rd +++ b/man/stat_summary.Rd @@ -135,10 +135,9 @@ single number.} \item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} \item{binwidth}{The width of the bins. Can be specified as a numeric value -or as a function that calculates width from unscaled x. Here, "unscaled x" -refers to the original x values in the data, before application of any -scale transformation. When specifying a function along with a grouping -structure, the function will be called once per group. +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. The default is to use the number of bins in \code{bins}, covering the range of the data. You should always override this value, exploring multiple widths to find the best to illustrate the @@ -162,7 +161,9 @@ to either \code{"x"} or \code{"y"}. See the \emph{Orientation} section for more \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -185,11 +186,11 @@ This geom treats each axis differently and, thus, can thus have two orientations \section{Aesthetics}{ -\code{stat_summary()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \strong{\code{\link[=aes_position]{x}}} -\item \strong{\code{\link[=aes_position]{y}}} -\item \code{\link[=aes_group_order]{group}} +\code{stat_summary()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \strong{\code{\link[=aes_position]{x}}} \tab \cr\cr +• \tab \strong{\code{\link[=aes_position]{y}}} \tab \cr\cr +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/stat_summary_2d.Rd b/man/stat_summary_2d.Rd index 464cdeacc3..da62dd0a15 100644 --- a/man/stat_summary_2d.Rd +++ b/man/stat_summary_2d.Rd @@ -113,11 +113,19 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} \item{drop}{drop if the output of \code{fun} is \code{NA}.} @@ -132,7 +140,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -171,6 +181,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins}, \code{binwidth}, \code{breaks}, \code{center}, and \code{boundary} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(carat, depth, z = price)) d + stat_summary_2d() diff --git a/man/stat_unique.Rd b/man/stat_unique.Rd index 89a7e728b5..717b49e36c 100644 --- a/man/stat_unique.Rd +++ b/man/stat_unique.Rd @@ -97,7 +97,9 @@ a warning. If \code{TRUE}, missing values are silently removed.} \code{NA}, the default, includes if any aesthetics are mapped. \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to -display.} +display. To include legend keys for all levels, even +when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, +but unobserved levels are omitted.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, rather than combining with them. This is most useful for helper functions @@ -109,9 +111,9 @@ Remove duplicates } \section{Aesthetics}{ -\code{stat_unique()} understands the following aesthetics (required aesthetics are in bold): -\itemize{ -\item \code{\link[=aes_group_order]{group}} +\code{stat_unique()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: +\tabular{rll}{ +• \tab \code{\link[=aes_group_order]{group}} \tab → inferred \cr\cr } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/subtheme.Rd b/man/subtheme.Rd new file mode 100644 index 0000000000..a05a98a54c --- /dev/null +++ b/man/subtheme.Rd @@ -0,0 +1,159 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme-sub.R +\name{subtheme} +\alias{subtheme} +\alias{theme_sub_axis} +\alias{theme_sub_axis_x} +\alias{theme_sub_axis_y} +\alias{theme_sub_axis_bottom} +\alias{theme_sub_axis_top} +\alias{theme_sub_axis_left} +\alias{theme_sub_axis_right} +\alias{theme_sub_legend} +\alias{theme_sub_panel} +\alias{theme_sub_plot} +\alias{theme_sub_strip} +\title{Shortcuts for theme settings} +\usage{ +theme_sub_axis(title, text, ticks, ticks.length, line) + +theme_sub_axis_x(title, text, ticks, ticks.length, line) + +theme_sub_axis_y(title, text, ticks, ticks.length, line) + +theme_sub_axis_bottom(title, text, ticks, ticks.length, line) + +theme_sub_axis_top(title, text, ticks, ticks.length, line) + +theme_sub_axis_left(title, text, ticks, ticks.length, line) + +theme_sub_axis_right(title, text, ticks, ticks.length, line) + +theme_sub_legend( + background, + margin, + spacing, + spacing.x, + spacing.y, + key, + key.size, + key.height, + key.width, + text, + title, + position, + direction, + justification, + box, + box.just, + box.margin, + box.background, + box.spacing +) + +theme_sub_panel( + background, + border, + 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_plot( + background, + title, + title.position, + subtitle, + caption, + caption.position, + tag, + tag.position, + tag.location, + margin +) + +theme_sub_strip( + 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 +) +} +\arguments{ +\item{background, background.x, background.y, border, box, box.background, box.just, box.margin, box.spacing, caption, caption.position, clip, direction, grid, grid.major, grid.major.x, grid.major.y, grid.minor, grid.minor.x, grid.minor.y, justification, key, key.height, key.size, key.width, line, margin, ontop, placement, position, spacing, spacing.x, spacing.y, subtitle, switch.pad.grid, switch.pad.wrap, tag, tag.location, tag.position, text, text.x, text.x.bottom, text.x.top, text.y, text.y.left, text.y.right, ticks, ticks.length, title, title.position}{Arguments that are renamed and passed on to \code{\link[=theme]{theme()}}.} +} +\value{ +A \code{theme}-class object that can be added to a plot. +} +\description{ +This collection of functions serves as a shortcut for \code{\link[=theme]{theme()}} with +shorter argument names. Besides the shorter arguments, it also helps in +keeping theme declarations more organised. +} +\section{Functions}{ +\itemize{ +\item \code{theme_sub_axis()}: Theme specification for all axes. + +\item \code{theme_sub_axis_x()}: Theme specification for both x axes. + +\item \code{theme_sub_axis_y()}: Theme specification for both y axes. + +\item \code{theme_sub_axis_bottom()}: Theme specification for the bottom x axis. + +\item \code{theme_sub_axis_top()}: Theme specification for the top x axis. + +\item \code{theme_sub_axis_left()}: Theme specification for the left y axis. + +\item \code{theme_sub_axis_right()}: Theme specification for the right y axis. + +\item \code{theme_sub_legend()}: Theme specification for the legend. + +\item \code{theme_sub_panel()}: Theme specification for the panels. + +\item \code{theme_sub_plot()}: Theme specification for the whole plot. + +\item \code{theme_sub_strip()}: Theme specification for facet strips. + +}} +\examples{ +# A standard plot +p <- ggplot(mtcars, aes(disp, mpg, colour = drat)) + + geom_point() + +red_text <- element_text(colour = "red") +red_line <- element_line(colour = "red") + +# The theme settings below: +p + theme( + axis.title.x.bottom = red_text, + axis.text.x.bottom = red_text, + axis.line.x.bottom = red_line, + axis.ticks.x.bottom = red_line +) + +# Are equivalent to these less verbose theme settings +p + theme_sub_axis_bottom( + title = red_text, + text = red_text, + line = red_line, + ticks = red_line +) +} diff --git a/man/theme.Rd b/man/theme.Rd index 5d51fd8643..2766a3f8ca 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -10,6 +10,11 @@ theme( rect, text, title, + point, + polygon, + geom, + spacing, + margins, aspect.ratio, axis.title, axis.title.x, @@ -81,6 +86,7 @@ theme( legend.key.spacing, legend.key.spacing.x, legend.key.spacing.y, + legend.key.justification, legend.frame, legend.ticks, legend.ticks.length, @@ -118,6 +124,8 @@ theme( panel.grid.minor.x, panel.grid.minor.y, panel.ontop, + panel.widths, + panel.heights, plot.background, plot.title, plot.title.position, @@ -159,6 +167,16 @@ these should also be defined in the \verb{element tree} argument. \link[rlang:sp \item{title}{all title elements: plot, axes, legends (\code{\link[=element_text]{element_text()}}; inherits from \code{text})} +\item{point}{all point elements (\code{\link[=element_point]{element_point()}})} + +\item{polygon}{all polygon elements (\code{\link[=element_polygon]{element_polygon()}})} + +\item{geom}{defaults for geoms (\code{\link[=element_geom]{element_geom()}})} + +\item{spacing}{all spacings (\code{\link[grid:unit]{unit()}})} + +\item{margins}{all margins (\code{\link[=margin]{margin()}})} + \item{aspect.ratio}{aspect ratio of the panel} \item{axis.title, axis.title.x, axis.title.y, axis.title.x.top, axis.title.x.bottom, axis.title.y.left, axis.title.y.right}{labels of axes (\code{\link[=element_text]{element_text()}}). Specify all axes' labels (\code{axis.title}), @@ -185,7 +203,7 @@ from \code{line}} \item{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, }{minor tick marks along axes (\code{\link[=element_line]{element_line()}}). \verb{axis.minor.ticks.*.*} inherit from the corresponding major ticks \verb{axis.ticks.*.*}.} -\item{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}{length of tick marks (\code{unit})} +\item{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}{length of tick marks (\code{unit}). \code{axis.ticks.length} inherits from \code{spacing}.} \item{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}{length of minor tick marks (\code{unit}), or relative to \code{axis.ticks.length} when provided with \code{rel()}.} @@ -199,27 +217,36 @@ from \code{line}} \item{legend.background}{background of legend (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect})} -\item{legend.margin}{the margin around each legend (\code{\link[=margin]{margin()}})} +\item{legend.margin}{the margin around each legend (\code{\link[=margin]{margin()}}); inherits +from \code{margins}.} \item{legend.spacing, legend.spacing.x, legend.spacing.y}{the spacing between legends (\code{unit}). \code{legend.spacing.x} & \code{legend.spacing.y} -inherit from \code{legend.spacing} or can be specified separately} +inherit from \code{legend.spacing} or can be specified separately. +\code{legend.spacing} inherits from \code{spacing}.} \item{legend.key}{background underneath legend keys (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect})} \item{legend.key.size, legend.key.height, legend.key.width}{size of legend keys (\code{unit}); key background height & width inherit from -\code{legend.key.size} or can be specified separately} +\code{legend.key.size} or can be specified separately. In turn \code{legend.key.size} +inherits from \code{spacing}.} \item{legend.key.spacing, legend.key.spacing.x, legend.key.spacing.y}{spacing between legend keys given as a \code{unit}. Spacing in the horizontal (x) and vertical (y) direction inherit from \code{legend.key.spacing} or can be -specified separately.} +specified separately. \code{legend.key.spacing} inherits from \code{spacing}.} + +\item{legend.key.justification}{Justification for positioning legend keys +when more space is available than needed for display. The default, \code{NULL}, +stretches keys into the available space. Can be a location like \code{"center"} +or \code{"top"}, or a two-element numeric vector.} \item{legend.frame}{frame drawn around the bar (\code{\link[=element_rect]{element_rect()}}).} \item{legend.ticks}{tick marks shown along bars or axes (\code{\link[=element_line]{element_line()}})} -\item{legend.ticks.length}{length of tick marks in legend (\code{unit})} +\item{legend.ticks.length}{length of tick marks in legend +(\code{\link[grid:unit]{unit()}}); inherits from \code{legend.key.size}.} \item{legend.axis.line}{lines along axes in legends (\code{\link[=element_line]{element_line()}})} @@ -262,17 +289,17 @@ string. Can be \code{"panel"} (default) to align legends to the panels or "vertical")} \item{legend.box.just}{justification of each legend within the overall -bounding box, when there are multiple legends ("top", "bottom", "left", or -"right")} +bounding box, when there are multiple legends ("top", "bottom", "left", +"right", "center" or "centre")} \item{legend.box.margin}{margins around the full legend area, as specified -using \code{\link[=margin]{margin()}}} +using \code{\link[=margin]{margin()}}; inherits from \code{margins}.} \item{legend.box.background}{background of legend area (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect})} \item{legend.box.spacing}{The spacing between the plotting area and the -legend box (\code{unit})} +legend box (\code{unit}); inherits from \code{spacing}.} \item{panel.background}{background of plotting area, drawn underneath plot (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect})} @@ -284,7 +311,7 @@ it covers tick marks and grid lines. This should be used with \item{panel.spacing, panel.spacing.x, panel.spacing.y}{spacing between facet panels (\code{unit}). \code{panel.spacing.x} & \code{panel.spacing.y} inherit from \code{panel.spacing} -or can be specified separately.} +or can be specified separately. \code{panel.spacing} inherits from \code{spacing}.} \item{panel.grid, panel.grid.major, panel.grid.minor, panel.grid.major.x, panel.grid.major.y, panel.grid.minor.x, panel.grid.minor.y}{grid lines (\code{\link[=element_line]{element_line()}}). Specify major grid lines, or minor grid lines separately (using \code{panel.grid.major} or \code{panel.grid.minor}) @@ -298,6 +325,10 @@ from \code{line}} the data layers (\code{logical}). Usually used with a transparent or blank \code{panel.background}.} +\item{panel.widths, panel.heights}{Sizes for panels (\code{units}). Can be a +single unit to set the total size for the panel area, or a unit vector to +set the size of individual panels.} + \item{plot.background}{background of the entire plot (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect})} @@ -332,7 +363,7 @@ inside the panel space, anywhere in the plot as a whole, or in the margin around the panel space.} \item{plot.margin}{margin around entire plot (\code{unit} with the sizes of -the top, right, bottom, and left margins)} +the top, right, bottom, and left margins); inherits from \code{margin}.} \item{strip.background, strip.background.x, strip.background.y}{background of facet labels (\code{\link[=element_rect]{element_rect()}}; inherits from \code{rect}). Horizontal facet background (\code{strip.background.x}) @@ -356,11 +387,8 @@ that inherit from \code{strip.text.x} and \code{strip.text.y}, respectively. As a consequence, some theme stylings need to be applied to the position-dependent elements rather than to the parent elements} -\item{strip.switch.pad.grid}{space between strips and axes when strips are -switched (\code{unit})} - -\item{strip.switch.pad.wrap}{space between strips and axes when strips are -switched (\code{unit})} +\item{strip.switch.pad.grid, strip.switch.pad.wrap}{space between strips and +axes when strips are switched (\code{unit}); inherits from \code{spacing}.} \item{complete}{set this to \code{TRUE} if this is a complete theme, such as the one returned by \code{\link[=theme_grey]{theme_grey()}}. Complete themes behave @@ -368,7 +396,7 @@ differently when added to a ggplot object. Also, when setting \code{complete = TRUE} all elements will be set to inherit from blank elements.} -\item{validate}{\code{TRUE} to run \code{validate_element()}, \code{FALSE} to bypass checks.} +\item{validate}{\code{TRUE} to run \code{check_element()}, \code{FALSE} to bypass checks.} } \description{ Themes are a powerful way to customize the non-data components of your plots: @@ -405,7 +433,7 @@ p1 + theme(plot.background = element_rect(fill = "green")) # Panels -------------------------------------------------------------------- p1 + theme(panel.background = element_rect(fill = "white", colour = "grey50")) -p1 + theme(panel.border = element_rect(linetype = "dashed", fill = NA)) +p1 + theme(panel.border = element_rect(linetype = "dashed")) p1 + theme(panel.grid.major = element_line(colour = "black")) p1 + theme( panel.grid.major.y = element_blank(), @@ -459,14 +487,14 @@ p2 + theme( legend.position.inside = c(.95, .95), legend.justification = c("right", "top"), legend.box.just = "right", - legend.margin = margin(6, 6, 6, 6) + legend.margin = margin_auto(6) ) # The legend.box properties work similarly for the space around # all the legends p2 + theme( legend.box.background = element_rect(), - legend.box.margin = margin(6, 6, 6, 6) + legend.box.margin = margin_auto(6) ) # You can also control the display of the keys diff --git a/man/translate_shape_string.Rd b/man/translate_shape_string.Rd index f6d205cf79..cbbcad05a7 100644 --- a/man/translate_shape_string.Rd +++ b/man/translate_shape_string.Rd @@ -7,7 +7,8 @@ translate_shape_string(shape_string) } \arguments{ -\item{shape_string}{A character vector giving point shapes.} +\item{shape_string}{A character vector giving point shapes. Non-character +input will be returned.} } \value{ An integer vector with translated shapes. diff --git a/man/update_defaults.Rd b/man/update_defaults.Rd index e009b99d32..9620dde4e1 100644 --- a/man/update_defaults.Rd +++ b/man/update_defaults.Rd @@ -3,21 +3,45 @@ \name{update_geom_defaults} \alias{update_geom_defaults} \alias{update_stat_defaults} +\alias{reset_geom_defaults} +\alias{reset_stat_defaults} \title{Modify geom/stat aesthetic defaults for future plots} \usage{ update_geom_defaults(geom, new) update_stat_defaults(stat, new) + +reset_geom_defaults() + +reset_stat_defaults() } \arguments{ -\item{new}{Named list of aesthetics.} +\item{new}{One of the following: +\itemize{ +\item A named list of aesthetics to serve as new defaults. +\item \code{NULL} to reset the defaults. +}} \item{stat, geom}{Name of geom/stat to modify (like \code{"point"} or \code{"bin"}), or a Geom/Stat object (like \code{GeomPoint} or \code{StatBin}).} } \description{ -Modify geom/stat aesthetic defaults for future plots +Functions to update or reset the default aesthetics of geoms and stats. +} +\note{ +Please note that geom defaults can be set \emph{en masse} via the \code{theme(geom)} +argument. The guidelines for when to use which function are as follows: +\itemize{ +\item If you want to change defaults for all geoms in all plots, use +\code{theme_update(geom = element_geom(...))}. +\item If you want to change defaults for all geoms in a single plot, use +\code{+ theme(geom = element_geom(...))}. +\item If you want to change defaults for one geom in all plots, use +\code{update_geom_defaults()}. +\item If you want to change settings for one geom in a single plot, use fixed +aesthetic parameters in a layer, like so: \code{geom_point(colour = "red")}. +} } \examples{ @@ -28,9 +52,11 @@ update_geom_defaults("point", aes(color = "red")) GeomPoint$default_aes ggplot(mtcars, aes(mpg, wt)) + geom_point() -# reset default -update_geom_defaults("point", aes(color = "black")) +# reset single default +update_geom_defaults("point", NULL) +# reset all defaults +reset_geom_defaults() # updating a stat's default aesthetic settings # example: change stat_bin()'s default y-axis to the density scale @@ -41,8 +67,11 @@ ggplot(data.frame(x = rnorm(1e3)), aes(x)) + geom_histogram() + geom_function(fun = dnorm, color = "red") -# reset default -update_stat_defaults("bin", aes(y = after_stat(count))) +# reset single default +update_stat_defaults("bin", NULL) + +# reset all defaults +reset_stat_defaults() } \keyword{internal} diff --git a/man/waiver.Rd b/man/waiver.Rd index aeb97bf082..88fa06ba57 100644 --- a/man/waiver.Rd +++ b/man/waiver.Rd @@ -2,14 +2,21 @@ % Please edit documentation in R/utilities.R \name{waiver} \alias{waiver} +\alias{is.waiver} \title{A waiver object.} \usage{ waiver() + +is.waiver(x) +} +\arguments{ +\item{x}{An object to test} } \description{ A waiver is a "flag" object, similar to \code{NULL}, that indicates the calling function should just use the default value. It is used in certain functions to distinguish between displaying nothing (\code{NULL}) and -displaying a default value calculated elsewhere (\code{waiver()}) +displaying a default value calculated elsewhere (\code{waiver()}). +\code{is.waiver()} reports whether an object is a waiver. } \keyword{internal} diff --git a/pkgdown/favicon/apple-touch-icon-120x120.png b/pkgdown/favicon/apple-touch-icon-120x120.png index 2b84be21c5..aaa98f91e1 100644 Binary files a/pkgdown/favicon/apple-touch-icon-120x120.png and b/pkgdown/favicon/apple-touch-icon-120x120.png differ diff --git a/pkgdown/favicon/apple-touch-icon-152x152.png b/pkgdown/favicon/apple-touch-icon-152x152.png index 3f945a4062..e5bbb71635 100644 Binary files a/pkgdown/favicon/apple-touch-icon-152x152.png and b/pkgdown/favicon/apple-touch-icon-152x152.png differ diff --git a/pkgdown/favicon/apple-touch-icon-180x180.png b/pkgdown/favicon/apple-touch-icon-180x180.png index 4ad0be3c60..aa497088f6 100644 Binary files a/pkgdown/favicon/apple-touch-icon-180x180.png and b/pkgdown/favicon/apple-touch-icon-180x180.png differ diff --git a/pkgdown/favicon/apple-touch-icon-60x60.png b/pkgdown/favicon/apple-touch-icon-60x60.png index fd883b3746..399c898d28 100644 Binary files a/pkgdown/favicon/apple-touch-icon-60x60.png and b/pkgdown/favicon/apple-touch-icon-60x60.png differ diff --git a/pkgdown/favicon/apple-touch-icon-76x76.png b/pkgdown/favicon/apple-touch-icon-76x76.png index 02dfd253c0..8955cb9bdc 100644 Binary files a/pkgdown/favicon/apple-touch-icon-76x76.png and b/pkgdown/favicon/apple-touch-icon-76x76.png differ diff --git a/pkgdown/favicon/apple-touch-icon.png b/pkgdown/favicon/apple-touch-icon.png index 4ad0be3c60..74c6511d61 100644 Binary files a/pkgdown/favicon/apple-touch-icon.png and b/pkgdown/favicon/apple-touch-icon.png differ diff --git a/pkgdown/favicon/favicon-16x16.png b/pkgdown/favicon/favicon-16x16.png index 8ced81e9e2..aa7171cc1e 100644 Binary files a/pkgdown/favicon/favicon-16x16.png and b/pkgdown/favicon/favicon-16x16.png differ diff --git a/pkgdown/favicon/favicon-32x32.png b/pkgdown/favicon/favicon-32x32.png index 65a9dbd952..34c18fb656 100644 Binary files a/pkgdown/favicon/favicon-32x32.png and b/pkgdown/favicon/favicon-32x32.png differ diff --git a/pkgdown/favicon/favicon-48x48.png b/pkgdown/favicon/favicon-48x48.png new file mode 100644 index 0000000000..f554a3a108 Binary files /dev/null and b/pkgdown/favicon/favicon-48x48.png differ diff --git a/pkgdown/favicon/favicon.ico b/pkgdown/favicon/favicon.ico index 0134e2eee7..1d64806627 100644 Binary files a/pkgdown/favicon/favicon.ico and b/pkgdown/favicon/favicon.ico differ diff --git a/pkgdown/favicon/favicon.svg b/pkgdown/favicon/favicon.svg new file mode 100644 index 0000000000..37c061c7fa --- /dev/null +++ b/pkgdown/favicon/favicon.svg @@ -0,0 +1,3 @@ + \ No newline at end of file diff --git a/pkgdown/favicon/site.webmanifest b/pkgdown/favicon/site.webmanifest new file mode 100644 index 0000000000..4ebda26b53 --- /dev/null +++ b/pkgdown/favicon/site.webmanifest @@ -0,0 +1,21 @@ +{ + "name": "", + "short_name": "", + "icons": [ + { + "src": "/web-app-manifest-192x192.png", + "sizes": "192x192", + "type": "image/png", + "purpose": "maskable" + }, + { + "src": "/web-app-manifest-512x512.png", + "sizes": "512x512", + "type": "image/png", + "purpose": "maskable" + } + ], + "theme_color": "#ffffff", + "background_color": "#ffffff", + "display": "standalone" +} \ No newline at end of file diff --git a/pkgdown/favicon/web-app-manifest-192x192.png b/pkgdown/favicon/web-app-manifest-192x192.png new file mode 100644 index 0000000000..dbfb8f092c Binary files /dev/null and b/pkgdown/favicon/web-app-manifest-192x192.png differ diff --git a/pkgdown/favicon/web-app-manifest-512x512.png b/pkgdown/favicon/web-app-manifest-512x512.png new file mode 100644 index 0000000000..0ac228e793 Binary files /dev/null and b/pkgdown/favicon/web-app-manifest-512x512.png differ diff --git a/tests/testthat/_snaps/aes-calculated.md b/tests/testthat/_snaps/aes-calculated.md index 629d2007d5..cd3424516b 100644 --- a/tests/testthat/_snaps/aes-calculated.md +++ b/tests/testthat/_snaps/aes-calculated.md @@ -6,6 +6,14 @@ Duplicated aesthetics after name standardisation: colour +# calculated aesthetics throw warnings when lengths mismatch + + Failed to apply `after_stat()` for the following aesthetic: colour. + +--- + + Failed to apply `after_scale()` for the following aesthetic: colour. + # A deprecated warning is issued when stat(var) or ..var.. is used `stat(foo)` was deprecated in ggplot2 3.4.0. diff --git a/tests/testthat/_snaps/aes-setting.md b/tests/testthat/_snaps/aes-setting.md new file mode 100644 index 0000000000..b0ba47a52a --- /dev/null +++ b/tests/testthat/_snaps/aes-setting.md @@ -0,0 +1,36 @@ +# aesthetic parameters match length of data + + Code + set_colours(rep("red", 2)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + +--- + + Code + set_colours(rep("red", 3)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + +--- + + Code + set_colours(rep("red", 4)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + diff --git a/tests/testthat/_snaps/aes.md b/tests/testthat/_snaps/aes.md index 7f7f3ddc89..4a891eacbe 100644 --- a/tests/testthat/_snaps/aes.md +++ b/tests/testthat/_snaps/aes.md @@ -1,3 +1,43 @@ +# accessing an undefined variable results in an error + + Code + get_layer_data(p) + Condition + Error in `geom_point()`: + ! Problem while computing aesthetics. + i Error occurred in the 1st layer. + Caused by error: + ! object 'foo' not found + +# aes standardises aesthetic names + + Duplicated aesthetics after name standardisation: colour + +# warn_for_aes_extract_usage() warns for discouraged uses of $ and [[ within aes() + + Use of `df$x` is discouraged. + i Use `x` instead. + +--- + + Use of `df[["x"]]` is discouraged. + i Use `.data[["x"]]` instead. + +--- + + Use of `df$x` is discouraged. + i Use `x` instead. + +# warn_for_aes_extract_usage() does not evaluate function calls + + Use of `df$x` is discouraged. + i Use `x` instead. + +# Warnings are issued when plots use discouraged extract usage within aes() + + Use of `df$x` is discouraged. + i Use `x` instead. + # aes evaluation fails with unknown input Unknown input: diff --git a/tests/testthat/_snaps/annotate.md b/tests/testthat/_snaps/annotate.md index 23c8e0df43..abf4bb83e7 100644 --- a/tests/testthat/_snaps/annotate.md +++ b/tests/testthat/_snaps/annotate.md @@ -2,14 +2,14 @@ Problem while converting geom to grob. i Error occurred in the 1st layer. - Caused by error in `draw_panel()`: + Caused by error in `ranges_annotation()`: ! `annotation_raster()` only works with `coord_cartesian()`. --- Problem while converting geom to grob. i Error occurred in the 1st layer. - Caused by error in `draw_panel()`: + Caused by error in `ranges_annotation()`: ! `annotation_custom()` only works with `coord_cartesian()`. # annotation_map() checks the input data diff --git a/tests/testthat/_snaps/compat-plyr.md b/tests/testthat/_snaps/compat-plyr.md deleted file mode 100644 index d31d586cc8..0000000000 --- a/tests/testthat/_snaps/compat-plyr.md +++ /dev/null @@ -1,16 +0,0 @@ -# input checks work in compat functions - - Can only remove rownames from and objects. - ---- - - `x` must be a factor or character vector, not an integer vector. - ---- - - Must be a character vector, call, or formula. - ---- - - `x` must be a vector, not a character vector. - diff --git a/tests/testthat/_snaps/coord-.md b/tests/testthat/_snaps/coord-.md index c4f74d626c..563c7f475d 100644 --- a/tests/testthat/_snaps/coord-.md +++ b/tests/testthat/_snaps/coord-.md @@ -18,3 +18,19 @@ `coord()` has not implemented a `range()` method. +# check coord limits errors only on bad inputs + + Code + check_coord_limits(xlim(1, 2)) + Condition + Error: + ! `xlim(1, 2)` must be a vector, not a object. + +--- + + Code + check_coord_limits(1:3) + Condition + Error: + ! `1:3` must be a vector of length 2, not length 3. + diff --git a/tests/testthat/_snaps/coord-cartesian.md b/tests/testthat/_snaps/coord-cartesian.md index e7ed10569a..5bf397e20c 100644 --- a/tests/testthat/_snaps/coord-cartesian.md +++ b/tests/testthat/_snaps/coord-cartesian.md @@ -1,8 +1,8 @@ # cartesian coords throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector, not a object. --- - `ylim` must be a vector of length 2, not an integer vector of length 3. + `ylim` must be a vector of length 2, not length 3. diff --git a/tests/testthat/_snaps/coord-cartesian/clip-on-by-default-only-inside-visible.svg b/tests/testthat/_snaps/coord-cartesian/clip-on-by-default-only-inside-visible.svg index 6f424b0c4a..8532b083e3 100644 --- a/tests/testthat/_snaps/coord-cartesian/clip-on-by-default-only-inside-visible.svg +++ b/tests/testthat/_snaps/coord-cartesian/clip-on-by-default-only-inside-visible.svg @@ -27,14 +27,14 @@ -inside -inside -inside -inside -outside -outside -outside -outside +inside +inside +inside +inside +outside +outside +outside +outside clip on by default, only 'inside' visible diff --git a/tests/testthat/_snaps/coord-cartesian/clip-turned-off-both-inside-and-outside-visible.svg b/tests/testthat/_snaps/coord-cartesian/clip-turned-off-both-inside-and-outside-visible.svg index 89932b9196..b2120e5e14 100644 --- a/tests/testthat/_snaps/coord-cartesian/clip-turned-off-both-inside-and-outside-visible.svg +++ b/tests/testthat/_snaps/coord-cartesian/clip-turned-off-both-inside-and-outside-visible.svg @@ -20,14 +20,14 @@ -inside -inside -inside -inside -outside -outside -outside -outside +inside +inside +inside +inside +outside +outside +outside +outside clip turned off, both 'inside' and 'outside' visible diff --git a/tests/testthat/_snaps/coord-flip.md b/tests/testthat/_snaps/coord-flip.md index 99806717ba..101fb0908d 100644 --- a/tests/testthat/_snaps/coord-flip.md +++ b/tests/testthat/_snaps/coord-flip.md @@ -1,8 +1,8 @@ # flip coords throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector, not a object. --- - `ylim` must be a vector of length 2, not an integer vector of length 3. + `ylim` must be a vector of length 2, not length 3. diff --git a/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg b/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg index ffb66ff639..207bd13c34 100644 --- a/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg +++ b/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg @@ -27,6 +27,17 @@ + + + + + + + + + + + diff --git a/tests/testthat/_snaps/coord-map.md b/tests/testthat/_snaps/coord-map.md index 011a6dd41f..e74d005cad 100644 --- a/tests/testthat/_snaps/coord-map.md +++ b/tests/testthat/_snaps/coord-map.md @@ -1,10 +1,10 @@ # coord map throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector, not a object. --- - `ylim` must be a vector of length 2, not an integer vector of length 3. + `ylim` must be a vector of length 2, not length 3. # coord_map throws informative warning about guides diff --git a/tests/testthat/_snaps/coord-polar.md b/tests/testthat/_snaps/coord-polar.md index 1e43119dbe..62138ccf99 100644 --- a/tests/testthat/_snaps/coord-polar.md +++ b/tests/testthat/_snaps/coord-polar.md @@ -12,3 +12,7 @@ No appropriate placement found for `r_axis_inside`. i Axis will be placed at panel edge. +# when both x and y are AsIs, they are not transformed + + `coord_radial()` cannot respect the class of `x` when `y` is not also . + diff --git a/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg b/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg index 30c4b0fc24..6349bcb350 100644 --- a/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg +++ b/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg @@ -29,29 +29,29 @@ - - - - - - - - - - - -cat -strawberry -cake -coffee -window -fluid -cat -strawberry -cake -coffee -window -fluid + + + + + + + + + + + +cat +strawberry +cake +coffee +window +fluid +cat +strawberry +cake +coffee +window +fluid 1 2 3 diff --git a/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg b/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg new file mode 100644 index 0000000000..46607ddecd --- /dev/null +++ b/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg @@ -0,0 +1,70 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +100 +200 +300 + + + + + + +5 +10 + + + + + +5 +10 +x +y +full circle with axes placed at 90 and 225 degrees + + diff --git a/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg b/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg index 212100c87c..7fddfe8e83 100644 --- a/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg +++ b/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg @@ -28,21 +28,26 @@ - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + @@ -92,8 +97,8 @@ - - + + 10 15 20 @@ -106,7 +111,7 @@ - + diff --git a/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg b/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg index bc58f6429b..2f1de17be0 100644 --- a/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg +++ b/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg @@ -28,22 +28,26 @@ - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + @@ -101,8 +105,8 @@ - - + + 100 200 300 @@ -111,7 +115,7 @@ - + diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg index 8bf3cc6ec2..60045c846f 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg index d145a1e446..32bb41821f 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg b/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg index dfc63cb3d9..0c255f0bb8 100644 --- a/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg +++ b/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg @@ -47,115 +47,130 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -303,32 +318,32 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg index b9d09b1835..c82603f417 100644 --- a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg +++ b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg @@ -44,8 +44,8 @@ - - + + A B diff --git a/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg b/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg index e00a3d6a7c..b54b3afc35 100644 --- a/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg +++ b/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg @@ -47,8 +47,8 @@ - - + + 0.25 0.50 diff --git a/tests/testthat/_snaps/coord-transform.md b/tests/testthat/_snaps/coord-transform.md index def35a0f27..cec8af5ae2 100644 --- a/tests/testthat/_snaps/coord-transform.md +++ b/tests/testthat/_snaps/coord-transform.md @@ -1,8 +1,16 @@ +# warnings are generated when coord_trans() results in new infinite values + + Transformation introduced infinite values in y-axis + +--- + + Transformation introduced infinite values in x-axis + # coord_trans() throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector, not a object. --- - `ylim` must be a vector of length 2, not an integer vector of length 3. + `ylim` must be a vector of length 2, not length 3. diff --git a/tests/testthat/_snaps/coord_sf.md b/tests/testthat/_snaps/coord_sf.md index bb43424d33..7eb42bf074 100644 --- a/tests/testthat/_snaps/coord_sf.md +++ b/tests/testthat/_snaps/coord_sf.md @@ -21,9 +21,9 @@ # coord_sf() throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector, not a object. --- - `ylim` must be a vector of length 2, not an integer vector of length 3. + `ylim` must be a vector of length 2, not length 3. diff --git a/tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg b/tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg index b38125acd3..78e321d395 100644 --- a/tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg +++ b/tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg @@ -47,27 +47,27 @@ -80 -° -W -79 -° -W -78 -° -W -77 -° -W -76 -° -W -75 -° -W -40 -° -N +80 +° +W +79 +° +W +78 +° +W +77 +° +W +76 +° +W +75 +° +W +40 +° +N 35 ° N diff --git a/tests/testthat/_snaps/coord_sf/no-breaks.svg b/tests/testthat/_snaps/coord_sf/no-breaks.svg new file mode 100644 index 0000000000..67455011bb --- /dev/null +++ b/tests/testthat/_snaps/coord_sf/no-breaks.svg @@ -0,0 +1,48 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x +y +no breaks + + diff --git a/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg b/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg index d787461ca4..addbc59e92 100644 --- a/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg +++ b/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg @@ -71,11 +71,15 @@ + + + + a b diff --git a/tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg b/tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg index 90a5b755d2..5e3b176475 100644 --- a/tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg +++ b/tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg @@ -59,11 +59,11 @@ z - + - + - + a b c diff --git a/tests/testthat/_snaps/empty-data.md b/tests/testthat/_snaps/empty-data.md new file mode 100644 index 0000000000..9889c48a91 --- /dev/null +++ b/tests/testthat/_snaps/empty-data.md @@ -0,0 +1,27 @@ +# layers with empty data are silently omitted with facet_wrap + + Code + get_layer_data(d) + Condition + Error in `combine_vars()`: + ! Faceting variables must have at least one value. + +# layers with empty data are silently omitted with facet_grid + + Code + get_layer_data(d) + Condition + Error in `combine_vars()`: + ! Faceting variables must have at least one value. + +# Should error when totally empty data frame because there's no x and y + + Code + get_layer_data(d) + Condition + Error in `geom_point()`: + ! Problem while computing aesthetics. + i Error occurred in the 2nd layer. + Caused by error: + ! object 'wt' not found + diff --git a/tests/testthat/_snaps/facet-.md b/tests/testthat/_snaps/facet-.md index 2efa86bc64..154499e38a 100644 --- a/tests/testthat/_snaps/facet-.md +++ b/tests/testthat/_snaps/facet-.md @@ -1,3 +1,19 @@ +# facets reject aes() + + Code + facet_wrap(aes(foo)) + Condition + Error in `check_vars()`: + ! Please use `vars()` to supply facet variables. + +--- + + Code + facet_grid(aes(foo)) + Condition + Error in `check_vars()`: + ! Please use `vars()` to supply facet variables. + # facet_grid() fails if passed both a formula and a vars() `rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list. @@ -30,6 +46,14 @@ x Plot is missing `letter` Layer is missing `letter` +# at least one combination must exist in combine_vars() + + Code + combine_vars(list(df), vars = vars(letter = letter)) + Condition + Error in `combine_vars()`: + ! Faceting variables must have at least one value. + # combine_vars() generates the correct combinations At least one layer must contain all faceting variables: `b` and `c` @@ -40,7 +64,16 @@ Faceting variables must have at least one value. -# validate_facets() provide meaningful errors +# eval_facet() is tolerant for missing columns (#2963) + + Code + eval_facet(quo(no_such_variable * x), data_frame(foo = 1), possible_columns = c( + "x")) + Condition + Error: + ! object 'no_such_variable' not found + +# check_vars() provide meaningful errors Please use `vars()` to supply facet variables. diff --git a/tests/testthat/_snaps/facet-/facet-wrap-with-omitted-inner-axis-labels.svg b/tests/testthat/_snaps/facet-/facet-wrap-with-omitted-inner-axis-labels.svg index 66caee5c07..7c936b4768 100644 --- a/tests/testthat/_snaps/facet-/facet-wrap-with-omitted-inner-axis-labels.svg +++ b/tests/testthat/_snaps/facet-/facet-wrap-with-omitted-inner-axis-labels.svg @@ -108,83 +108,110 @@ - - + + - + + +6 - - + + - - -6 + 1 - - + + - + 8 - -0 - - + + - + + +0 - - + + - + 4 + + + + + + + + + 0 - - + + - + 4 + + + + + + + + + 1 - - + + - + 6 + + + + + + + + + 0 diff --git a/tests/testthat/_snaps/facet-labels.md b/tests/testthat/_snaps/facet-labels.md new file mode 100644 index 0000000000..6130705bea --- /dev/null +++ b/tests/testthat/_snaps/facet-labels.md @@ -0,0 +1,16 @@ +# labeller() dispatches labellers + + Code + ggplotGrob(p3) + Condition + Error in `resolve_labeller()`: + ! Cannot supply both `rows` and `cols` to `facet_wrap()`. + +--- + + Code + ggplotGrob(p5) + Condition + Error in `labeller()`: + ! Conflict between `.cols` and `cyl`. + diff --git a/tests/testthat/_snaps/facet-labels/outside-justified-labels.svg b/tests/testthat/_snaps/facet-labels/outside-justified-labels.svg new file mode 100644 index 0000000000..9b04f0b614 --- /dev/null +++ b/tests/testthat/_snaps/facet-labels/outside-justified-labels.svg @@ -0,0 +1,144 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + + +D + + + + + + + + + + +A + + + + + + + + + + +B + + + +X +X +X +X +X + +X + +X +X +X +X +X + +X +YYYYY + +Y + + +YYYYY + +Y +x +y +outside-justified labels + + diff --git a/tests/testthat/_snaps/facet-layout.md b/tests/testthat/_snaps/facet-layout.md index 03cdcbe8b3..1ab4474443 100644 --- a/tests/testthat/_snaps/facet-layout.md +++ b/tests/testthat/_snaps/facet-layout.md @@ -22,6 +22,10 @@ `nrow` must be a whole number or `NULL`, not the number 1.5. +--- + + Cannot use `space = "free_x"` with custom `nrow` or `ncol`. + --- Need 3 panels, but together `nrow` and `ncol` only provide 1. @@ -33,7 +37,7 @@ # facet_grid throws errors at bad layout specs - `coord_fixed()` doesn't support free scales. + `facet_grid()` can't use free scales with `coord_fixed()`. --- diff --git a/tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg b/tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg index c3f247ebe5..7d546bcc7e 100644 --- a/tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg +++ b/tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg @@ -93,24 +93,6 @@ - - - - - - - - - - - - - - - - - - @@ -349,15 +331,6 @@ - - - - - - - - - @@ -380,15 +353,6 @@ - - - - - - - - - diff --git a/tests/testthat/_snaps/fortify.md b/tests/testthat/_snaps/fortify.md index 81c3decea5..605829d9d8 100644 --- a/tests/testthat/_snaps/fortify.md +++ b/tests/testthat/_snaps/fortify.md @@ -3,3 +3,153 @@ `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`, not a object. i Did you accidentally pass `aes()` to the `data` argument? +# fortify.default can handle healthy data-frame-like objects + + Code + fortify(X) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` must return an of length 2. + +--- + + Code + fortify(array(1:60, 5:3)) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` must return an of length 2. + +--- + + Code + fortify(cbind(X, Y, Z, deparse.level = 0)) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `colnames(data)` must return a of length `ncol(data)`. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `dim.foo()`: + ! oops! + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` must return an of length 2. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` must return an of length 2. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` can't have `NA`s or negative values. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `dim(data)` can't have `NA`s or negative values. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `dimnames(x)[[2L]]`: + ! subscript out of bounds + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `colnames(data)` must return a of length `ncol(data)`. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_like()`: + ! `colnames(data)` must return a of length `ncol(data)`. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `as.data.frame.foo()`: + ! oops! + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_conversion()`: + ! `as.data.frame(data)` must return a . + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_conversion()`: + ! `as.data.frame(data)` must preserve dimensions. + +--- + + Code + fortify(object) + Condition + Error in `fortify()`: + ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. + Caused by error in `check_data_frame_conversion()`: + ! `as.data.frame(data)` must preserve column names. + diff --git a/tests/testthat/_snaps/geom-.md b/tests/testthat/_snaps/geom-.md index 0eae2d74ba..b0ca0c7e85 100644 --- a/tests/testthat/_snaps/geom-.md +++ b/tests/testthat/_snaps/geom-.md @@ -2,10 +2,10 @@ Problem while setting up geom aesthetics. i Error occurred in the 1st layer. - Caused by error in `use_defaults()`: - ! Aesthetic modifiers returned invalid values - x The following mappings are invalid - x `colour = after_scale(data)` + Caused by error: + ! Aesthetic modifiers returned invalid values. + x The following aesthetics are invalid: + * `colour = after_scale(data)` i Did you map the modifier in the wrong layer? --- diff --git a/tests/testthat/_snaps/geom-bar.md b/tests/testthat/_snaps/geom-bar.md new file mode 100644 index 0000000000..0afff44c16 --- /dev/null +++ b/tests/testthat/_snaps/geom-bar.md @@ -0,0 +1,4 @@ +# geom_bar removes bars with parts outside the plot limits + + Removed 1 row containing missing values or values outside the scale range (`geom_bar()`). + diff --git a/tests/testthat/_snaps/geom-boxplot.md b/tests/testthat/_snaps/geom-boxplot.md index d50a9db5e9..10e75bb438 100644 --- a/tests/testthat/_snaps/geom-boxplot.md +++ b/tests/testthat/_snaps/geom-boxplot.md @@ -1,3 +1,18 @@ +# geom_boxplot for continuous x gives warning if more than one x (#992) + + Continuous x aesthetic + i did you forget `aes(group = ...)`? + +--- + + Continuous x aesthetic + i did you forget `aes(group = ...)`? + +--- + + Continuous x aesthetic + i did you forget `aes(group = ...)`? + # boxplots with a group size >1 error Can only draw one boxplot per group. diff --git a/tests/testthat/_snaps/geom-boxplot/customised-style.svg b/tests/testthat/_snaps/geom-boxplot/customised-style.svg new file mode 100644 index 0000000000..612ec93728 --- /dev/null +++ b/tests/testthat/_snaps/geom-boxplot/customised-style.svg @@ -0,0 +1,167 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + + + + + + + +2seater +compact +midsize +minivan +pickup +subcompact +suv +class +displ + +class + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2seater +compact +midsize +minivan +pickup +subcompact +suv +customised style + + diff --git a/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg b/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg index c3fcba0018..309ffcc43d 100644 --- a/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg +++ b/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg @@ -72,16 +72,22 @@ + + + + + + 4 6 8 diff --git a/tests/testthat/_snaps/geom-boxplot/staples.svg b/tests/testthat/_snaps/geom-boxplot/staples.svg index b0bf785867..b2f4054294 100644 --- a/tests/testthat/_snaps/geom-boxplot/staples.svg +++ b/tests/testthat/_snaps/geom-boxplot/staples.svg @@ -78,16 +78,22 @@ + + + + + + 4 6 8 diff --git a/tests/testthat/_snaps/geom-col.md b/tests/testthat/_snaps/geom-col.md new file mode 100644 index 0000000000..1dfce430b0 --- /dev/null +++ b/tests/testthat/_snaps/geom-col.md @@ -0,0 +1,8 @@ +# geom_col removes columns with parts outside the plot limits + + Removed 3 rows containing missing values or values outside the scale range (`geom_col()`). + +--- + + Removed 1 row containing missing values or values outside the scale range (`geom_col()`). + diff --git a/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg b/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg new file mode 100644 index 0000000000..0a82d0b2af --- /dev/null +++ b/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.00 +1.25 +1.50 +1.75 +2.00 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y +flipped geom_curve + + diff --git a/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg b/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg new file mode 100644 index 0000000000..645b025c9d --- /dev/null +++ b/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.00 +1.25 +1.50 +1.75 +2.00 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y +standard geom_curve + + diff --git a/tests/testthat/_snaps/geom-dotplot.md b/tests/testthat/_snaps/geom-dotplot.md index ba2fa8558c..a559276853 100644 --- a/tests/testthat/_snaps/geom-dotplot.md +++ b/tests/testthat/_snaps/geom-dotplot.md @@ -14,3 +14,11 @@ Caused by error in `compute_group()`: ! `weight` must be nonnegative integers, not a double vector. +# geom_dotplot draws correctly + + Removed 2 rows containing missing values or values outside the scale range (`stat_bindot()`). + +--- + + Removed 2 rows containing missing values or values outside the scale range (`stat_bindot()`). + diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg index f76c20a281..163e6973da 100644 --- a/tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg +++ b/tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg @@ -39,7 +39,7 @@ - + diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg index bdda8286d6..cd136306cc 100644 --- a/tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg +++ b/tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg @@ -39,7 +39,7 @@ - + diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg index c6f3b60763..4bd4970011 100644 --- a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg +++ b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg @@ -36,10 +36,10 @@ - - - - + + + + @@ -47,8 +47,8 @@ - - + + A B C diff --git a/tests/testthat/_snaps/geom-label.md b/tests/testthat/_snaps/geom-label.md index 2ea8c33c06..68ab4ebba4 100644 --- a/tests/testthat/_snaps/geom-label.md +++ b/tests/testthat/_snaps/geom-label.md @@ -1,7 +1,6 @@ # geom_label() throws meaningful errors - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Choose one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- diff --git a/tests/testthat/_snaps/geom-label/geom-label-with-line-parameters.svg b/tests/testthat/_snaps/geom-label/geom-label-with-line-parameters.svg new file mode 100644 index 0000000000..b7c5c9717f --- /dev/null +++ b/tests/testthat/_snaps/geom-label/geom-label-with-line-parameters.svg @@ -0,0 +1,121 @@ + + + + + + + + + + + + + + + + + + + + + + +foo + +bar + +baz + +foo + +bar + +baz + + + +1.00 +1.25 +1.50 +1.75 +2.00 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y + +labels + + +a + +a + + +a + +a + + +a + +a +bar +baz +foo + +x + + +a + +a + + +a + +a + + +a + +a + + +a + +a + + +a + +a +1.0 +1.5 +2.0 +2.5 +3.0 +geom_label with line parameters + + diff --git a/tests/testthat/_snaps/geom-map.md b/tests/testthat/_snaps/geom-map.md index 03bef91fa5..4228af232e 100644 --- a/tests/testthat/_snaps/geom-map.md +++ b/tests/testthat/_snaps/geom-map.md @@ -6,3 +6,12 @@ `map` must have the columns `x`, `y`, and `id`. +# map_data() checks it input + + Code + map_data("world", namesonly = TRUE) + Condition + Error in `map_data()`: + ! `maps::map()` must return an object of type , not a character vector. + i Did you pass the right arguments? + diff --git a/tests/testthat/_snaps/geom-path.md b/tests/testthat/_snaps/geom-path.md index 6516134f98..9396883a78 100644 --- a/tests/testthat/_snaps/geom-path.md +++ b/tests/testthat/_snaps/geom-path.md @@ -5,3 +5,15 @@ Caused by error in `draw_panel()`: ! `geom_path()` can't have varying colour, linewidth, and/or alpha along the line when linetype isn't solid. +# stairstep() exists with error when an invalid `direction` is given + + Code + stairstep(df, direction = "invalid") + Condition + Error in `stairstep()`: + ! `direction` must be one of "hv", "vh", or "mid", not "invalid". + +# NA linetype is dropped with warning + + Removed 2 rows containing missing values or values outside the scale range (`geom_path()`). + diff --git a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg index b970c9f317..f134915d5f 100644 --- a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg +++ b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg @@ -18,6 +18,7 @@ + @@ -25,10 +26,10 @@ - - - - + + + + colour diff --git a/tests/testthat/_snaps/geom-raster.md b/tests/testthat/_snaps/geom-raster.md index 16da7d9d54..4deac92872 100644 --- a/tests/testthat/_snaps/geom-raster.md +++ b/tests/testthat/_snaps/geom-raster.md @@ -14,13 +14,6 @@ `vjust` must be a number, not the string "a". ---- - - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `draw_panel()`: - ! `geom_raster()` only works with `coord_cartesian()`. - # geom_raster() fails with pattern fills Problem while converting geom to grob. diff --git a/tests/testthat/_snaps/geom-raster/discrete-positions.svg b/tests/testthat/_snaps/geom-raster/discrete-positions.svg index ee3e5a1491..5aca7daef6 100644 --- a/tests/testthat/_snaps/geom-raster/discrete-positions.svg +++ b/tests/testthat/_snaps/geom-raster/discrete-positions.svg @@ -44,13 +44,13 @@ interaction(x, y) - + - + - + - + A.C B.C A.D diff --git a/tests/testthat/_snaps/geom-raster/irregular-categorical.svg b/tests/testthat/_snaps/geom-raster/irregular-categorical.svg index 68dda93cfe..dc12288875 100644 --- a/tests/testthat/_snaps/geom-raster/irregular-categorical.svg +++ b/tests/testthat/_snaps/geom-raster/irregular-categorical.svg @@ -56,11 +56,11 @@ factor(col) - + - + - + 0 1 NA diff --git a/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg b/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg new file mode 100644 index 0000000000..ee53464264 --- /dev/null +++ b/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +0.5/2.5 + + + +0.5 +1.0 +1.5 +2.0 +2.5 + + + + + +x +y + +fill + + + + + + + + +A +B +C +D +rectangle fallback + + diff --git a/tests/testthat/_snaps/geom-rect.md b/tests/testthat/_snaps/geom-rect.md new file mode 100644 index 0000000000..8c04cbbb21 --- /dev/null +++ b/tests/testthat/_snaps/geom-rect.md @@ -0,0 +1,9 @@ +# geom_rect can derive corners + + Code + GeomRect$setup_data(test, NULL) + Condition + Error in `resolve_rect()`: + ! `geom_rect()` requires two of the following aesthetics: xmin, xmax, x, or width. + i Currently, x is present. + diff --git a/tests/testthat/_snaps/geom-ribbon.md b/tests/testthat/_snaps/geom-ribbon.md index ae45d533f0..4c1fbb5ecc 100644 --- a/tests/testthat/_snaps/geom-ribbon.md +++ b/tests/testthat/_snaps/geom-ribbon.md @@ -17,9 +17,13 @@ Problem while converting geom to grob. i Error occurred in the 1st layer. Caused by error in `draw_group()`: - ! Aesthetics can not vary along a ribbon. + ! Aesthetics can not vary along a ribbon: linewidth. --- `outline.type` must be one of "both", "upper", "lower", or "full", not "test". +# NAs are dropped from the data + + Removed 1 row containing missing values or values outside the scale range (`geom_ribbon()`). + diff --git a/tests/testthat/_snaps/geom-rug.md b/tests/testthat/_snaps/geom-rug.md index 06e4ad195b..c9e2157860 100644 --- a/tests/testthat/_snaps/geom-rug.md +++ b/tests/testthat/_snaps/geom-rug.md @@ -5,3 +5,7 @@ Caused by error in `draw_panel()`: ! `length` must be a object, not the number 0.01. +# geom_rug() warns about missing values when na.rm = FALSE + + Removed 2 rows containing missing values or values outside the scale range (`geom_rug()`). + diff --git a/tests/testthat/_snaps/geom-sf.md b/tests/testthat/_snaps/geom-sf.md index 1cc4fbb7d1..74edd268e1 100644 --- a/tests/testthat/_snaps/geom-sf.md +++ b/tests/testthat/_snaps/geom-sf.md @@ -1,3 +1,15 @@ +# geom_sf() removes rows containing missing aes + + Removed 1 row containing missing values or values outside the scale range (`geom_sf()`). + +--- + + Removed 1 row containing missing values or values outside the scale range (`geom_sf()`). + +--- + + Removed 1 row containing missing values or values outside the scale range (`geom_sf()`). + # errors are correctly triggered Problem while converting geom to grob. @@ -7,13 +19,11 @@ --- - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg new file mode 100644 index 0000000000..642a061bab --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-line-legend.svg @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 +5.0 +5.5 +6.0 + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 +4.0 + +col + + + + +bar +foo +geom_sf line legend + + diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg new file mode 100644 index 0000000000..e92ba98f8e --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-point-legend.svg @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.2 +3.4 +3.6 +3.8 +4.0 + + + + + + + + + + + + +1.0 +1.2 +1.4 +1.6 +1.8 +2.0 + +col + + + + +bar +foo +geom_sf point legend + + diff --git a/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg b/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg new file mode 100644 index 0000000000..6eb5d587a8 --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/geom-sf-polygon-legend.svg @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +3.0 +3.5 +4.0 +4.5 +5.0 +5.5 +6.0 + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 +4.0 + +col + + + + +bar +foo +geom_sf polygon legend + + diff --git a/tests/testthat/_snaps/geom-sf/labels-for-north-carolina.svg b/tests/testthat/_snaps/geom-sf/labels-for-north-carolina.svg index cf5ffdbbf2..f11f41251b 100644 --- a/tests/testthat/_snaps/geom-sf/labels-for-north-carolina.svg +++ b/tests/testthat/_snaps/geom-sf/labels-for-north-carolina.svg @@ -27,8 +27,8 @@ - -ashe + +ashe diff --git a/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg b/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg new file mode 100644 index 0000000000..c8dc5b6922 --- /dev/null +++ b/tests/testthat/_snaps/geom-sf/mixed-geometry-types.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1 + 0 + 1 + 2 + 3 + 4 + 5 + 6 + + + + + + + + + + + + + + + + +-1 + 0 + 1 + 2 + 3 + 4 + 5 + 6 +mixed geometry types + + diff --git a/tests/testthat/_snaps/geom-sf/north-carolina-county-boundaries.svg b/tests/testthat/_snaps/geom-sf/north-carolina-county-boundaries.svg index 40e2e8c503..ebb2ccaf03 100644 --- a/tests/testthat/_snaps/geom-sf/north-carolina-county-boundaries.svg +++ b/tests/testthat/_snaps/geom-sf/north-carolina-county-boundaries.svg @@ -36,7 +36,7 @@ - + diff --git a/tests/testthat/_snaps/geom-sf/texts-for-north-carolina.svg b/tests/testthat/_snaps/geom-sf/texts-for-north-carolina.svg index 96ffe43109..ec2184a425 100644 --- a/tests/testthat/_snaps/geom-sf/texts-for-north-carolina.svg +++ b/tests/testthat/_snaps/geom-sf/texts-for-north-carolina.svg @@ -27,7 +27,7 @@ -ashe +ashe diff --git a/tests/testthat/_snaps/geom-smooth.md b/tests/testthat/_snaps/geom-smooth.md new file mode 100644 index 0000000000..aaffd02403 --- /dev/null +++ b/tests/testthat/_snaps/geom-smooth.md @@ -0,0 +1,4 @@ +# geom_smooth() works when one group fails + + span too small. fewer data values than degrees of freedom. + diff --git a/tests/testthat/_snaps/geom-text.md b/tests/testthat/_snaps/geom-text.md index c9d11b2bc7..917a4ca707 100644 --- a/tests/testthat/_snaps/geom-text.md +++ b/tests/testthat/_snaps/geom-text.md @@ -1,5 +1,20 @@ # geom_text() checks input - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` + +# geom_text() drops missing angles + + Removed 1 row containing missing values or values outside the scale range (`geom_text()`). + +# geom_text() rejects exotic units + + Code + ggplotGrob(p + geom_text(size = 10, size.unit = "npc")) + Condition + Error in `geom_text()`: + ! Problem while converting geom to grob. + i Error occurred in the 1st layer. + Caused by error in `resolve_text_unit()`: + ! `unit` must be one of "mm", "pt", "cm", "in", or "pc", not "npc". + i Did you mean "pc"? diff --git a/tests/testthat/_snaps/geom-violin.md b/tests/testthat/_snaps/geom-violin.md index 80da5aad02..68cc4c1c5a 100644 --- a/tests/testthat/_snaps/geom-violin.md +++ b/tests/testthat/_snaps/geom-violin.md @@ -1,14 +1,12 @@ # quantiles fails outside 0-1 bound - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `draw_group()`: - ! `draw_quantiles` must be between 0 and 1. + Computation failed in `stat_ydensity()`. + Caused by error in `compute_group()`: + ! `quantiles` must be between 0 and 1. --- - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `draw_group()`: - ! `draw_quantiles` must be between 0 and 1. + Computation failed in `stat_ydensity()`. + Caused by error in `compute_group()`: + ! `quantiles` must be between 0 and 1. diff --git a/tests/testthat/_snaps/geom-violin/basic.svg b/tests/testthat/_snaps/geom-violin/basic.svg index 206a6b4626..16e7518c21 100644 --- a/tests/testthat/_snaps/geom-violin/basic.svg +++ b/tests/testthat/_snaps/geom-violin/basic.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg b/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg index f737690144..611f73f969 100644 --- a/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg +++ b/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg @@ -27,7 +27,7 @@ - + diff --git a/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg b/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg index f11a934abb..74fc5ed64e 100644 --- a/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg +++ b/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg @@ -27,7 +27,7 @@ - + diff --git a/tests/testthat/_snaps/geom-violin/coord-flip.svg b/tests/testthat/_snaps/geom-violin/coord-flip.svg index 434afe96c8..59f095248a 100644 --- a/tests/testthat/_snaps/geom-violin/coord-flip.svg +++ b/tests/testthat/_snaps/geom-violin/coord-flip.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/coord-polar.svg b/tests/testthat/_snaps/geom-violin/coord-polar.svg index e70e3b11f3..5da2c31990 100644 --- a/tests/testthat/_snaps/geom-violin/coord-polar.svg +++ b/tests/testthat/_snaps/geom-violin/coord-polar.svg @@ -36,9 +36,9 @@ - - - + + + A B C diff --git a/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg b/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg index 86a328e5b5..6af10a6faa 100644 --- a/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg +++ b/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/dodging.svg b/tests/testthat/_snaps/geom-violin/dodging.svg index c1ccf480ce..d1d537e3b2 100644 --- a/tests/testthat/_snaps/geom-violin/dodging.svg +++ b/tests/testthat/_snaps/geom-violin/dodging.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg index 17142781de..fcf5700ada 100644 --- a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg +++ b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg @@ -27,12 +27,12 @@ - - - - - - + + + + + + diff --git a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg index 56049d8ef6..477f9a02c5 100644 --- a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg +++ b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg @@ -27,12 +27,12 @@ - - - - - - + + + + + + diff --git a/tests/testthat/_snaps/geom-violin/narrower-width-5.svg b/tests/testthat/_snaps/geom-violin/narrower-width-5.svg index d7a23e057b..d233183697 100644 --- a/tests/testthat/_snaps/geom-violin/narrower-width-5.svg +++ b/tests/testthat/_snaps/geom-violin/narrower-width-5.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/quantiles.svg b/tests/testthat/_snaps/geom-violin/quantiles.svg deleted file mode 100644 index 8bec1ac1a6..0000000000 --- a/tests/testthat/_snaps/geom-violin/quantiles.svg +++ /dev/null @@ -1,69 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --3 --2 --1 -0 -1 -2 -3 - - - - - - - - - - -A -B -C -x -y -quantiles - - diff --git a/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg b/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg index 1c0bf845b4..ca9f1bf889 100644 --- a/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg +++ b/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/styled-quantiles.svg b/tests/testthat/_snaps/geom-violin/styled-quantiles.svg new file mode 100644 index 0000000000..0b8d55329f --- /dev/null +++ b/tests/testthat/_snaps/geom-violin/styled-quantiles.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + +A +B +C +x +y +styled quantiles + + diff --git a/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg b/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg index 1494c6bd08..3dc573d465 100644 --- a/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg +++ b/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg b/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg index 1db22dd441..d109c20fbc 100644 --- a/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg +++ b/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/ggsave.md b/tests/testthat/_snaps/ggsave.md index 8a16fc672b..03440c5eba 100644 --- a/tests/testthat/_snaps/ggsave.md +++ b/tests/testthat/_snaps/ggsave.md @@ -1,7 +1,76 @@ +# ggsave can create directories + + Code + ggsave(path, p) + Condition + Error in `ggsave()`: + ! Cannot find directory 'PATH' + i Please supply an existing directory or use `create.dir = TRUE`. + +# ggsave warns about empty or multiple filenames + + Code + x <- suppressMessages(ggsave(c(file1, file2), plot)) + Condition + Warning in `ggsave()`: + `filename` must have length 1, not 2. + ! Only the first,'PATH', will be used. + +--- + + Code + ggsave(character(), plot) + Condition + Error in `ggsave()`: + ! `filename` must be a single string, not an empty character vector. + +# ggsave fails informatively for no-extension filenames + + Code + ggsave(tempfile(), plot) + Condition + Error in `ggsave()`: + ! Can't save to PATH + i Either supply `filename` with a file extension or supply `device`. + +# warned about large plot unless limitsize = FALSE + + Code + plot_dim(c(50, 50)) + Condition + Error: + ! Dimensions exceed 50 inches (`height` and `width` are specified in inches not pixels). + i If you're sure you want a plot that big, use `limitsize = FALSE`. + +--- + + Code + plot_dim(c(15000, 15000), units = "px") + Condition + Error: + ! Dimensions exceed 50 inches (`height` and `width` are specified in pixels). + i If you're sure you want a plot that big, use `limitsize = FALSE`. + # unknown device triggers error `device` must be a string, function or `NULL`, not the number 1. +--- + + Code + validate_device("xyz") + Condition + Error: + ! Unknown graphics device "xyz" + +--- + + Code + validate_device(NULL, "test.xyz") + Condition + Error: + ! Unknown graphics device "xyz" + # invalid single-string DPI values throw an error `dpi` must be one of "screen", "print", or "retina", not "abc". diff --git a/tests/testthat/_snaps/guide-.md b/tests/testthat/_snaps/guide-.md new file mode 100644 index 0000000000..600e56f797 --- /dev/null +++ b/tests/testthat/_snaps/guide-.md @@ -0,0 +1,11 @@ +# dots are checked when making guides + + Ignoring unknown argument to `guide_axis()`: `foo`. + +--- + + Arguments in `...` must be used. + x Problematic argument: + * foo = "bar" + i Did you misspell an argument name? + diff --git a/tests/testthat/_snaps/guide-axis.md b/tests/testthat/_snaps/guide-axis.md new file mode 100644 index 0000000000..97bb6b8fca --- /dev/null +++ b/tests/testthat/_snaps/guide-axis.md @@ -0,0 +1,19 @@ +# a warning is generated when guides are drawn at a location that doesn't make sense + + Position guide is perpendicular to the intended axis. + i Did you mean to specify a different guide `position`? + +# a warning is generated when more than one position guide is drawn at a location + + `guide_axis()`: Discarding guide on merge. + i Do you have more than one guide with the same `position`? + +# Using non-position guides for position scales results in an informative error + + `guide_legend()` cannot be used for x, xmin, xmax, or xend. + i Use any non position aesthetic instead. + +# guide_axis_logticks calculates appropriate ticks + + The `prescale.base` argument will override the scale's log-10 transformation in log-tick positioning. + diff --git a/tests/testthat/_snaps/guides/align-facet-labels-facets-horizontal.svg b/tests/testthat/_snaps/guide-axis/align-facet-labels-facets-horizontal.svg similarity index 100% rename from tests/testthat/_snaps/guides/align-facet-labels-facets-horizontal.svg rename to tests/testthat/_snaps/guide-axis/align-facet-labels-facets-horizontal.svg diff --git a/tests/testthat/_snaps/guides/align-facet-labels-facets-vertical.svg b/tests/testthat/_snaps/guide-axis/align-facet-labels-facets-vertical.svg similarity index 100% rename from tests/testthat/_snaps/guides/align-facet-labels-facets-vertical.svg rename to tests/testthat/_snaps/guide-axis/align-facet-labels-facets-vertical.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-basic.svg b/tests/testthat/_snaps/guide-axis/axis-guides-basic.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-basic.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-basic.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg b/tests/testthat/_snaps/guide-axis/axis-guides-check-overlap.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-check-overlap.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-check-overlap.svg diff --git a/tests/testthat/_snaps/guide-axis/axis-guides-negative-rotation.svg b/tests/testthat/_snaps/guide-axis/axis-guides-negative-rotation.svg new file mode 100644 index 0000000000..8bb60d982b --- /dev/null +++ b/tests/testthat/_snaps/guide-axis/axis-guides-negative-rotation.svg @@ -0,0 +1,106 @@ + + + + + + + + + + + + + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg b/tests/testthat/_snaps/guide-axis/axis-guides-positive-rotation.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-positive-rotation.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg b/tests/testthat/_snaps/guide-axis/axis-guides-text-dodged-into-rows-cols.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-text-dodged-into-rows-cols.svg diff --git a/tests/testthat/_snaps/guide-axis/axis-guides-vertical-negative-rotation.svg b/tests/testthat/_snaps/guide-axis/axis-guides-vertical-negative-rotation.svg new file mode 100644 index 0000000000..06d782e9c8 --- /dev/null +++ b/tests/testthat/_snaps/guide-axis/axis-guides-vertical-negative-rotation.svg @@ -0,0 +1,106 @@ + + + + + + + + + + + + + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + +1,000 +2,000 +3,000 +4,000 +5,000 +6,000 +7,000 +8,000 +9,000 +10,000 + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg b/tests/testthat/_snaps/guide-axis/axis-guides-vertical-rotation.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-vertical-rotation.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-with-capped-ends.svg b/tests/testthat/_snaps/guide-axis/axis-guides-with-capped-ends.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-with-capped-ends.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-with-capped-ends.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg b/tests/testthat/_snaps/guide-axis/axis-guides-zero-breaks.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-zero-breaks.svg diff --git a/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg b/tests/testthat/_snaps/guide-axis/axis-guides-zero-rotation.svg similarity index 100% rename from tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg rename to tests/testthat/_snaps/guide-axis/axis-guides-zero-rotation.svg diff --git a/tests/testthat/_snaps/guides/guide-axis-customization.svg b/tests/testthat/_snaps/guide-axis/guide-axis-customization.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-axis-customization.svg rename to tests/testthat/_snaps/guide-axis/guide-axis-customization.svg diff --git a/tests/testthat/_snaps/guides/guide-axis-theta-in-cartesian-coordinates.svg b/tests/testthat/_snaps/guide-axis/guide-axis-theta-in-cartesian-coordinates.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-axis-theta-in-cartesian-coordinates.svg rename to tests/testthat/_snaps/guide-axis/guide-axis-theta-in-cartesian-coordinates.svg diff --git a/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg b/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg new file mode 100644 index 0000000000..79f3e27b8c --- /dev/null +++ b/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +75 +100 +125 +150 +175 +200 +225 +250 +275 +300 +325 +350 +375 +400 +425 +450 +475 + + + + + + + + + + + + + + + + + + +75 +100 +125 +150 +175 +200 +225 +250 +275 +300 +325 +350 +375 +400 +425 +450 +475 + + + + + + + + + + + + + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + +disp +mpg +guide_axis_theta with angle adapting to theta + + diff --git a/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg b/tests/testthat/_snaps/guide-axis/guide-titles-with-coord-trans.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg rename to tests/testthat/_snaps/guide-axis/guide-titles-with-coord-trans.svg diff --git a/tests/testthat/_snaps/guides/guides-specified-in-guides.svg b/tests/testthat/_snaps/guide-axis/guides-specified-in-guides.svg similarity index 100% rename from tests/testthat/_snaps/guides/guides-specified-in-guides.svg rename to tests/testthat/_snaps/guide-axis/guides-specified-in-guides.svg diff --git a/tests/testthat/_snaps/guides/guides-with-minor-ticks.svg b/tests/testthat/_snaps/guide-axis/guides-with-minor-ticks.svg similarity index 100% rename from tests/testthat/_snaps/guides/guides-with-minor-ticks.svg rename to tests/testthat/_snaps/guide-axis/guides-with-minor-ticks.svg diff --git a/tests/testthat/_snaps/guides/logtick-axes-with-customisation.svg b/tests/testthat/_snaps/guide-axis/logtick-axes-with-customisation.svg similarity index 100% rename from tests/testthat/_snaps/guides/logtick-axes-with-customisation.svg rename to tests/testthat/_snaps/guide-axis/logtick-axes-with-customisation.svg diff --git a/tests/testthat/_snaps/guides/position-guide-titles.svg b/tests/testthat/_snaps/guide-axis/position-guide-titles.svg similarity index 100% rename from tests/testthat/_snaps/guides/position-guide-titles.svg rename to tests/testthat/_snaps/guide-axis/position-guide-titles.svg diff --git a/tests/testthat/_snaps/guides/stacked-axes.svg b/tests/testthat/_snaps/guide-axis/stacked-axes.svg similarity index 100% rename from tests/testthat/_snaps/guides/stacked-axes.svg rename to tests/testthat/_snaps/guide-axis/stacked-axes.svg diff --git a/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg b/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg new file mode 100644 index 0000000000..d8399aeb76 --- /dev/null +++ b/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg @@ -0,0 +1,147 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 + + + + + + + + + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 +hp +left +right +stacked radial axes + + diff --git a/tests/testthat/_snaps/guides/thick-axis-lines.svg b/tests/testthat/_snaps/guide-axis/thick-axis-lines.svg similarity index 100% rename from tests/testthat/_snaps/guides/thick-axis-lines.svg rename to tests/testthat/_snaps/guide-axis/thick-axis-lines.svg diff --git a/tests/testthat/_snaps/guide-colorbar.md b/tests/testthat/_snaps/guide-colorbar.md new file mode 100644 index 0000000000..95818b07a1 --- /dev/null +++ b/tests/testthat/_snaps/guide-colorbar.md @@ -0,0 +1,14 @@ +# colorsteps and bins checks the breaks format + + Breaks are not formatted correctly for a bin legend. + i Use `(, ]` format to indicate bins. + +--- + + Breaks are not formatted correctly for a bin legend. + i Use `(, ]` format to indicate bins. + +# guide_colourbar warns about discrete scales + + `guide_colourbar()` needs continuous scales. + diff --git a/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg b/tests/testthat/_snaps/guide-colorbar/combined-colour-and-fill-aesthetics.svg similarity index 98% rename from tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg rename to tests/testthat/_snaps/guide-colorbar/combined-colour-and-fill-aesthetics.svg index 9d656ece9f..75f9b641d3 100644 --- a/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg +++ b/tests/testthat/_snaps/guide-colorbar/combined-colour-and-fill-aesthetics.svg @@ -79,6 +79,6 @@ 5 6 7 -one combined colorbar for colour and fill aesthetics +combined colour and fill aesthetics diff --git a/tests/testthat/_snaps/guides/customized-colorbar.svg b/tests/testthat/_snaps/guide-colorbar/customized-colorbar.svg similarity index 100% rename from tests/testthat/_snaps/guides/customized-colorbar.svg rename to tests/testthat/_snaps/guide-colorbar/customized-colorbar.svg diff --git a/tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg b/tests/testthat/_snaps/guide-colorbar/white-to-red-colorbar-white-ticks-no-frame.svg similarity index 100% rename from tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg rename to tests/testthat/_snaps/guide-colorbar/white-to-red-colorbar-white-ticks-no-frame.svg diff --git a/tests/testthat/_snaps/guide-legend.md b/tests/testthat/_snaps/guide-legend.md new file mode 100644 index 0000000000..7369171c92 --- /dev/null +++ b/tests/testthat/_snaps/guide-legend.md @@ -0,0 +1,6 @@ +# unresolved, modified expressions throw a warning (#6264) + + Unable to apply staged modifications. + Caused by error: + ! object 'prop' not found + diff --git a/tests/testthat/_snaps/guides/enlarged-guides.svg b/tests/testthat/_snaps/guide-legend/enlarged-guides.svg similarity index 100% rename from tests/testthat/_snaps/guides/enlarged-guides.svg rename to tests/testthat/_snaps/guide-legend/enlarged-guides.svg diff --git a/tests/testthat/_snaps/guides/horizontal-legend-direction.svg b/tests/testthat/_snaps/guide-legend/horizontal-legend-direction.svg similarity index 100% rename from tests/testthat/_snaps/guides/horizontal-legend-direction.svg rename to tests/testthat/_snaps/guide-legend/horizontal-legend-direction.svg diff --git a/tests/testthat/_snaps/guides/left-aligned-legend-key.svg b/tests/testthat/_snaps/guide-legend/left-aligned-legend-key.svg similarity index 100% rename from tests/testthat/_snaps/guides/left-aligned-legend-key.svg rename to tests/testthat/_snaps/guide-legend/left-aligned-legend-key.svg diff --git a/tests/testthat/_snaps/guides/legend-byrow-true.svg b/tests/testthat/_snaps/guide-legend/legend-byrow-true.svg similarity index 100% rename from tests/testthat/_snaps/guides/legend-byrow-true.svg rename to tests/testthat/_snaps/guide-legend/legend-byrow-true.svg diff --git a/tests/testthat/_snaps/guide-legend/legend-key-justification.svg b/tests/testthat/_snaps/guide-legend/legend-key-justification.svg new file mode 100644 index 0000000000..25880c7d29 --- /dev/null +++ b/tests/testthat/_snaps/guide-legend/legend-key-justification.svg @@ -0,0 +1,136 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 +400 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +disp + +drat + + + + + + +3 +4 +5 + +factor(cyl) + + + + + + +one line +up +to +four +lines +up +to +five +whole +lines +legend key justification + + diff --git a/tests/testthat/_snaps/guides/legend-with-widely-spaced-keys.svg b/tests/testthat/_snaps/guide-legend/legend-with-widely-spaced-keys.svg similarity index 100% rename from tests/testthat/_snaps/guides/legend-with-widely-spaced-keys.svg rename to tests/testthat/_snaps/guide-legend/legend-with-widely-spaced-keys.svg diff --git a/tests/testthat/_snaps/guides/vertical-legend-direction.svg b/tests/testthat/_snaps/guide-legend/vertical-legend-direction.svg similarity index 100% rename from tests/testthat/_snaps/guides/vertical-legend-direction.svg rename to tests/testthat/_snaps/guide-legend/vertical-legend-direction.svg diff --git a/tests/testthat/_snaps/guides.md b/tests/testthat/_snaps/guides.md index 62d1e41d24..a47fba746b 100644 --- a/tests/testthat/_snaps/guides.md +++ b/tests/testthat/_snaps/guides.md @@ -1,8 +1,3 @@ -# Using non-position guides for position scales results in an informative error - - `guide_legend()` cannot be used for x, xmin, xmax, or xend. - i Use any non position aesthetic instead. - # guide specifications are properly checked Unknown guide: test @@ -42,19 +37,21 @@ `nrow` * `ncol` needs to be larger than the number of breaks (5). -# colorsteps and bins checks the breaks format +# get_guide_data retrieves keys appropriately - Breaks are not formatted correctly for a bin legend. - i Use `(, ]` format to indicate bins. + Code + get_guide_data(b, 1) + Condition + Error in `get_guide_data()`: + ! `aesthetic` must be a single string, not the number 1. --- - Breaks are not formatted correctly for a bin legend. - i Use `(, ]` format to indicate bins. - -# guide_axis_logticks calculates appropriate ticks - - The `prescale.base` argument will override the scale's log-10 transformation in log-tick positioning. + Code + get_guide_data(b, "x", panel = "a") + Condition + Error in `get_guide_data()`: + ! `panel` must be a whole number, not the string "a". # binning scales understand the different combinations of limits, breaks, labels, and show.limits @@ -66,10 +63,15 @@ `show.limits` is ignored when `labels` are given as a character vector. i Either add the limits to `breaks` or provide a function for `labels`. -# a warning is generated when guides( = FALSE) is specified +# guides() warns if unnamed guides are provided + + Guides provided to `guides()` must be named. + i All guides are unnamed. + +--- - The `guide` argument in `scale_*()` cannot be `FALSE`. This was deprecated in ggplot2 3.3.4. - i Please use "none" instead. + Guides provided to `guides()` must be named. + i The 2nd guide is unnamed. # old S3 guides can be implemented diff --git a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg deleted file mode 100644 index b2bb7180ab..0000000000 --- a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg +++ /dev/null @@ -1,106 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg deleted file mode 100644 index ba7d74a326..0000000000 --- a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg +++ /dev/null @@ -1,106 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - -1,000 -2,000 -3,000 -4,000 -5,000 -6,000 -7,000 -8,000 -9,000 -10,000 - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/guide-axis-theta-with-angle-adapting-to-theta.svg b/tests/testthat/_snaps/guides/guide-axis-theta-with-angle-adapting-to-theta.svg deleted file mode 100644 index b6cfa798fc..0000000000 --- a/tests/testthat/_snaps/guides/guide-axis-theta-with-angle-adapting-to-theta.svg +++ /dev/null @@ -1,192 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -75 -100 -125 -150 -175 -200 -225 -250 -275 -300 -325 -350 -375 -400 -425 -450 -475 - - - - - - - - - - - - - - - - - - -75 -100 -125 -150 -175 -200 -225 -250 -275 -300 -325 -350 -375 -400 -425 -450 -475 - - - - - - - - - - - - - - - - - - - -10 -15 -20 -25 -30 -35 - - - - - - -disp -mpg -guide_axis_theta with angle adapting to theta - - diff --git a/tests/testthat/_snaps/guides/guide-custom-with-void-theme.svg b/tests/testthat/_snaps/guides/guide-custom-with-void-theme.svg new file mode 100644 index 0000000000..12b96037a8 --- /dev/null +++ b/tests/testthat/_snaps/guides/guide-custom-with-void-theme.svg @@ -0,0 +1,35 @@ + + + + + + + + + + + + + + + + + + + + + + +custom guide + +guide_custom with void theme + + diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg b/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg new file mode 100644 index 0000000000..22481fa7cf --- /dev/null +++ b/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + +A +B +C +x +y + +x + + + + + + +A +B +C + +1:3 + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +legend inside plot, multiple positions + + diff --git a/tests/testthat/_snaps/guides/reversed-guide-bins.svg b/tests/testthat/_snaps/guides/reversed-guide-bins.svg new file mode 100644 index 0000000000..16e8f7efca --- /dev/null +++ b/tests/testthat/_snaps/guides/reversed-guide-bins.svg @@ -0,0 +1,97 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +25 +50 +75 +100 + + + + + + + + + + +0 +25 +50 +75 +100 +x +x + +x + + + + + + + + + + + + + + +100 +75 +50 +25 +0 + +x + + + + + + + + + + + + +75 +50 +25 +reversed guide_bins + + diff --git a/tests/testthat/_snaps/guides/stacked-radial-axes.svg b/tests/testthat/_snaps/guides/stacked-radial-axes.svg deleted file mode 100644 index 18609a9a74..0000000000 --- a/tests/testthat/_snaps/guides/stacked-radial-axes.svg +++ /dev/null @@ -1,143 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -100 -200 -300 - - - - -100 -200 -300 - - - - -100 -200 -300 - - - - -100 -200 -300 - - - - - -100 -200 -300 -400 - - - - - -100 -200 -300 -400 - - - - - - - - - -100 -200 -300 -400 - - - - - -100 -200 -300 -400 -hp -left -right -stacked radial axes - - diff --git a/tests/testthat/_snaps/guides/stylised-guide-custom.svg b/tests/testthat/_snaps/guides/stylised-guide-custom.svg new file mode 100644 index 0000000000..85d3aa01f9 --- /dev/null +++ b/tests/testthat/_snaps/guides/stylised-guide-custom.svg @@ -0,0 +1,37 @@ + + + + + + + + + + + + + + + + + + + + + + + + +custom guide + +stylised guide_custom + + diff --git a/tests/testthat/_snaps/labels.md b/tests/testthat/_snaps/labels.md index 8c027dae53..2a4bd75ff4 100644 --- a/tests/testthat/_snaps/labels.md +++ b/tests/testthat/_snaps/labels.md @@ -1,3 +1,22 @@ +# alt text can take a function + + Code + get_alt_text(p) + Output + [1] "A plot showing class on a discrete x-axis and count on a continuous y-axis using a bar layer." + +# get_alt_text checks dots + + Arguments in `...` must be used. + x Problematic argument: + * foo = "bar" + i Did you misspell an argument name? + +# warnings are thrown for unknown labels + + Ignoring unknown labels: + * `foo = "bar"` + # plot.tag.position rejects invalid input The `plot.tag.position` theme element must be a object. @@ -6,3 +25,19 @@ `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "foobar". +--- + + Code + ggplotGrob(p + theme(plot.tag.position = c(0, 0.5, 1))) + Condition + Error in `theme()`: + ! A `plot.tag.position` must be a vector of length 2, not length 3. + +--- + + Code + ggplotGrob(p + theme(plot.tag.position = c(0, 0), plot.tag.location = "margin")) + Condition + Error in `theme()`: + ! A `plot.tag.position` cannot be used with `"margin"` as `plot.tag.location`. + diff --git a/tests/testthat/_snaps/layer.md b/tests/testthat/_snaps/layer.md index d95e11bed6..c796c6a530 100644 --- a/tests/testthat/_snaps/layer.md +++ b/tests/testthat/_snaps/layer.md @@ -1,14 +1,14 @@ # layer() checks its input - Can't create layer without a geom. + `geom` must be either a string or a object, not `NULL`. --- - Can't create layer without a stat. + `stat` must be either a string or a object, not `NULL`. --- - Can't create layer without a position. + `position` must be either a string or a object, not `NULL`. --- @@ -25,48 +25,88 @@ --- - `x` must be either a string or a object, not an environment. + `environment()` must be either a string or a object, not an environment. + +--- + + Failed to retrieve a object from `geom_foo()`. + Caused by error in `geom_foo()`: + ! This function is unconstructable. + +# unknown params create warning + + Ignoring unknown parameters: `blah` + +# unknown aesthetics create warning + + Ignoring unknown aesthetics: blah + +# empty aesthetics create warning + + Ignoring empty aesthetics: `fill` and `shape`. # invalid aesthetics throws errors Problem while computing aesthetics. i Error occurred in the 1st layer. - Caused by error in `compute_aesthetics()`: + Caused by error: ! Aesthetics are not valid data columns. x The following aesthetics are invalid: - x `fill = data` + * `fill = data` i Did you mistype the name of a data column or forget to add `after_stat()`? --- Problem while mapping stat to aesthetics. i Error occurred in the 1st layer. - Caused by error in `map_statistic()`: + Caused by error: ! Aesthetics must be valid computed stats. x The following aesthetics are invalid: - x `fill = after_stat(data)` + * `fill = after_stat(data)` i Did you map your stat in the wrong layer? +# missing aesthetics trigger informative error + + Code + ggplot_build(ggplot(df) + geom_line()) + Condition + Error in `geom_line()`: + ! Problem while setting up geom. + i Error occurred in the 1st layer. + Caused by error in `compute_geom_1()`: + ! `geom_line()` requires the following missing aesthetics: x and y. + +--- + + Code + ggplot_build(ggplot(df) + geom_col()) + Condition + Error in `geom_col()`: + ! Problem while setting up geom. + i Error occurred in the 1st layer. + Caused by error in `compute_geom_1()`: + ! `geom_col()` requires the following missing aesthetics: x and y. + # function aesthetics are wrapped with after_stat() Problem while computing aesthetics. i Error occurred in the 1st layer. - Caused by error in `compute_aesthetics()`: + Caused by error: ! Aesthetics are not valid data columns. x The following aesthetics are invalid: - x `colour = NULL` - x `fill = NULL` + * `colour = density` + * `fill = density` i Did you mistype the name of a data column or forget to add `after_stat()`? # computed stats are in appropriate layer Problem while mapping stat to aesthetics. i Error occurred in the 1st layer. - Caused by error in `map_statistic()`: + Caused by error: ! Aesthetics must be valid computed stats. x The following aesthetics are invalid: - x `colour = NULL` - x `fill = NULL` + * `colour = after_stat(density)` + * `fill = after_stat(density)` i Did you map your stat in the wrong layer? # layer reports the error with correct index etc @@ -89,6 +129,16 @@ All aesthetics have length 1, but the data has 32 rows. i Please consider using `annotate()` or provide this layer with data containing a single row. +# layer names can be resolved + + Code + p + l + l + Condition + Error in `new_layer_names()`: + ! Names must be unique. + x These names are duplicated: + * "foobar" at locations 3 and 4. + # layer_data returns a data.frame `layer_data()` must return a . diff --git a/tests/testthat/_snaps/legend-draw/all-legend-keys.svg b/tests/testthat/_snaps/legend-draw/all-legend-keys.svg new file mode 100644 index 0000000000..e535bebe99 --- /dev/null +++ b/tests/testthat/_snaps/legend-draw/all-legend-keys.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + +point + +abline + +rect + +polygon + +blank +boxplot + + + + + + +crossbar + + +path + +vpath + +dotplot + +linerange + +pointrange + + +smooth + +text +a +label + +a +vline + +timeseries + + + diff --git a/tests/testthat/_snaps/limits.md b/tests/testthat/_snaps/limits.md index b7f4ffd960..f52f2e94e5 100644 --- a/tests/testthat/_snaps/limits.md +++ b/tests/testthat/_snaps/limits.md @@ -4,5 +4,5 @@ --- - `linewidth` must be a two-element vector. + `linewidth` must be a vector of length 2, not length 1. diff --git a/tests/testthat/_snaps/margins.md b/tests/testthat/_snaps/margins.md deleted file mode 100644 index 3eefe771b7..0000000000 --- a/tests/testthat/_snaps/margins.md +++ /dev/null @@ -1,4 +0,0 @@ -# justify_grobs() checks input - - `grobs` must be an individual or list of objects, not the number 1. - diff --git a/tests/testthat/_snaps/performance.md b/tests/testthat/_snaps/performance.md new file mode 100644 index 0000000000..153fde6c57 --- /dev/null +++ b/tests/testthat/_snaps/performance.md @@ -0,0 +1,9 @@ +# modifyList is masked + + Code + modifyList(testlist, testappend) + Condition + Error in `modifyList()`: + ! Please use `modify_list()` instead of `modifyList()` for better performance. + i See the vignette ggplot2 internal programming guidelines for details. + diff --git a/tests/testthat/_snaps/plot.md b/tests/testthat/_snaps/plot.md index 6035364389..157ebb6635 100644 --- a/tests/testthat/_snaps/plot.md +++ b/tests/testthat/_snaps/plot.md @@ -8,6 +8,13 @@ `data` cannot be a function. i Have you misspelled the `data` argument in `ggplot()` +--- + + Arguments in `...` must be used. + x Problematic argument: + * foobar = "nonsense" + i Did you misspell an argument name? + # construction have user friendly errors Cannot use `+` with a single argument. diff --git a/tests/testthat/_snaps/position-jitterdodge.md b/tests/testthat/_snaps/position-jitterdodge.md deleted file mode 100644 index 1a387e880e..0000000000 --- a/tests/testthat/_snaps/position-jitterdodge.md +++ /dev/null @@ -1,8 +0,0 @@ -# position_jitterdodge() fails with meaningful error - - Problem while computing position. - i Error occurred in the 1st layer. - Caused by error in `setup_params()`: - ! `position_jitterdodge()` requires at least one aesthetic to dodge by. - i Use one of "fill", "colour", "linetype", "shape", "size", or "alpha" aesthetics. - diff --git a/tests/testthat/_snaps/position_dodge.md b/tests/testthat/_snaps/position_dodge.md new file mode 100644 index 0000000000..044f2b4392 --- /dev/null +++ b/tests/testthat/_snaps/position_dodge.md @@ -0,0 +1,11 @@ +# position_dodge warns about missing required aesthetics + + Code + ggplot_build(p) + Condition + Error: + ! Problem while computing position. + i Error occurred in the 1st layer. + Caused by error in `setup_params()`: + ! `position_dodge()` requires the following missing aesthetics: x or xmin. + diff --git a/tests/testthat/_snaps/prohibited-functions.md b/tests/testthat/_snaps/prohibited-functions.md index 87c26e26a8..e13510ebcf 100644 --- a/tests/testthat/_snaps/prohibited-functions.md +++ b/tests/testthat/_snaps/prohibited-functions.md @@ -29,7 +29,7 @@ [4] "date_minor_breaks" $discrete_scale - [1] "scale_name" + [1] "scale_name" "minor_breaks" $geom_density2d [1] "contour_var" @@ -43,17 +43,11 @@ $geom_density_2d_filled [1] "contour_var" - $geom_label - [1] "nudge_x" "nudge_y" - - $geom_sf_label - [1] "nudge_x" "nudge_y" - $geom_sf_text - [1] "nudge_x" "nudge_y" "check_overlap" + [1] "check_overlap" $geom_text - [1] "nudge_x" "nudge_y" "check_overlap" + [1] "check_overlap" $geom_violin [1] "draw_quantiles" @@ -149,7 +143,8 @@ [4] "date_minor_breaks" $scale_x_time - [1] "minor_breaks" + [1] "date_breaks" "minor_breaks" "date_minor_breaks" + [4] "date_labels" $scale_y_continuous [1] "minor_breaks" @@ -163,7 +158,8 @@ [4] "date_minor_breaks" $scale_y_time - [1] "minor_breaks" + [1] "date_breaks" "minor_breaks" "date_minor_breaks" + [4] "date_labels" $sf_transform_xy [1] "target_crs" "source_crs" "authority_compliant" @@ -184,34 +180,44 @@ [1] "contour_var" $theme_bw - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_classic - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_dark - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_gray - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_grey - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_light - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_linedraw - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_minimal - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_test - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $theme_void - [1] "base_size" "base_family" "base_line_size" "base_rect_size" + [1] "base_size" "base_family" "header_family" "base_line_size" + [5] "base_rect_size" $transform_position [1] "trans_x" "trans_y" diff --git a/tests/testthat/_snaps/qplot.md b/tests/testthat/_snaps/qplot.md index 6513d2deb0..c95b8b3d2d 100644 --- a/tests/testthat/_snaps/qplot.md +++ b/tests/testthat/_snaps/qplot.md @@ -1,4 +1,4 @@ # qplot() only work with character geom - `geom` must be a character vector, not a object. + `geom` must be a character vector, not a object. diff --git a/tests/testthat/_snaps/scale-colour-continuous.md b/tests/testthat/_snaps/scale-colour.md similarity index 89% rename from tests/testthat/_snaps/scale-colour-continuous.md rename to tests/testthat/_snaps/scale-colour.md index a5410a8799..14d6e6a95d 100644 --- a/tests/testthat/_snaps/scale-colour-continuous.md +++ b/tests/testthat/_snaps/scale-colour.md @@ -21,10 +21,8 @@ --- Unknown scale type: "abc" - i Use either "gradient" or "viridis". --- Unknown scale type: "abc" - i Use either "gradient" or "viridis". diff --git a/tests/testthat/_snaps/scale-date.md b/tests/testthat/_snaps/scale-date.md new file mode 100644 index 0000000000..da37c01413 --- /dev/null +++ b/tests/testthat/_snaps/scale-date.md @@ -0,0 +1,34 @@ +# date(time) scales throw warnings when input is incorrect + + A value was passed to a Date scale. + i The value was converted to a object. + +--- + + A value was passed to a Datetime scale. + i The value was converted to a object. + +--- + + Code + ggplot_build(p + scale_x_date(date_breaks = c(11, 12))) + Condition + Error in `datetime_scale()`: + ! `date_breaks` must be a single string, not a double vector. + +--- + + Code + ggplot_build(p + scale_x_date(date_minor_breaks = c(11, 12))) + Condition + Error in `datetime_scale()`: + ! `date_minor_breaks` must be a single string, not a double vector. + +--- + + Code + ggplot_build(p + scale_x_date(date_labels = c(11, 12))) + Condition + Error in `datetime_scale()`: + ! `date_labels` must be a single string, not a double vector. + diff --git a/tests/testthat/_snaps/scale-discrete.md b/tests/testthat/_snaps/scale-discrete.md index c668bceba9..6a49fa9fdf 100644 --- a/tests/testthat/_snaps/scale-discrete.md +++ b/tests/testthat/_snaps/scale-discrete.md @@ -1,3 +1,39 @@ +# Scale is checked in default colour scale + + Code + scale_colour_discrete(type = scale_colour_gradient) + Condition + Error in `scale_backward_compatibility()`: + ! The `type` argument must return a discrete scale for the colour aesthetic. + x The provided scale is continuous. + +--- + + Code + scale_fill_discrete(type = scale_fill_gradient) + Condition + Error in `scale_backward_compatibility()`: + ! The `type` argument must return a discrete scale for the fill aesthetic. + x The provided scale is continuous. + +--- + + Code + scale_colour_discrete(type = scale_fill_hue) + Condition + Error in `scale_backward_compatibility()`: + ! The `type` argument must return a continuous scale for the colour aesthetic. + x The provided scale works with the following aesthetics: fill. + +--- + + Code + scale_fill_discrete(type = scale_colour_hue) + Condition + Error in `scale_backward_compatibility()`: + ! The `type` argument must return a continuous scale for the fill aesthetic. + x The provided scale works with the following aesthetics: colour. + # Aesthetics with no continuous interpretation fails when called A continuous variable cannot be mapped to the linetype aesthetic. @@ -8,3 +44,27 @@ A continuous variable cannot be mapped to the shape aesthetic. i Choose a different aesthetic or use `scale_shape_binned()`. +# mapped_discrete vectors behaves as predicted + + Code + mapped_discrete(letters) + Condition + Error in `mapped_discrete()`: + ! Can't convert `x` to . + +# invalid palettes trigger errors + + Code + ggplot_build(p + scale_x_discrete(palette = function(x) LETTERS[1:3])) + Condition + Error in `scale_x_discrete()`: + ! The `palette` function must return a vector. + +--- + + Code + ggplot_build(p + scale_x_discrete(palette = function(x) 1:2)) + Condition + Error in `scale_x_discrete()`: + ! The `palette` function must return at least 3 values. + diff --git a/tests/testthat/_snaps/scale-gradient.md b/tests/testthat/_snaps/scale-gradient.md new file mode 100644 index 0000000000..ebb18a84e7 --- /dev/null +++ b/tests/testthat/_snaps/scale-gradient.md @@ -0,0 +1,4 @@ +# midpoints are transformed + + log-10 transformation introduced infinite values in `midpoint`. + diff --git a/tests/testthat/_snaps/scale-hue.md b/tests/testthat/_snaps/scale-hue.md index bccf63c43a..8221bba045 100644 --- a/tests/testthat/_snaps/scale-hue.md +++ b/tests/testthat/_snaps/scale-hue.md @@ -1,4 +1,4 @@ # scale_hue() checks the type input - `type` must be a character vector or a list of character vectors. + `type` must be a character vector or list of character vectors, not an integer vector. diff --git a/tests/testthat/_snaps/scale-manual.md b/tests/testthat/_snaps/scale-manual.md index faf69a7899..70c2fa4dfd 100644 --- a/tests/testthat/_snaps/scale-manual.md +++ b/tests/testthat/_snaps/scale-manual.md @@ -2,3 +2,19 @@ No shared levels found between `names(values)` of the manual scale and the data's colour values. +# insufficient values raise an error + + Code + ggplot_build(p + scale_colour_manual(values = "black")) + Condition + Error in `palette()`: + ! Insufficient values in manual scale. 2 needed but only 1 provided. + +# fewer values (#3451) + + Code + s2$map(c("4", "6", "8")) + Condition + Error in `palette()`: + ! Insufficient values in manual scale. 3 needed but only 2 provided. + diff --git a/tests/testthat/_snaps/scales-breaks-labels.md b/tests/testthat/_snaps/scales-breaks-labels.md new file mode 100644 index 0000000000..e3b5f28532 --- /dev/null +++ b/tests/testthat/_snaps/scales-breaks-labels.md @@ -0,0 +1,133 @@ +# labels match breaks + + Code + scale_x_discrete(breaks = 1:3, labels = 1:2) + Condition + Error in `scale_x_discrete()`: + ! `breaks` and `labels` must have the same length. + +--- + + Code + scale_x_continuous(breaks = 1:3, labels = 1:2) + Condition + Error in `scale_x_continuous()`: + ! `breaks` and `labels` must have the same length. + +# passing continuous limits to a discrete scale generates a warning + + Continuous limits supplied to discrete scale. + i Did you mean `limits = factor(...)` or `scale_*_continuous()`? + +# suppressing breaks, minor_breask, and labels works + + Code + scale_x_date(breaks = NA, limits = lims)$get_breaks() + Condition + Error in `scale_x_date()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_date(labels = NA, limits = lims)$get_labels() + Condition + Error in `scale_x_date()`: + ! Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor() + Condition + Error in `scale_x_date()`: + ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(breaks = NA, limits = lims)$get_breaks() + Condition + Error in `scale_x_datetime()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(labels = NA, limits = lims)$get_labels() + Condition + Error in `scale_x_datetime()`: + ! Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor() + Condition + Error in `scale_x_datetime()`: + ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. + +# scale_breaks with explicit NA options (deprecated) + + Code + sxc$get_breaks() + Condition + Error in `scale_x_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + sxc$get_breaks_minor() + Condition + Error in `scale_x_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + syc$get_breaks() + Condition + Error in `scale_y_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + syc$get_breaks_minor() + Condition + Error in `scale_y_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + sac$get_breaks() + Condition + Error in `scale_alpha_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + ssc$get_breaks() + Condition + Error in `scale_size_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + sfc$get_breaks() + Condition + Error in `scale_fill_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scc$get_breaks() + Condition + Error in `scale_colour_continuous()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + diff --git a/tests/testthat/_snaps/scales.md b/tests/testthat/_snaps/scales.md index 61754a645a..33b36a3cd8 100644 --- a/tests/testthat/_snaps/scales.md +++ b/tests/testthat/_snaps/scales.md @@ -1,3 +1,31 @@ +# oob affects position values + + Removed 1 row containing missing values or values outside the scale range (`geom_bar()`). + +--- + + Removed 3 rows containing missing values or values outside the scale range (`geom_bar()`). + +# scales warn when transforms introduces non-finite values + + log-10 transformation introduced infinite values. + +# size and alpha scales throw appropriate warnings for factors + + Using size for a discrete variable is not advised. + +--- + + Using alpha for a discrete variable is not advised. + +--- + + Using linewidth for a discrete variable is not advised. + +# shape scale throws appropriate warnings for factors + + Using shapes for an ordinal variable is not advised + # scale_apply preserves class and attributes `scale_id` must not contain any "NA". @@ -44,11 +72,130 @@ # numeric scale transforms can produce breaks + Code + test_breaks("asn", limits = c(0, 1)) + Output + [1] 0.00 0.25 0.50 0.75 1.00 + +--- + + Code + test_breaks("sqrt", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("atanh", limits = c(-0.9, 0.9)) + Output + [1] NA -0.5 0.0 0.5 NA + +--- + + Code + test_breaks(transform_boxcox(0), limits = c(1, 10)) + Output + [1] NA 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks(transform_modulus(0), c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks(transform_yj(0), c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("exp", c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("identity", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + Code test_breaks("log", limits = c(0.1, 1000)) Output [1] NA 1.00000 20.08554 403.42879 +--- + + Code + test_breaks("log10", limits = c(0.1, 1000)) + Output + [1] 1e-01 1e+00 1e+01 1e+02 1e+03 + +--- + + Code + test_breaks("log2", limits = c(0.5, 32)) + Output + [1] 0.5 2.0 8.0 32.0 + +--- + + Code + test_breaks("log1p", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("pseudo_log", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("logit", limits = c(0.001, 0.999)) + Output + [1] NA 0.25 0.50 0.75 NA + +--- + + Code + test_breaks("probit", limits = c(0.001, 0.999)) + Output + [1] NA 0.25 0.50 0.75 NA + +--- + + Code + test_breaks("reciprocal", limits = c(1, 10)) + Output + [1] NA 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("reverse", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("sqrt", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + # training incorrectly appropriately communicates the offenders Continuous values supplied to discrete scale. @@ -71,3 +218,19 @@ The `scale_name` argument of `binned_scale()` is deprecated as of ggplot2 3.5.0. +# continuous scales warn about faulty `limits` + + Code + scale_x_continuous(limits = c("A", "B")) + Condition + Error in `scale_x_continuous()`: + ! `limits` must be a vector, not a character vector. + +--- + + Code + scale_x_continuous(limits = 1:3) + Condition + Error in `scale_x_continuous()`: + ! `limits` must be a vector of length 2, not length 3. + diff --git a/tests/testthat/_snaps/stat-bin.md b/tests/testthat/_snaps/stat-bin.md index dd7a8127bf..db0b8f44c0 100644 --- a/tests/testthat/_snaps/stat-bin.md +++ b/tests/testthat/_snaps/stat-bin.md @@ -23,35 +23,34 @@ # inputs to binning are checked - Computation failed in `stat_bin()`. - Caused by error in `bins()`: - ! `breaks` must be a vector, not a character vector. + `breaks` must be a vector, not a character vector. --- - `x_range` must have two elements. + `binwidth` must be a number, not a character vector. --- - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_width()`: - ! `binwidth` must be a number, not a character vector. + `binwidth` must be a number larger than or equal to 0, not the number -4. --- - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_width()`: - ! `binwidth` must be a number larger than or equal to 0, not the number -4. + `bins` must be a whole number larger than or equal to 1, not the number -4. ---- +# setting boundary and center - `x_range` must have two elements. + Computation failed in `stat_bin()`. + Caused by error in `compute_bins()`: + ! Only one of `boundary` and `center` may be specified. ---- +# bin errors at high bin counts - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_bins()`: - ! `bins` must be a whole number larger than or equal to 1, not the number -4. + Code + compute_bins(c(1, 2e+06), binwidth = 1) + Condition + Error in `bin_breaks_width()`: + ! The number of histogram bins must be less than 1,000,000. + i Did you make `binwidth` too small? # stat_count throws error when both x and y aesthetic present diff --git a/tests/testthat/_snaps/stat-bin2d.md b/tests/testthat/_snaps/stat-bin2d.md index ffc60d7f92..a0bb2eebc7 100644 --- a/tests/testthat/_snaps/stat-bin2d.md +++ b/tests/testthat/_snaps/stat-bin2d.md @@ -1,12 +1,12 @@ # binwidth is respected Computation failed in `stat_bin2d()`. - Caused by error in `bin2d_breaks()`: + Caused by error in `compute_bins()`: ! `binwidth` must be a number, not a double vector. --- Computation failed in `stat_bin2d()`. - Caused by error in `bin2d_breaks()`: - ! `origin` must be a number, not a double vector. + Caused by error in `compute_bins()`: + ! `boundary` must be a number or `NULL`, not a double vector. diff --git a/tests/testthat/_snaps/stat-connect.md b/tests/testthat/_snaps/stat-connect.md new file mode 100644 index 0000000000..98c4fd7df5 --- /dev/null +++ b/tests/testthat/_snaps/stat-connect.md @@ -0,0 +1,24 @@ +# stat_connect rejects invalid connections + + Code + test_setup(connection = "foobar") + Condition + Error in `setup_params()`: + ! `connection` must be one of "hv", "vh", "mid", or "linear", not "foobar". + +--- + + Code + test_setup(connection = matrix(1:3, ncol = 1)) + Condition + Error in `setup_params()`: + ! `connection` must be a numeric with 2 columns, not an integer matrix with 1 column(s). + +--- + + Code + test_setup(connection = matrix(c(1:3, NA), ncol = 2)) + Condition + Error in `setup_params()`: + ! `connection` cannot contain missing or other non-finite values. + diff --git a/tests/testthat/_snaps/stat-contour.md b/tests/testthat/_snaps/stat-contour.md new file mode 100644 index 0000000000..d20d5aee72 --- /dev/null +++ b/tests/testthat/_snaps/stat-contour.md @@ -0,0 +1,14 @@ +# a warning is issued when there is more than one z per x+y + + Contour data has duplicated x, y coordinates. + i 1 duplicated row have been dropped. + +# contouring sparse data results in a warning + + `stat_contour()`: Zero contours were generated + +# stat_contour() removes duplicated coordinates + + Contour data has duplicated x, y coordinates. + i 4 duplicated rows have been dropped. + diff --git a/tests/testthat/_snaps/stat-density.md b/tests/testthat/_snaps/stat-density.md index 17cbca4b7d..94902bca55 100644 --- a/tests/testthat/_snaps/stat-density.md +++ b/tests/testthat/_snaps/stat-density.md @@ -1,3 +1,7 @@ +# stat_density handles data outside of `bounds` + + Some data points are outside of `bounds`. Removing them. + # stat_density works in both directions Problem while computing stat. @@ -5,6 +9,10 @@ Caused by error in `setup_params()`: ! `stat_density()` requires an x or y aesthetic. +# compute_density returns useful df and throws warning when <2 values + + Groups with fewer than two data points have been dropped. + # precompute_bandwidth() errors appropriately `bw` must be one of "nrd0", "nrd", "ucv", "bcv", "sj", "sj-ste", or "sj-dpi", not "foobar". diff --git a/tests/testthat/_snaps/stat-density2d.md b/tests/testthat/_snaps/stat-density2d.md index a8840aaa76..03a875c63c 100644 --- a/tests/testthat/_snaps/stat-density2d.md +++ b/tests/testthat/_snaps/stat-density2d.md @@ -5,3 +5,10 @@ Caused by error in `compute_layer()`: ! `contour_var` must be one of "density", "ndensity", or "count", not "abcd". +# stat_density_2d handles faulty bandwidth + + Computation failed in `stat_density2d()`. + Caused by error in `precompute_2d_bw()`: + ! The bandwidth argument `h` must contain numbers larger than 0. + i Please set the `h` argument to stricly positive numbers manually. + diff --git a/tests/testthat/_snaps/stat-ecdf.md b/tests/testthat/_snaps/stat-ecdf.md index e4da4c47f9..92edd3193f 100644 --- a/tests/testthat/_snaps/stat-ecdf.md +++ b/tests/testthat/_snaps/stat-ecdf.md @@ -5,3 +5,21 @@ Caused by error in `setup_params()`: ! `stat_ecdf()` requires an x or y aesthetic. +# weighted ecdf warns about weird weights + + The weight aesthetic does not support non-finite or `NA` values. + i These weights were replaced by "0". + +--- + + The sum of the weight aesthetic is close to "0". + i Computed eCDF might be unstable. + +--- + + Code + wecdf(1:10, rep(c(-1, 1), 5)) + Condition + Error in `wecdf()`: + ! Cannot compute eCDF when the weight aesthetic sums up to "0". + diff --git a/tests/testthat/_snaps/stat-function.md b/tests/testthat/_snaps/stat-function.md new file mode 100644 index 0000000000..329b6cc8de --- /dev/null +++ b/tests/testthat/_snaps/stat-function.md @@ -0,0 +1,5 @@ +# Warn when drawing multiple copies of the same function + + Multiple drawing groups in `geom_function()` + i Did you use the correct group, colour, or fill aesthetics? + diff --git a/tests/testthat/_snaps/stat-ydensity.md b/tests/testthat/_snaps/stat-ydensity.md index 1511b0b462..f72f4ebd57 100644 --- a/tests/testthat/_snaps/stat-ydensity.md +++ b/tests/testthat/_snaps/stat-ydensity.md @@ -6,3 +6,12 @@ `test` is not a valid bandwidth rule. +# `drop = FALSE` preserves groups with 1 observations + + Groups with fewer than two datapoints have been dropped. + i Set `drop = FALSE` to consider such groups for position adjustment purposes. + +--- + + Cannot compute density for groups with fewer than two datapoints. + diff --git a/tests/testthat/_snaps/stats.md b/tests/testthat/_snaps/stats.md index 92a4296185..f5b46f9669 100644 --- a/tests/testthat/_snaps/stats.md +++ b/tests/testthat/_snaps/stats.md @@ -1,6 +1,35 @@ +# plot succeeds even if some computation fails + + Computation failed in `stat_summary()`. + Caused by error in `fun()`: + ! Failed computation + +# error message is thrown when aesthetics are missing + + Code + ggplot_build(p) + Condition + Error in `stat_sum()`: + ! Problem while computing stat. + i Error occurred in the 1st layer. + Caused by error in `compute_layer()`: + ! `stat_sum()` requires the following missing aesthetics: x and y. + # erroneously dropped aesthetics are found and issue a warning + The following aesthetics were dropped during statistical transformation: fill. + i This can happen when ggplot fails to infer the correct grouping structure in the data. + i Did you forget to specify a `group` aesthetic or to convert a numerical variable into a factor? + +--- + The following aesthetics were dropped during statistical transformation: colour and fill. i This can happen when ggplot fails to infer the correct grouping structure in the data. i Did you forget to specify a `group` aesthetic or to convert a numerical variable into a factor? +--- + + The following aesthetics were dropped during statistical transformation: colour. + i This can happen when ggplot fails to infer the correct grouping structure in the data. + i Did you forget to specify a `group` aesthetic or to convert a numerical variable into a factor? + diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 259a887c1a..0218bbef51 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -1,3 +1,19 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error: + ! Can't add `"asdf"` to a theme object. + +# replacing theme elements with %+replace% operator works + + Code + theme_grey() + "asdf" + Condition + Error: + ! Can't add `"asdf"` to a theme object. + # theme validation happens at build stage The `text` theme element must be a object. @@ -40,6 +56,27 @@ The `blablabla` theme element must be a object. +--- + + `element_tree` must have names. + +--- + + `element_tree` must have elements constructed with `el_def()`. + i Invalid structure: "foo" + +--- + + Invalid parent in `element_tree`: "foo". + +# elements can be merged + + Code + merge_element(text_base, rect_base) + Condition + Error in `merge_element()`: + ! Only elements of the same class can be merged. + # Theme elements are checked during build `plot.title.position` must be one of "panel" or "plot", not "test". @@ -53,7 +90,16 @@ `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "test". i Did you mean "left"? +# subtheme functions rename arguments as intended + + Ignoring unknown `theme()` elements: foo and bar. + # Theme validation behaves as expected The `aspect.ratio` theme element must be a object. +# theme() warns about conflicting palette options + + The `options('ggplot2.discrete.colour')` setting is incompatible with the `palette.colour.discrete` theme setting. + i You can set `options(ggplot2.discrete.colour = NULL)`. + diff --git a/tests/testthat/_snaps/theme/large-margins.svg b/tests/testthat/_snaps/theme/large-margins.svg new file mode 100644 index 0000000000..1e4bfb10db --- /dev/null +++ b/tests/testthat/_snaps/theme/large-margins.svg @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + +x +y + +z + + + + +a +b +large margins + + diff --git a/tests/testthat/_snaps/theme/large-spacing.svg b/tests/testthat/_snaps/theme/large-spacing.svg new file mode 100644 index 0000000000..1680934c61 --- /dev/null +++ b/tests/testthat/_snaps/theme/large-spacing.svg @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + +x +y + +z + + + + +a +b +large spacing + + diff --git a/tests/testthat/_snaps/theme/point-elements.svg b/tests/testthat/_snaps/theme/point-elements.svg new file mode 100644 index 0000000000..f810f35c3b --- /dev/null +++ b/tests/testthat/_snaps/theme/point-elements.svg @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/theme/polygon-elements.svg b/tests/testthat/_snaps/theme/polygon-elements.svg new file mode 100644 index 0000000000..e6e0de8c72 --- /dev/null +++ b/tests/testthat/_snaps/theme/polygon-elements.svg @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/theme/theme-bw-large.svg b/tests/testthat/_snaps/theme/theme-bw-large.svg index 148d1a93ca..cbffb819ac 100644 --- a/tests/testthat/_snaps/theme/theme-bw-large.svg +++ b/tests/testthat/_snaps/theme/theme-bw-large.svg @@ -45,9 +45,9 @@ - - - + + + @@ -87,9 +87,9 @@ z - + - + a b theme_bw_large diff --git a/tests/testthat/_snaps/theme/theme-classic-large.svg b/tests/testthat/_snaps/theme/theme-classic-large.svg index 96767cc14f..7105d5474b 100644 --- a/tests/testthat/_snaps/theme/theme-classic-large.svg +++ b/tests/testthat/_snaps/theme/theme-classic-large.svg @@ -27,9 +27,9 @@ - - - + + + @@ -43,36 +43,36 @@ 1 - - - - - - -1.0 -1.5 -2.0 -2.5 -3.0 - -1.0 -1.5 -2.0 -2.5 -3.0 - - - - - + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 + +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + x y z - + - + a b theme_classic_large diff --git a/tests/testthat/_snaps/theme/theme-classic.svg b/tests/testthat/_snaps/theme/theme-classic.svg index 8588be9819..45ef7ef076 100644 --- a/tests/testthat/_snaps/theme/theme-classic.svg +++ b/tests/testthat/_snaps/theme/theme-classic.svg @@ -43,28 +43,28 @@ 1 - - - - - - -1.0 -1.5 -2.0 -2.5 -3.0 - -1.0 -1.5 -2.0 -2.5 -3.0 - - - - - + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 + +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + x y diff --git a/tests/testthat/_snaps/theme/theme-dark-large.svg b/tests/testthat/_snaps/theme/theme-dark-large.svg index 9bad950947..f6f9c1058f 100644 --- a/tests/testthat/_snaps/theme/theme-dark-large.svg +++ b/tests/testthat/_snaps/theme/theme-dark-large.svg @@ -45,9 +45,9 @@ - - - + + + @@ -86,9 +86,9 @@ z - + - + a b theme_dark_large diff --git a/tests/testthat/_snaps/theme/theme-gray-large.svg b/tests/testthat/_snaps/theme/theme-gray-large.svg index a827864db6..4348638185 100644 --- a/tests/testthat/_snaps/theme/theme-gray-large.svg +++ b/tests/testthat/_snaps/theme/theme-gray-large.svg @@ -45,9 +45,9 @@ - - - + + + @@ -86,9 +86,9 @@ z - + - + a b theme_gray_large diff --git a/tests/testthat/_snaps/theme/theme-light-large.svg b/tests/testthat/_snaps/theme/theme-light-large.svg index 727f55ae02..29fc210917 100644 --- a/tests/testthat/_snaps/theme/theme-light-large.svg +++ b/tests/testthat/_snaps/theme/theme-light-large.svg @@ -45,9 +45,9 @@ - - - + + + @@ -87,9 +87,9 @@ z - + - + a b theme_light_large diff --git a/tests/testthat/_snaps/theme/theme-linedraw-large.svg b/tests/testthat/_snaps/theme/theme-linedraw-large.svg index 66998cd898..e2aadff6e7 100644 --- a/tests/testthat/_snaps/theme/theme-linedraw-large.svg +++ b/tests/testthat/_snaps/theme/theme-linedraw-large.svg @@ -45,9 +45,9 @@ - - - + + + @@ -87,9 +87,9 @@ z - + - + a b theme_linedraw_large diff --git a/tests/testthat/_snaps/theme/theme-minimal-large.svg b/tests/testthat/_snaps/theme/theme-minimal-large.svg index 4673e9cc60..1dc1caf61a 100644 --- a/tests/testthat/_snaps/theme/theme-minimal-large.svg +++ b/tests/testthat/_snaps/theme/theme-minimal-large.svg @@ -18,6 +18,7 @@ + @@ -43,9 +44,9 @@ - - - + + + @@ -71,8 +72,8 @@ x y z - - + + a b theme_minimal_large diff --git a/tests/testthat/_snaps/theme/theme-minimal.svg b/tests/testthat/_snaps/theme/theme-minimal.svg index aa5fbe37d8..ce2799c95b 100644 --- a/tests/testthat/_snaps/theme/theme-minimal.svg +++ b/tests/testthat/_snaps/theme/theme-minimal.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/theme/theme-void-large.svg b/tests/testthat/_snaps/theme/theme-void-large.svg index 8135cd36d3..58ac3525dd 100644 --- a/tests/testthat/_snaps/theme/theme-void-large.svg +++ b/tests/testthat/_snaps/theme/theme-void-large.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/theme/theme-void.svg b/tests/testthat/_snaps/theme/theme-void.svg index b69c91ef30..e537f6bb9d 100644 --- a/tests/testthat/_snaps/theme/theme-void.svg +++ b/tests/testthat/_snaps/theme/theme-void.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/theme/theme-with-inverted-colours.svg b/tests/testthat/_snaps/theme/theme-with-inverted-colours.svg new file mode 100644 index 0000000000..812529cf9f --- /dev/null +++ b/tests/testthat/_snaps/theme/theme-with-inverted-colours.svg @@ -0,0 +1,332 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Strip title + + + + + + + + +2 +3 +4 +5 +6 +7 +20 +30 +40 + + + +displ +hwy + +drv + + + + + + +4 +f +r +Subtitle +Main title +Caption +A + + diff --git a/tests/testthat/_snaps/utilities-break.md b/tests/testthat/_snaps/utilities-break.md new file mode 100644 index 0000000000..31563a6cd7 --- /dev/null +++ b/tests/testthat/_snaps/utilities-break.md @@ -0,0 +1,4 @@ +# cut_interval throws the correct error message + + Specify exactly one of `n` and `length`. + diff --git a/tests/testthat/_snaps/utilities-checks.md b/tests/testthat/_snaps/utilities-checks.md new file mode 100644 index 0000000000..18fb2a2bdc --- /dev/null +++ b/tests/testthat/_snaps/utilities-checks.md @@ -0,0 +1,20 @@ +# check_device checks R versions correctly + + R 4.0.0 does not support gradients. + +--- + + R 4.1.0 does not support gradients. + +--- + + R 4.2.0 does not support glyphs. + +# check_device finds device capabilities + + The pdf device does not support clipping paths. + +--- + + Unable to check the capabilities of the foobar device. + diff --git a/tests/testthat/_snaps/utilities.md b/tests/testthat/_snaps/utilities.md index 804ce1ad27..4ccf6d67d1 100644 --- a/tests/testthat/_snaps/utilities.md +++ b/tests/testthat/_snaps/utilities.md @@ -12,12 +12,16 @@ --- - `test()` requires the following missing aesthetics: x and fill or y and fill. + `test()` requires the following missing aesthetics: fill and x or y. # remove_missing checks input `na.rm` must be `TRUE` or `FALSE`, not an integer vector. +# characters survive remove_missing + + Removed 1 row containing non-finite outside the scale range. + # tolower() and toupper() has been masked Please use `to_lower_ascii()`, which works fine in all locales. @@ -50,7 +54,19 @@ Only one of `boundary` and `center` may be specified. -# interleave() checks the vector lengths - - Can't recycle `..1` (size 4) to match `..2` (size 0). +# summary method gives a nice summary + + Code + summary(p) + Output + data: manufacturer, model, displ, year, cyl, trans, drv, cty, hwy, fl, + class [234x11] + mapping: x = ~displ, y = ~hwy, colour = ~drv + scales: x, xmin, xmax, xend, xintercept, xmin_final, xmax_final, xlower, xmiddle, xupper, x0, colour + faceting: ~year, ~cyl + ----------------------------------- + geom_point: na.rm = FALSE + stat_identity: na.rm = FALSE + position_identity + diff --git a/tests/testthat/helper-plot-data.R b/tests/testthat/helper-plot-data.R index bc1f81f2c9..13e36d861a 100644 --- a/tests/testthat/helper-plot-data.R +++ b/tests/testthat/helper-plot-data.R @@ -5,7 +5,7 @@ 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) + panel_params <- plot$coordinates$setup_panel_params(scales$x, scales$y, params = pieces$layout$coord_params) plot$coordinates$transform(panel_data, panel_params) }) }) diff --git a/tests/testthat/test-aes-calculated.R b/tests/testthat/test-aes-calculated.R index 256a246f83..2d389106cf 100644 --- a/tests/testthat/test-aes-calculated.R +++ b/tests/testthat/test-aes-calculated.R @@ -6,7 +6,7 @@ test_that("names surrounded by .. is calculated", { expect_equal(is_calculated_aes(aes(..x.., ..x, x..)), c(TRUE, FALSE, FALSE)) # even when nested - expect_equal(is_calculated_aes(aes(f(..x..))), TRUE) + expect_true(is_calculated_aes(aes(f(..x..)))) }) test_that("call to stat() is calculated", { @@ -70,6 +70,26 @@ test_that("staged aesthetics warn appropriately for duplicated names", { expect_snapshot_warning(ggplot_build(p)) }) +test_that("calculated aesthetics throw warnings when lengths mismatch", { + + df <- data.frame(x = 1:2) + + p <- ggplot(df, aes(x, x)) + + expect_snapshot_warning( + ggplot_build( + p + geom_point(aes(colour = after_stat(c("A", "B", "C")))) + ) + ) + + expect_snapshot_warning( + ggplot_build( + 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", { p1 <- ggplot(NULL, aes(stat(foo))) expect_snapshot_warning(b1 <- ggplot_build(p1)) @@ -77,3 +97,75 @@ test_that("A deprecated warning is issued when stat(var) or ..var.. is used", { p2 <- ggplot(NULL, aes(..bar..)) expect_snapshot_warning(b2 <- ggplot_build(p2)) }) + +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()) + expect_equal(evaled, list(x = 10, y = 30)) + + evaled <- eval_aesthetics(mapping, data = data, mask = list(foo = bar)) + expect_equal(evaled, list(x = 10, y = 200)) + + # Test namespace-prefixed evaluation (#6104) + 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)) + expect_equal(evaled, list(x = 10, y = 20)) + 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)) + expect_equal( + eval_aesthetics(start_unnamed, data = df), + list(x = 1:2) + ) + + start_named <- aes(stage(start = x)) + expect_equal( + eval_aesthetics(start_named, data = df), + list(x = 1:2) + ) + + start_nulls <- aes(stage(start = x, after_stat = NULL, after_scale = NULL)) + expect_equal( + eval_aesthetics(start_nulls, data = df), + list(x = 1:2) + ) + +}) + +test_that("A geom can have scaled defaults (#6135)", { + + test_geom <- ggproto( + NULL, GeomPoint, + default_aes = modify_list( + GeomPoint$default_aes, + aes(colour = after_scale(alpha(fill, 0.5)), fill = "black") + ) + ) + + df <- data.frame(x = 1:3, fill = c("#FF0000", "#00FF00", "#0000FF")) + + ld <- layer_data( + ggplot(df, aes(x, x, fill = I(fill))) + + stat_identity(geom = test_geom) + ) + + expect_equal(ld$colour, c("#FF000080", "#00FF0080", '#0000FF80')) + + defaults <- get_geom_defaults(test_geom) + expect_equal(defaults$colour, c("#00000080")) +}) diff --git a/tests/testthat/test-aes-grouping.R b/tests/testthat/test-aes-grouping.R index 204128f197..d5536cc417 100644 --- a/tests/testthat/test-aes-grouping.R +++ b/tests/testthat/test-aes-grouping.R @@ -4,7 +4,7 @@ df <- data_frame( b = c("a", "b", "a", "b") ) -group <- function(x) as.vector(layer_data(x, 1)$group) +group <- function(x) as.vector(get_layer_data(x, 1)$group) groups <- function(x) vec_unique_count(group(x)) @@ -26,7 +26,7 @@ test_that("no error for aes(groupS)", { g <- add_group(df2) expect_equal(nrow(g), nrow(df2)) - expect_equal(names(g), c("x", "y", "groupS", "group")) + expect_named(g, c("x", "y", "groupS", "group")) }) test_that("label is not used as a grouping var", { diff --git a/tests/testthat/test-aes-setting.R b/tests/testthat/test-aes-setting.R index 4c3e055ea8..2071921c03 100644 --- a/tests/testthat/test-aes-setting.R +++ b/tests/testthat/test-aes-setting.R @@ -3,13 +3,13 @@ test_that("aesthetic parameters match length of data", { p <- ggplot(df, aes(x, y)) set_colours <- function(colours) { - layer_data(p + geom_point(colour = colours)) + get_layer_data(p + geom_point(colour = colours)) } set_colours("red") - expect_error(set_colours(rep("red", 2)), "must be either length 1") - expect_error(set_colours(rep("red", 3)), "must be either length 1") - expect_error(set_colours(rep("red", 4)), "must be either length 1") + expect_snapshot(set_colours(rep("red", 2)), error = TRUE) + expect_snapshot(set_colours(rep("red", 3)), error = TRUE) + expect_snapshot(set_colours(rep("red", 4)), error = TRUE) set_colours(rep("red", 5)) }) @@ -19,7 +19,7 @@ test_that("Length 1 aesthetics are recycled to 0", { expect_silent(plot(p)) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(nrow(data), 0) }) @@ -31,7 +31,7 @@ test_that("legend filters out aesthetics not of length 1", { # Ideally would test something in the legend data structure, but # that's not easily accessible currently. - expect_error(ggplot_gtable(ggplot_build(p)), NA) + expect_no_error(ggplot_gtable(ggplot_build(p))) }) test_that("alpha affects only fill colour of solid geoms", { @@ -45,11 +45,11 @@ test_that("alpha affects only fill colour of solid geoms", { ribb <- ggplot(df, aes(x = x, ymin = 1, ymax = y + 1)) + geom_ribbon(fill = "red", colour = "red", alpha = 0.5) - expect_equal(layer_grob(poly)[[1]]$gp$col[[1]], "red") - expect_equal(layer_grob(rect)[[1]]$gp$col[[1]], "red") - expect_equal(layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], "red") + 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(layer_grob(poly)[[1]]$gp$fill[[1]], "#FF000080") - expect_equal(layer_grob(rect)[[1]]$gp$fill[[1]], "#FF000080") - expect_equal(layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], "#FF000080") + 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") }) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index 92b51b94e8..a42b4a3ae1 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -48,19 +48,21 @@ test_that("aes evaluated in environment where plot created", { df <- data_frame(x = 1, y = 1) p <- ggplot(df, aes(foo, y)) + geom_point() - # Accessing an undefined variable should result in error - expect_error(layer_data(p), "'foo' not found") + test_that("accessing an undefined variable results in an error", { + skip_if(getRversion() <= "4.4.0") + expect_snapshot(get_layer_data(p), error = TRUE) + }) # Once it's defined we should get it back foo <- 0 - expect_equal(layer_data(p)$x, 0) + expect_equal(get_layer_data(p)$x, 0) # And regular variable shadowing should work f <- function() { foo <- 10 ggplot(df, aes(foo, y)) + geom_point() } - expect_equal(layer_data(f())$x, 10) + expect_equal(get_layer_data(f())$x, 10) }) test_that("constants are not wrapped in quosures", { @@ -94,12 +96,14 @@ test_that("assignment methods pull unwrap constants from quosures", { test_that("quosures are squashed when creating default label for a mapping", { p <- ggplot(mtcars) + aes(!!quo(identity(!!quo(cyl)))) - expect_identical(p$labels$x, "identity(cyl)") + labels <- ggplot_build(p)$plot$labels + expect_identical(labels$x, "identity(cyl)") }) test_that("labelling doesn't cause error if aesthetic is NULL", { p <- ggplot(mtcars) + aes(x = NULL) - expect_identical(p$labels$x, "x") + labels <- ggplot_build(p)$plot$labels + expect_identical(labels$x, "x") }) test_that("aes standardises aesthetic names", { @@ -112,29 +116,26 @@ test_that("aes standardises aesthetic names", { expect_identical(aes(color_point = x), aes(colour_point = x)) # warning when standardisation creates duplicates - expect_warning(aes(color = x, colour = y), "Duplicated aesthetics") + expect_snapshot_warning(aes(color = x, colour = y)) }) 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_warning( - warn_for_aes_extract_usage(aes(df$x), df), - "Use of `df\\$x` is discouraged" + expect_snapshot_warning( + warn_for_aes_extract_usage(aes(df$x), df) ) - expect_warning( - warn_for_aes_extract_usage(aes(df[["x"]]), df), - 'Use of `df\\[\\["x"\\]\\]` is discouraged' + expect_snapshot_warning( + warn_for_aes_extract_usage(aes(df[["x"]]), df) ) # Check that rownames are ignored (#5392) df2 <- df rownames(df2) <- LETTERS[seq_len(nrow(df))] - expect_warning( - warn_for_aes_extract_usage(aes(df$x), df2), - "Use of `df\\$x` is discouraged" + expect_snapshot_warning( + warn_for_aes_extract_usage(aes(df$x), df2) ) }) @@ -142,7 +143,7 @@ test_that("warn_for_aes_extract_usage() does not evaluate function calls", { df <- data_frame(x = 1:5, nested_df = data_frame(x = 6:10)) returns_df <- function() df - expect_warning(warn_for_aes_extract_usage(aes(df$x), df)) + expect_snapshot_warning(warn_for_aes_extract_usage(aes(df$x), df)) expect_silent(warn_for_aes_extract_usage(aes(returns_df()$x), df)) }) @@ -161,7 +162,7 @@ test_that("warn_for_aes_extract_usage() does not warn for valid uses of $ and [[ test_that("Warnings are issued when plots use discouraged extract usage within aes()", { df <- data_frame(x = 1:3, y = 1:3) p <- ggplot(df, aes(df$x, y)) + geom_point() - expect_warning(ggplot_build(p), "Use of `df\\$x` is discouraged") + expect_snapshot_warning(ggplot_build(p)) }) test_that("aes evaluation fails with unknown input", { diff --git a/tests/testthat/test-annotate.R b/tests/testthat/test-annotate.R index 8646433a92..a0200a82d3 100644 --- a/tests/testthat/test-annotate.R +++ b/tests/testthat/test-annotate.R @@ -13,7 +13,7 @@ test_that("dates in segment annotation work", { yend = 10 ) - expect_true(all(c("xend", "yend") %in% names(layer_data(p, 2)))) + expect_true(all(c("xend", "yend") %in% names(get_layer_data(p, 2)))) }) test_that("segment annotations transform with scales", { @@ -86,3 +86,32 @@ test_that("annotate() warns about `stat` or `position` arguments", { annotate("point", 1:3, 1:3, stat = "density", position = "dodge") ) }) + +test_that("annotation_custom() and annotation_raster() adhere to scale transforms", { + rast <- matrix(rainbow(10), nrow = 1) + + p <- ggplot() + + annotation_raster(rast, 1, 10, 1, 9) + + 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) + + 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_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) + +}) diff --git a/tests/testthat/test-build.R b/tests/testthat/test-build.R index 24930a0373..cdcbe0c6ac 100644 --- a/tests/testthat/test-build.R +++ b/tests/testthat/test-build.R @@ -15,13 +15,13 @@ test_that("there is one data frame for each layer", { test_that("position aesthetics are coerced to correct type", { l1 <- ggplot(df, aes(x, y)) + geom_point() - d1 <- layer_data(l1, 1) + d1 <- get_layer_data(l1, 1) expect_type(d1$x, "double") expect_type(d1$y, "double") l2 <- ggplot(df, aes(x, z)) + geom_point() + scale_x_discrete() - d2 <- layer_data(l2, 1) + d2 <- get_layer_data(l2, 1) expect_s3_class(d2$x, "mapped_discrete") expect_s3_class(d2$y, "mapped_discrete") @@ -32,7 +32,7 @@ test_that("non-position aesthetics are mapped", { geom_point() expect_named( - layer_data(l1, 1), + get_layer_data(l1, 1), c( "x", "y", "fill", "group", "colour", "shape", "size", "PANEL", "alpha", "stroke" @@ -41,7 +41,7 @@ test_that("non-position aesthetics are mapped", { ) l2 <- l1 + scale_colour_manual(values = c("blue", "red", "yellow")) - d2 <- layer_data(l2, 1) + d2 <- get_layer_data(l2, 1) expect_equal(d2$colour, c("blue", "red", "yellow")) }) @@ -50,5 +50,5 @@ test_that("strings are not converted to factors", { p <- ggplot(df, aes(x, y)) + geom_text(aes(label = label), parse = TRUE) - expect_type(layer_data(p)$label, "character") + expect_type(get_layer_data(p)$label, "character") }) diff --git a/tests/testthat/test-compat-plyr.R b/tests/testthat/test-compat-plyr.R deleted file mode 100644 index b8fd891ebf..0000000000 --- a/tests/testthat/test-compat-plyr.R +++ /dev/null @@ -1,6 +0,0 @@ -test_that("input checks work in compat functions", { - expect_snapshot_error(unrowname(1:6)) - expect_snapshot_error(revalue(1:7, c("5" = 2))) - expect_snapshot_error(as.quoted(1:7)) - expect_snapshot_error(round_any(letters)) -}) diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index ca7f62c06e..b0cef2de26 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -37,8 +37,7 @@ 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_equal(names(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", { @@ -48,8 +47,64 @@ test_that("check coord limits errors only on bad inputs", { expect_null(check_coord_limits(c(1,2))) # Should raise error if Scale object is passed - expect_error(check_coord_limits(xlim(1,2))) + expect_snapshot(check_coord_limits(xlim(1,2)), error = TRUE) # Should raise error if vector of wrong length is passed - expect_error(check_coord_limits(1:3)) + expect_snapshot(check_coord_limits(1:3), error = TRUE) }) + +test_that("coords append a column to the layout correctly", { + layout <- data_frame0(SCALE_X = c(1, 1, 1), SCALE_Y = c(1, 1, 1)) + test <- Coord$setup_layout(layout) + expect_equal(test$COORD, c(1, 1, 1)) + + layout <- data_frame0(SCALE_X = c(1, 1, 1), SCALE_Y = c(1, 2, 2)) + test <- Coord$setup_layout(layout) + expect_equal(test$COORD, c(1, 2, 2)) + + layout <- data_frame0(SCALE_X = c(1, 2, 3), SCALE_Y = c(1, 1, 1)) + test <- Coord$setup_layout(layout) + expect_equal(test$COORD, c(1, 2, 3)) + + layout <- data_frame0(SCALE_X = c(1, 2, 3), SCALE_Y = c(1, 2, 3)) + test <- Coord$setup_layout(layout) + expect_equal(test$COORD, c(1, 2, 3)) + + layout <- data_frame0(SCALE_X = c(1, 1, 1), SCALE_Y = c(1, 2, 1)) + test <- Coord$setup_layout(layout) + expect_equal(test$COORD, c(1, 2, 1)) +}) + +test_that("parse_coord_expand parses correctly", { + + p <- parse_coord_expand(FALSE) + expect_equal(p, rep(FALSE, 4)) + + p <- parse_coord_expand(c(FALSE, TRUE)) + expect_equal(p, c(FALSE, TRUE, FALSE, TRUE)) + + p <- parse_coord_expand(c(top = FALSE, left = FALSE)) + expect_equal(p, c(FALSE, TRUE, TRUE, FALSE)) + + # 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))) + 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))) + 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 23bed331ae..5bb16c4cd1 100644 --- a/tests/testthat/test-coord-cartesian.R +++ b/tests/testthat/test-coord-cartesian.R @@ -22,6 +22,19 @@ test_that("cartesian coords throws error when limits are badly specified", { expect_snapshot_error(ggplot() + coord_cartesian(ylim=1:3)) }) +test_that("cartesian coords can be reversed", { + p <- ggplot(data_frame0(x = c(0, 2), y = c(0, 2))) + + aes(x = x, y = y) + + geom_point() + + coord_cartesian( + xlim = c(-1, 3), ylim = c(-1, 3), expand = FALSE, + reverse = "xy" + ) + grob <- layer_grob(p)[[1]] + expect_equal(as.numeric(grob$x), c(0.75, 0.25)) + expect_equal(as.numeric(grob$y), c(0.75, 0.25)) +}) + # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-coord-flip.R b/tests/testthat/test-coord-flip.R index 0a346ebb24..fc63748418 100644 --- a/tests/testthat/test-coord-flip.R +++ b/tests/testthat/test-coord-flip.R @@ -4,7 +4,12 @@ test_that("secondary labels are correctly turned off", { ggplot(mtcars, aes(x = mpg, y = cyl)) + geom_point() + scale_x_continuous(sec.axis = dup_axis(guide = guide_axis(title = NULL))) + - coord_flip() + coord_flip() + + theme_test() + + theme( + panel.grid.major.y = element_line(colour = "grey80"), + panel.grid.major.x = element_line(colour = "grey90") + ) ) }) diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index 2a9b15867a..466162b0f5 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -1,7 +1,7 @@ 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, .5)) + 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)), @@ -9,7 +9,7 @@ test_that("polar distance is calculated correctly", { ) coord <- coord_polar() panel_params <- coord$setup_panel_params(scales$x, scales$y) - dists <- coord$distance(dat$theta, dat$r, panel_params) + dists <- coord$distance(dat$theta, dat$r, panel_params, boost = 1) # dists is normalized by dividing by this value, so we'll add it back # The maximum length of a spiral arc, from (t,r) = (0,0) to (2*pi,1) @@ -85,16 +85,16 @@ test_that("coord_polar can have free scales in facets", { geom_col() + coord_polar(theta = "y") - sc <- layer_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 <- layer_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 <- layer_scales(p + facet_grid(x ~ .), 1, 1) + sc <- get_panel_scales(p + facet_grid(x ~ .), 1, 1) expect_equal(sc$y$get_limits(), c(0, 2)) - sc <- layer_scales(p + facet_grid(x ~ ., scales = "free"), 1, 1) + sc <- get_panel_scales(p + facet_grid(x ~ ., scales = "free"), 1, 1) expect_equal(sc$y$get_limits(), c(0, 1)) }) @@ -155,9 +155,66 @@ 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)) + + scale_y_continuous(limits = c(0, 10)) + + grob <- get_layer_grob(p + coord_polar())[[1]] + location <- c(as.numeric(grob$x), as.numeric(grob$y)) + expect_equal(location, c(0.75, 0.25)) + + grob <- get_layer_grob(p + coord_radial())[[1]] + location <- c(as.numeric(grob$x), as.numeric(grob$y)) + expect_equal(location, c(0.75, 0.25)) + + # Check warning is thrown if only one is AsIs + p <- ggplot() + + annotate("text", x = I(0.75), y = 2.5, label = "foo") + + scale_x_continuous(limits = c(0, 10)) + + scale_y_continuous(limits = c(0, 10)) + + coord_radial() + + expect_snapshot_warning(ggplotGrob(p)) + +}) + +test_that("radial coords can be reversed", { + p <- ggplot(data_frame0(x = c(0, 2), y = c(0, 2))) + + aes(x = x, y = y) + + geom_point() + + scale_x_continuous(limits = c(-1, 3), expand = c(0, 0)) + + scale_y_continuous(limits = c(-1, 3), expand = c(0, 0)) + fwd <- coord_radial(start = 0.5 * pi, end = 1.5 * pi, reverse = "none") + rev <- coord_radial(start = 0.5 * pi, end = 1.5 * pi, reverse = "thetar") + + fwd <- layer_grob(p + fwd)[[1]] + rev <- layer_grob(p + rev)[[1]] + + expect_equal(as.numeric(fwd$x), rev(as.numeric(rev$x))) + expect_equal(as.numeric(fwd$y), rev(as.numeric(rev$y))) +}) + +test_that("coord_radial can deal with empty breaks (#6271)", { + p <- ggplot_build( + ggplot(mtcars, aes(mpg, disp)) + + geom_point() + + coord_radial() + + scale_x_continuous(breaks = numeric()) + + scale_y_continuous(breaks = numeric()) + ) + guides <- p$layout$panel_params[[1]]$guides$guides + is_none <- vapply(guides, inherits, logical(1), what = "GuideNone") + expect_true(all(is_none)) +}) # Visual tests ------------------------------------------------------------ +#TODO: Once {vdiffr} supports non-rectangular clipping paths, we should add a +# test for `coord_radial(clip = "on")`'s ability to clip to the sector + test_that("polar coordinates draw correctly", { theme <- theme_test() + theme( @@ -176,7 +233,7 @@ 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, .5), + 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", @@ -270,3 +327,20 @@ test_that("coord_radial() draws correctly", { theme ) }) + +test_that("coord_radial()'s axis internal placement works", { + + df <- data.frame(x = c(0, 360), y = c(1, 14)) + + expect_doppelganger( + "full circle with axes placed at 90 and 225 degrees", + ggplot(df, aes(x, y)) + + geom_point() + + coord_radial( + expand = FALSE, + r.axis.inside = c(90, 225) + ) + + guides(r.sec = "axis") + + theme(axis.line = element_line()) + ) +}) diff --git a/tests/testthat/test-coord-train.R b/tests/testthat/test-coord-train.R index b326fc6fe1..9d42ec3c79 100644 --- a/tests/testthat/test-coord-train.R +++ b/tests/testthat/test-coord-train.R @@ -5,7 +5,7 @@ test_that("NA's don't appear in breaks", { ns <- names(trained)[grepl("(\\.major)|(\\.minor)$", names(trained))] for (n in ns) { - if (!is.null(trained[n]) && any(is.na(trained[n]))) + if (!is.null(trained[n]) && anyNA(trained[n])) return(TRUE) } @@ -19,8 +19,8 @@ test_that("NA's don't appear in breaks", { # This is a test to make sure the later tests will be useful! # It's possible that changes to the way that breaks are calculated will # make it so that scale_break_positions will no longer give NA for range 1, 12 - expect_true(any(is.na(scale_x$break_positions()))) - expect_true(any(is.na(scale_y$break_positions()))) + expect_true(anyNA(scale_x$break_positions())) + 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))) diff --git a/tests/testthat/test-coord-transform.R b/tests/testthat/test-coord-transform.R index abb05a3cae..7621f5ed9c 100644 --- a/tests/testthat/test-coord-transform.R +++ b/tests/testthat/test-coord-transform.R @@ -10,8 +10,8 @@ test_that("warnings are generated when coord_trans() results in new infinite val # TODO: These multiple warnings should be summarized nicely. Until this gets # fixed, this test ignores all the following errors than the first one. suppressWarnings({ - expect_warning(ggplot_gtable(ggplot_build(p)), "Transformation introduced infinite values in y-axis") - expect_warning(ggplot_gtable(ggplot_build(p2)), "Transformation introduced infinite values in x-axis") + expect_snapshot_warning(ggplot_gtable(ggplot_build(p))) + expect_snapshot_warning(ggplot_gtable(ggplot_build(p2))) }) }) @@ -131,3 +131,17 @@ test_that("coord_trans() throws error when limits are badly specified", { # throws error when limit's length is different than two expect_snapshot_error(ggplot() + coord_trans(ylim=1:3)) }) + +test_that("transformed coords can be reversed", { + p <- ggplot(data_frame0(x = c(1, 100), y = c(1, 100))) + + aes(x = x, y = y) + + geom_point() + + coord_trans( + x = "log10", y = "log10", + xlim = c(0.1, 1000), ylim = c(0.1, 1000), expand = FALSE, + reverse = "xy" + ) + grob <- layer_grob(p)[[1]] + expect_equal(as.numeric(grob$x), c(0.75, 0.25)) + expect_equal(as.numeric(grob$y), c(0.75, 0.25)) +}) diff --git a/tests/testthat/test-coord_sf.R b/tests/testthat/test-coord_sf.R index bbb90e0243..a684bea20b 100644 --- a/tests/testthat/test-coord_sf.R +++ b/tests/testthat/test-coord_sf.R @@ -30,6 +30,20 @@ test_that("graticule lines can be removed via theme", { expect_doppelganger("no panel grid", plot) }) +test_that("graticule lines and axes can be removed via scales", { + skip_if_not_installed("sf") + + df <- data_frame(x = c(1, 2, 3), y = c(1, 2, 3)) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + coord_sf() + + theme_gray() + + scale_x_continuous(breaks = NULL) + + scale_y_continuous(breaks = NULL) + + expect_doppelganger("no breaks", plot) +}) + test_that("axis labels are correct for manual breaks", { skip_if_not_installed("sf") @@ -295,9 +309,50 @@ test_that("sf_transform_xy() works", { # transform back out2 <- sf_transform_xy(out, 4326, 3347) expect_identical(data$city, out2$city) - expect_true(all(abs(out2$x - data$x) < .01)) - expect_true(all(abs(out2$y - data$y) < .01)) + 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() + + annotate("text", x = I(0.75), y = I(0.25), label = "foo") + + scale_x_continuous(limits = c(-180, 180)) + + scale_y_continuous(limits = c(-80, 80)) + + coord_sf(default_crs = 4326, crs = 3857) + + 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))), + crs = 4326 # basic long-lat crs + ) + polygon <- sf::st_transform(polygon, crs = 3347) + + p <- ggplot(polygon) + geom_sf(fill = NA) + + scale_x_continuous(breaks = breaks_width(0.5)) + + scale_y_continuous(n.breaks = 4) + + b <- ggplot_build(p) + grat <- b$layout$panel_params[[1]]$graticule + expect_equal( + vec_slice(grat$degree, grat$type == "E"), + seq(-81, -74.5, by = 0.5) + ) + expect_equal( + vec_slice(grat$degree, grat$type == "N"), + seq(34, 40, by = 2) + ) }) test_that("coord_sf() uses the guide system", { @@ -332,3 +387,53 @@ test_that("coord_sf() throws error when limits are badly specified", { # throws error when limit's length is different than two expect_snapshot_error(ggplot() + coord_sf(ylim=1:3)) }) + +test_that("sf coords can be reversed", { + skip_if_not_installed("sf") + + 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, + reverse = "xy" + ) + grob <- layer_grob(p)[[1]] + expect_equal(as.numeric(grob$x), c(0.75, 0.25)) + expect_equal(as.numeric(grob$y), c(0.75, 0.25)) +}) + +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 + skip_on_cran() + + df <- sf::st_sf( + g = sf::st_sfc(sf::st_point( + # Out of bounds values for lon/lat + c(-600, 1200) + )), + crs = 4326 + ) + + # Double-check graticule is empty, suppressing warnings about oob longlat values + grat <- suppressWarnings(sf::st_graticule(df)) + expect_equal(nrow(grat), 0) + + # Plot should render + p <- suppressWarnings(layer_grob(ggplot(df) + geom_sf())[[1]]) + expect_length(p$x, 1) +}) + +test_that("coord_sf() can calculate breaks when expansion is on", { + skip_if_not_installed("sf") + df <- sf::st_multipoint(cbind(c(-180, 180), c(-90, 90))) + df <- sf::st_sfc(df, crs = 4326) + b <- ggplot_build(ggplot(df) + geom_sf()) + + x <- get_guide_data(b, "x") + y <- get_guide_data(b, "y") + expect_equal(nrow(x), 5L) + expect_equal(nrow(y), 3L) +}) diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R deleted file mode 100644 index 57acb22544..0000000000 --- a/tests/testthat/test-data.R +++ /dev/null @@ -1,25 +0,0 @@ -test_that("stringsAsFactors doesn't affect results", { - skip_if(as.integer(R.Version()$major) >= 4L, "stringsAsFactors only affects R <4.0") - - old <- getOption("stringsAsFactors") - on.exit(options(stringsAsFactors = old), add = TRUE) - - dat.character <- data_frame(x = letters[5:1], y = 1:5) - dat.factor <- data_frame(x = letters[5:1], y = 1:5) - - base <- ggplot(mapping = aes(x, y)) + geom_point() - xlabels <- function(x) x$layout$panel_params[[1]]$x$get_labels() - - options(stringsAsFactors = TRUE) - char_true <- ggplot_build(base %+% dat.character) - factor_true <- ggplot_build(base %+% dat.factor) - - options(stringsAsFactors = FALSE) - char_false <- ggplot_build(base %+% dat.character) - factor_false <- ggplot_build(base %+% dat.factor) - - expect_equal(xlabels(char_true), letters[1:5]) - expect_equal(xlabels(char_false), letters[1:5]) - expect_equal(xlabels(factor_true), letters[1:5]) - expect_equal(xlabels(factor_false), letters[1:5]) -}) diff --git a/tests/testthat/test-empty-data.R b/tests/testthat/test-empty-data.R index b9c72ced1b..e6fe24ce38 100644 --- a/tests/testthat/test-empty-data.R +++ b/tests/testthat/test-empty-data.R @@ -3,30 +3,30 @@ df0 <- data_frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = nume test_that("layers with empty data are silently omitted", { # Empty data (no visible points) d <- ggplot(df0, aes(mpg,wt)) + geom_point() - expect_equal(nrow(layer_data(d)), 0) + expect_equal(nrow(get_layer_data(d)), 0) d <- ggplot() + geom_point(data = df0, aes(mpg,wt)) - expect_equal(nrow(layer_data(d)), 0) + expect_equal(nrow(get_layer_data(d)), 0) # Regular mtcars data, x=mpg, y=wt, normal points and points from empty data frame d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_point(data = df0) - expect_equal(nrow(layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(layer_data(d, 2)), 0) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) # Regular mtcars data, but points only from empty data frame d <- ggplot(mtcars, aes(mpg, wt)) + geom_point(data = df0) - expect_equal(nrow(layer_data(d, 1)), 0) + expect_equal(nrow(get_layer_data(d, 1)), 0) }) test_that("plots with empty data and vectors for aesthetics work", { d <- ggplot(NULL, aes(1:5, 1:5)) + geom_point() - expect_equal(nrow(layer_data(d)), 5) + expect_equal(nrow(get_layer_data(d)), 5) d <- ggplot(data_frame(), aes(1:5, 1:5)) + geom_point() - expect_equal(nrow(layer_data(d)), 5) + expect_equal(nrow(get_layer_data(d)), 5) d <- ggplot() + geom_point(aes(1:5, 1:5)) - expect_equal(nrow(layer_data(d)), 5) + expect_equal(nrow(get_layer_data(d)), 5) }) test_that("layers with empty data are silently omitted with facet_wrap", { @@ -34,50 +34,52 @@ test_that("layers with empty data are silently omitted with facet_wrap", { d <- ggplot(df0, aes(mpg, wt)) + geom_point() + facet_wrap(~cyl) - expect_error(layer_data(d), "must have at least one value") + expect_snapshot(get_layer_data(d), error = TRUE) d <- d + geom_point(data = mtcars) - expect_equal(nrow(layer_data(d, 1)), 0) - expect_equal(nrow(layer_data(d, 2)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 1)), 0) + expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) }) test_that("layers with empty data are silently omitted with facet_grid", { d <- ggplot(df0, aes(mpg, wt)) + geom_point() + facet_grid(am ~ cyl) - expect_error(layer_data(d), "must have at least one value") + expect_snapshot(get_layer_data(d), error = TRUE) d <- d + geom_point(data = mtcars) - expect_equal(nrow(layer_data(d, 1)), 0) - expect_equal(nrow(layer_data(d, 2)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 1)), 0) + expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) }) test_that("empty data overrides plot defaults", { - # Should error when totally empty data frame because there's no x and y - d <- ggplot(mtcars, aes(mpg, wt)) + - geom_point() + - geom_point(data = data_frame()) - expect_error(layer_data(d), "not found") + test_that("Should error when totally empty data frame because there's no x and y", { + skip_if(getRversion() <= "4.4.0") + d <- ggplot(mtcars, aes(mpg, wt)) + + geom_point() + + geom_point(data = data_frame()) + expect_snapshot(get_layer_data(d), error = TRUE) + }) # No extra points when x and y vars don't exist but are set d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_point(data = data_frame(), x = 20, y = 3) - expect_equal(nrow(layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(layer_data(d, 2)), 0) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) # No extra points when x and y vars are empty, even when aesthetics are set d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_point(data = df0, x = 20, y = 3) - expect_equal(nrow(layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(layer_data(d, 2)), 0) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) }) test_that("layer inherits data from plot when data = NULL", { d <- ggplot(mtcars, aes(mpg, wt)) + geom_point(data = NULL) - expect_equal(nrow(layer_data(d)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d)), nrow(mtcars)) }) test_that("empty layers still generate one grob per panel", { @@ -88,13 +90,13 @@ test_that("empty layers still generate one grob per panel", { geom_point() + facet_wrap(~y) - expect_equal(length(layer_grob(d)), 3) + expect_length(get_layer_grob(d), 3) }) test_that("missing layers generate one grob per panel", { df <- data_frame(x = 1:4, y = rep(1:2, 2), g = rep(1:2, 2)) base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) - expect_equal(length(layer_grob(base)), 1) - expect_equal(length(layer_grob(base + facet_wrap(~ g))), 2) + expect_length(get_layer_grob(base), 1) + 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 5d4b176b6b..a24a5e4ca5 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -21,7 +21,7 @@ test_that("as_facets_list() coerces character vectors", { expect_identical(as_facets_list("foo"), list(foobar[1])) expect_identical(as_facets_list(c("foo", "bar")), list(foobar[1], foobar[2])) - expect_identical(wrap_as_facets_list(c("foo", "bar")), foobar) + expect_identical(compact_facets(c("foo", "bar")), foobar) }) test_that("as_facets_list() coerces lists", { @@ -43,16 +43,16 @@ test_that("as_facets_list() coerces quosures objectss", { }) test_that("facets reject aes()", { - expect_error(facet_wrap(aes(foo)), "Please use `vars()` to supply facet variables", fixed = TRUE) - expect_error(facet_grid(aes(foo)), "Please use `vars()` to supply facet variables", fixed = TRUE) + expect_snapshot(facet_wrap(aes(foo)), error = TRUE) + expect_snapshot(facet_grid(aes(foo)), error = TRUE) }) -test_that("wrap_as_facets_list() returns a quosures object with compacted", { - expect_identical(wrap_as_facets_list(vars(foo)), quos(foo = foo)) - expect_identical(wrap_as_facets_list(~foo + bar), quos(foo = foo, bar = bar)) +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)) f <- function(x) { - expect_identical(wrap_as_facets_list(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar)) + expect_identical(compact_facets(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar)) } f(NULL) @@ -71,12 +71,12 @@ test_that("grid_as_facets_list() returns a list of quosures objects with compact f() }) -test_that("wrap_as_facets_list() and grid_as_facets_list() accept empty specs", { - expect_identical(wrap_as_facets_list(NULL), quos()) - expect_identical(wrap_as_facets_list(list()), quos()) - expect_identical(wrap_as_facets_list(. ~ .), quos()) - expect_identical(wrap_as_facets_list(list(. ~ .)), quos()) - expect_identical(wrap_as_facets_list(list(NULL)), quos()) +test_that("compact_facets() and grid_as_facets_list() accept empty specs", { + expect_identical(compact_facets(NULL), quos()) + expect_identical(compact_facets(list()), quos()) + expect_identical(compact_facets(. ~ .), quos()) + 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())) @@ -92,9 +92,9 @@ test_that("facets split up the data", { l2 <- p + facet_grid(. ~ z) l3 <- p + facet_grid(z ~ .) - d1 <- layer_data(l1) - d2 <- layer_data(l2) - d3 <- layer_data(l3) + d1 <- get_layer_data(l1) + d2 <- get_layer_data(l2) + d3 <- get_layer_data(l3) expect_equal(d1, d2) expect_equal(d1, d3) @@ -105,8 +105,8 @@ test_that("facets split up the data", { l4 <- p_empty + facet_wrap(~z) l5 <- p_empty + facet_grid(. ~ z) - d4 <- layer_data(l4) - d5 <- layer_data(l5) + d4 <- get_layer_data(l4) + d5 <- get_layer_data(l5) expect_equal(d1, d4) expect_equal(d1, d5) @@ -120,7 +120,7 @@ test_that("facet_wrap() accepts vars()", { p1 <- p + facet_wrap(~z) p2 <- p + facet_wrap(vars(Z = z), labeller = label_both) - expect_identical(layer_data(p1), layer_data(p2)) + expect_identical(get_layer_data(p1), get_layer_data(p2)) }) test_that("facet_grid() accepts vars()", { @@ -165,14 +165,14 @@ test_that("facet_wrap()/facet_grid() compact the facet spec, and accept empty sp # facet_wrap() p_wrap <- p + facet_wrap(vars(NULL)) - d_wrap <- layer_data(p_wrap) + d_wrap <- get_layer_data(p_wrap) expect_equal(d_wrap$PANEL, factor(c(1L, 1L, 1L))) expect_equal(d_wrap$group, structure(c(-1L, -1L, -1L), n = 1L)) # facet_grid() p_grid <- p + facet_grid(vars(NULL)) - d_grid <- layer_data(p_grid) + d_grid <- get_layer_data(p_grid) expect_equal(d_grid$PANEL, factor(c(1L, 1L, 1L))) expect_equal(d_grid$group, structure(c(-1L, -1L, -1L), n = 1L)) @@ -325,6 +325,18 @@ test_that("facet_wrap `axes` can draw inner axes.", { expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2) }) +test_that("facet_wrap throws deprecation messages", { + withr::local_options(lifecycle_verbosity = "warning") + + facet <- facet_wrap(vars(year)) + facet$params$dir <- "h" + + lifecycle::expect_deprecated( + ggplot_build(ggplot(mpg, aes(displ, hwy)) + geom_point() + facet), + "Internal use of" + ) +}) + # Variable combinations --------------------------------------------------- test_that("zero-length vars in combine_vars() generates zero combinations", { @@ -341,9 +353,9 @@ test_that("at least one layer must contain all facet variables in combine_vars() test_that("at least one combination must exist in combine_vars()", { df <- data_frame(letter = character(0)) - expect_error( + expect_snapshot( combine_vars(list(df), vars = vars(letter = letter)), - "Faceting variables must have at least one value" + error = TRUE ) }) @@ -451,15 +463,15 @@ test_that("eval_facet() is tolerant for missing columns (#2963)", { ) # If the expression contains any non-existent variable, it fails - expect_error( + expect_snapshot( eval_facet(quo(no_such_variable * x), data_frame(foo = 1), possible_columns = c("x")), - "object 'no_such_variable' not found" + error = TRUE ) }) -test_that("validate_facets() provide meaningful errors", { - expect_snapshot_error(validate_facets(aes(var))) - expect_snapshot_error(validate_facets(ggplot())) +test_that("check_vars() provide meaningful errors", { + expect_snapshot_error(check_vars(aes(var))) + expect_snapshot_error(check_vars(ggplot())) }) test_that("check_layout() throws meaningful errors", { diff --git a/tests/testthat/test-facet-labels.R b/tests/testthat/test-facet-labels.R index 6d086e0b7b..01fe866a92 100644 --- a/tests/testthat/test-facet-labels.R +++ b/tests/testthat/test-facet-labels.R @@ -86,7 +86,7 @@ test_that("labeller() dispatches labellers", { # facet_wrap() shouldn't get both rows and cols p3 <- p + facet_wrap(~cyl, labeller = labeller( .cols = label_both, .rows = label_both)) - expect_error(ggplotGrob(p3)) + expect_snapshot(ggplotGrob(p3), error = TRUE) # facet_grid() can get both rows and cols p4 <- p + facet_grid(am ~ cyl, labeller = labeller( @@ -98,7 +98,7 @@ test_that("labeller() dispatches labellers", { # margin-wide labeller p5 <- p + facet_wrap(~cyl, labeller = labeller( .rows = label_both, cyl = label_value)) - expect_error(ggplotGrob(p5)) + expect_snapshot(ggplotGrob(p5), error = TRUE) # Variables can be attributed labellers p6 <- p + facet_grid(am + cyl ~ ., labeller = labeller( @@ -130,18 +130,12 @@ test_that("as_labeller() deals with non-labellers", { expect_equal(get_labels_matrix(p2), cbind(c("0-foo", "1-foo"))) }) -test_that("old school labellers still work", { +test_that("old school labellers are deprecated", { my_labeller <- function(variable, value) { paste0("var = ", as.character(value)) } - expect_warning(p <- - ggplot(mtcars, aes(disp, drat)) + - geom_point() + - facet_grid(~cyl, labeller = my_labeller)) - - expected_labels <- cbind(paste("var =", c(4, 6, 8))) - expect_identical(get_labels_matrix(p, "cols"), expected_labels) + lifecycle::expect_defunct(facet_grid(~cyl, labeller = my_labeller)) }) @@ -157,3 +151,30 @@ test_that("parsed labels are rendered correctly", { 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"), + f1 = c("A", "B"), + f2 = c("C", "D") + ) + + # By default, axis labels are inside-justified so it doesn't matter whether + # justification occurs across panels. This changes for outside-justification. + # See #5820 + + p <- ggplot(df, aes(x, y)) + + geom_point() + + 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.x.bottom = element_text(vjust = 0) + ) + + expect_doppelganger("outside-justified labels", p) +}) diff --git a/tests/testthat/test-facet-layout.R b/tests/testthat/test-facet-layout.R index 9ab6e80eeb..a008a0c80d 100644 --- a/tests/testthat/test-facet-layout.R +++ b/tests/testthat/test-facet-layout.R @@ -32,6 +32,44 @@ test_that("grid: includes all combinations", { 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$COL, c(1:3, 1:2)) + + test <- panel_layout(facet_wrap(~x, dir = "tl"), dummy) + expect_equal(test$ROW, c(1, 2, 1, 2, 1)) + expect_equal(test$COL, c(1, 1, 2, 2, 3)) + + test <- panel_layout(facet_wrap(~x, dir = "lb"), dummy) + expect_equal(test$ROW, c(2, 2, 2, 1, 1)) + expect_equal(test$COL, c(1, 2, 3, 1, 2)) + + test <- panel_layout(facet_wrap(~x, dir = "bl"), dummy) + expect_equal(test$ROW, c(2, 1, 2, 1, 2)) + expect_equal(test$COL, c(1, 1, 2, 2, 3)) + + test <- panel_layout(facet_wrap(~x, dir = "rt"), dummy) + expect_equal(test$ROW, c(1, 1, 1, 2, 2)) + expect_equal(test$COL, c(3, 2, 1, 3, 2)) + + test <- panel_layout(facet_wrap(~x, dir = "tr"), dummy) + expect_equal(test$ROW, c(1, 2, 1, 2, 1)) + expect_equal(test$COL, c(3, 3, 2, 2, 1)) + + test <- panel_layout(facet_wrap(~x, dir = "rb"), dummy) + expect_equal(test$ROW, c(2, 2, 2, 1, 1)) + expect_equal(test$COL, c(3, 2, 1, 3, 2)) + + 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)) roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a)) @@ -100,7 +138,8 @@ test_that("grid: as.table reverses rows", { a2 <- data_frame( a = factor(1:3, levels = 1:4), - b = factor(1:3, levels = 4:1) + b = factor(1:3, levels = 4:1), + c = as.character(c(1:2, NA)) ) test_that("wrap: drop = FALSE preserves unused levels", { @@ -111,6 +150,11 @@ test_that("wrap: drop = FALSE preserves unused levels", { wrap_b <- panel_layout(facet_wrap(~b, drop = FALSE), list(a2)) expect_equal(nrow(wrap_b), 4) expect_equal(as.character(wrap_b$b), as.character(4:1)) + + # NA character should not be dropped or throw errors #5485 + wrap_c <- panel_layout(facet_wrap(~c, drop = FALSE), list(a2)) + expect_equal(nrow(wrap_c), 3) + expect_equal(wrap_c$c, a2$c) }) test_that("grid: drop = FALSE preserves unused levels", { @@ -128,6 +172,25 @@ test_that("grid: drop = FALSE preserves unused levels", { 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() + + scale_x_continuous(limits = c(0, NA), expand = c(0, 0)) + + scale_y_continuous(limits = c(0, NA), expand = c(0, 0)) + + # Test free_x + gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_x", space = "free_x")) + test <- gt$widths[panel_cols(gt)$l] + expect_equal(as.numeric(test), 1:3) + + # Test free_y + gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_y", space = "free_y")) + test <- gt$heights[panel_rows(gt)$t] + expect_equal(as.numeric(test), 1:3) +}) + # Missing behaviour ---------------------------------------------------------- a3 <- data_frame( @@ -163,6 +226,8 @@ test_that("facet_wrap throws errors at bad layout specs", { expect_snapshot_error(facet_wrap(~test, nrow = -1)) expect_snapshot_error(facet_wrap(~test, nrow = 1.5)) + expect_snapshot_warning(facet_wrap(~test, nrow = 2, space = "free_x")) + p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + facet_wrap(~gear, ncol = 1, nrow = 1) @@ -188,6 +253,23 @@ test_that("facet_grid throws errors at bad layout specs", { expect_snapshot_error(ggplotGrob(p)) }) +test_that("facet_grid can respect coord aspect with free scales/space", { + df <- expand.grid(x = letters[1:6], y = LETTERS[1:3]) + p <- ggplot(df, aes(x, y)) + + geom_tile() + + facet_grid( + rows = vars(y == "C"), + cols = vars(x %in% c("e", "f")), + scales = "free", space = "free" + ) + + coord_fixed(3, expand = FALSE) + gt <- ggplotGrob(p) + 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(height), c(6, 3)) +}) + test_that("facet_wrap and facet_grid throws errors when using reserved words", { mtcars2 <- mtcars mtcars2$PANEL <- mtcars2$cyl diff --git a/tests/testthat/test-facet-map.R b/tests/testthat/test-facet-map.R index 35e3256958..d6d1d0c79a 100644 --- a/tests/testthat/test-facet-map.R +++ b/tests/testthat/test-facet-map.R @@ -22,6 +22,10 @@ test_that("margins add extra data", { loc <- panel_map_one(facet_grid(a~b, margins = "b"), df) expect_equal(nrow(loc), nrow(df) * 2) + + # For variables including computation (#1864) + loc <- panel_map_one(facet_grid(a ~ I(b + 1), margins = TRUE), df) + expect_equal(nrow(loc), nrow(df) * 4) }) test_that("grid: missing facet columns are duplicated", { @@ -89,6 +93,67 @@ test_that("wrap and grid can facet by a POSIXct variable", { expect_equal(loc_grid_row$PANEL, factor(1:3)) }) +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) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + +test_that("grid: 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(colour = "green", layout = "fixed_rows") + + geom_point(colour = "purple", layout = "fixed_cols") + + geom_point() + + geom_point(colour = "blue", layout = 5) + + facet_grid(x ~ y) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(rep(1:6, 3)) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(rep(1:6, 2)) + ) + expect_equal( + table(get_layer_data(b, i = 4L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 5L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + + # Missing behaviour ---------------------------------------------------------- a3 <- data_frame( diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index 1ee8792e99..d13f8d500c 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -135,38 +135,54 @@ test_that("strips can be removed", { expect_true(all(sapply(strip_grobs, inherits, 'zeroGrob'))) }) -test_that("strips can be removed", { - dat <- data_frame(a = rep(LETTERS[1:10], 10), x = rnorm(100), y = rnorm(100)) - g <- ggplot(dat, aes(x = x, y = y)) + - geom_point() + - facet_wrap(~a) + - theme(strip.background = element_blank(), strip.text = element_blank()) - g_grobs <- ggplotGrob(g) - strip_grobs <- g_grobs$grobs[grepl('strip-', g_grobs$layout$name)] - expect_true(all(sapply(strip_grobs, inherits, 'zeroGrob'))) -}) - test_that("padding is only added if axis is present", { p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + - facet_grid(. ~ drv) + + facet_grid(year ~ drv) + theme( strip.placement = "outside", strip.switch.pad.grid = unit(10, "mm") ) pg <- ggplotGrob(p) - expect_equal(length(pg$heights), 17) + expect_length(pg$heights, 19) + expect_length(pg$widths, 18) - pg <- ggplotGrob(p + scale_x_continuous(position = "top")) - expect_equal(length(pg$heights), 18) + pg <- ggplotGrob( + p + scale_x_continuous(position = "top") + + scale_y_continuous(position = "right") + ) + expect_length(pg$heights, 20) expect_equal(as.character(pg$heights[9]), "1cm") + expect_length(pg$widths, 19) + expect_equal(as.character(pg$widths[13]), "1cm") # Also add padding with negative ticks and no text (#5251) pg <- ggplotGrob( p + scale_x_continuous(labels = NULL, position = "top") + theme(axis.ticks.length.x.top = unit(-2, "mm")) ) - expect_equal(length(pg$heights), 18) + expect_length(pg$heights, 20) expect_equal(as.character(pg$heights[9]), "1cm") + + # Inverse should be true when strips are switched + p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + + facet_grid(year ~ drv, switch = "both") + + theme( + strip.placement = "outside", + strip.switch.pad.grid = unit(10, "mm") + ) + + pg <- ggplotGrob(p) + expect_length(pg$heights, 20) + expect_equal(as.character(pg$heights[13]), "1cm") + expect_length(pg$widths, 19) + expect_equal(as.character(pg$widths[7]), "1cm") + + pg <- ggplotGrob( + p + scale_x_continuous(position = "top") + + scale_y_continuous(position = "right") + ) + expect_length(pg$heights, 19) + expect_length(pg$widths, 18) }) test_that("y strip labels are rotated when strips are switched", { @@ -193,3 +209,21 @@ test_that("strip clipping can be set from the theme", { expect_equal(strip$x$top[[1]]$layout$clip, "off") }) +test_that("strip labels can be accessed", { + + expect_null(get_strip_labels(ggplot())) + + expect_equal( + get_strip_labels(ggplot() + facet_wrap(vars("X", "Y"))), + list(facets = data_frame0(`"X"` = "X", `"Y"` = "Y")) + ) + + expect_equal( + get_strip_labels(ggplot() + facet_grid(vars("X"), vars("Y"))), + list( + cols = data_frame0(`"Y"` = "Y"), + rows = data_frame0(`"X"` = "X") + ) + ) +}) + diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 03980c19c1..e98edad549 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -11,7 +11,7 @@ test_that("spatial polygons have correct ordering", { y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2)) } - make_hole <- function(x = 0, y = 0, height = .5, width = .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 @@ -67,12 +67,12 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Not even data-frame-like - expect_error(fortify(X)) - expect_error(fortify(array(1:60, 5:3))) + expect_snapshot(fortify(X), error = TRUE) + expect_snapshot(fortify(array(1:60, 5:3)), error = TRUE) # Unhealthy data-frame-like (matrix with no colnames) - expect_error(fortify(cbind(X, Y, Z, deparse.level=0))) + expect_snapshot(fortify(cbind(X, Y, Z, deparse.level=0)), error = TRUE) # Healthy data-frame-like (matrix with colnames) @@ -100,25 +100,27 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Rejected by fortify.default() because of unhealthy dim() behavior + skip_if(getRversion() <= "4.4.0") + dim.foo <- function(x) stop("oops!") registerS3method("dim", "foo", dim.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) dim.foo <- function(x) c(length(x), 2) registerS3method("dim", "foo", dim.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) dim.foo <- function(x) 5:2 registerS3method("dim", "foo", dim.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) dim.foo <- function(x) c(length(x), NA_integer_) registerS3method("dim", "foo", dim.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) dim.foo <- function(x) c(length(x), -5L) registerS3method("dim", "foo", dim.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) # Repair dim() @@ -129,18 +131,18 @@ test_that("fortify.default can handle healthy data-frame-like objects", { dimnames.foo <- function(x) list() # this breaks colnames() registerS3method("dimnames", "foo", dimnames.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) dimnames.foo <- function(x) list(format(seq_along(x)), toupper) registerS3method("dimnames", "foo", dimnames.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) # Rejected by fortify.default() because behaviors of dim() and colnames() # don't align dimnames.foo <- function(x) list(NULL, c("X1", "X2", "X3")) registerS3method("dimnames", "foo", dimnames.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) # Repair colnames() @@ -151,20 +153,21 @@ test_that("fortify.default can handle healthy data-frame-like objects", { as.data.frame.foo <- function(x, row.names = NULL, ...) stop("oops!") registerS3method("as.data.frame", "foo", as.data.frame.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) as.data.frame.foo <- function(x, row.names = NULL, ...) "whatever" registerS3method("as.data.frame", "foo", as.data.frame.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) as.data.frame.foo <- function(x, row.names = NULL, ...) data.frame() registerS3method("as.data.frame", "foo", as.data.frame.foo) - expect_error(fortify(object)) + + expect_snapshot(fortify(object), error = TRUE) 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))) } registerS3method("as.data.frame", "foo", as.data.frame.foo) - expect_error(fortify(object)) + expect_snapshot(fortify(object), error = TRUE) }) diff --git a/tests/testthat/test-function-args.R b/tests/testthat/test-function-args.R index 22b59a394f..cb4586c5d7 100644 --- a/tests/testthat/test-function-args.R +++ b/tests/testthat/test-function-args.R @@ -13,7 +13,7 @@ test_that("geom_xxx and GeomXxx$draw arg defaults match", { geom_fun_names, c("geom_map", "geom_sf", "geom_smooth", "geom_column", "geom_area", "geom_density", "annotation_custom", "annotation_map", "annotation_raster", - "annotation_id") + "annotation_id", "geom_errorbarh") ) # For each geom_xxx function and the corresponding GeomXxx$draw and diff --git a/tests/testthat/test-geom-.R b/tests/testthat/test-geom-.R index 409aa19b8f..6766178f22 100644 --- a/tests/testthat/test-geom-.R +++ b/tests/testthat/test-geom-.R @@ -6,7 +6,44 @@ test_that("aesthetic checking in geom throws correct errors", { expect_snapshot_error(check_aesthetics(aes, 4)) }) +test_that("get_geom_defaults can use various sources", { + test <- get_geom_defaults(geom_point) + expect_equal(test$colour, "black") + + test <- get_geom_defaults(geom_point(colour = "red")) + expect_equal(test$colour, "red") + + test <- get_geom_defaults("point") + expect_equal(test$colour, "black") + + test <- get_geom_defaults(GeomPoint, theme(geom = element_geom("red"))) + expect_equal(test$colour, "red") +}) + +test_that("geom defaults can be set and reset", { + l <- geom_point() + orig <- l$geom$default_aes$colour + test <- get_geom_defaults(l) + expect_equal(test$colour, "black") + + inv <- update_geom_defaults("point", list(colour = "red")) + test <- get_geom_defaults(l) + expect_equal(test$colour, "red") + expect_equal(inv$colour, orig) + + inv <- update_geom_defaults("point", NULL) + test <- get_geom_defaults(l) + expect_equal(test$colour, "black") + expect_equal(inv$colour, "red") + + inv <- update_geom_defaults("line", list(colour = "blue")) + reset <- reset_geom_defaults() + + expect_equal(reset$geom_line$colour, "blue") + expect_equal(reset$geom_point$colour, GeomPoint$default_aes$colour) + expect_equal(GeomLine$default_aes$colour, inv$colour) +}) test_that("updating geom aesthetic defaults preserves class and order", { @@ -23,7 +60,7 @@ test_that("updating geom aesthetic defaults preserves class and order", { expect_equal(updated_defaults, intended_defaults) - update_geom_defaults("point", original_defaults) + update_geom_defaults("point", NULL) }) @@ -46,6 +83,6 @@ test_that("updating stat aesthetic defaults preserves class and order", { expect_equal(updated_defaults, intended_defaults) - update_stat_defaults("bin", original_defaults) + update_stat_defaults("bin", NULL) }) diff --git a/tests/testthat/test-geom-bar.R b/tests/testthat/test-geom-bar.R index b21a2f5a64..4fb34ef4e6 100644 --- a/tests/testthat/test-geom-bar.R +++ b/tests/testthat/test-geom-bar.R @@ -3,21 +3,19 @@ test_that("geom_bar removes bars with parts outside the plot limits", { p <- ggplot(dat, aes(x)) + geom_bar() - expect_warning( # warning created at render stage - ggplotGrob(p + ylim(0, 2.5)), - "Removed 1 row containing missing values or values outside the scale range" - ) + # warning created at render stage + expect_snapshot_warning(ggplotGrob(p + ylim(0, 2.5))) }) test_that("geom_bar works in both directions", { dat <- data_frame(x = c("a", "b", "b", "c", "c", "c")) p <- ggplot(dat, aes(x)) + geom_bar() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(dat, aes(y = x)) + geom_bar() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index e6cfa26416..81d37cc5a9 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -23,11 +23,11 @@ test_that("geom_boxplot works in both directions", { dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) p <- ggplot(dat, aes(x, y)) + geom_boxplot() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(dat, aes(y, x)) + geom_boxplot() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -42,22 +42,22 @@ test_that("geom_boxplot for continuous x gives warning if more than one x (#992) ggplot_build(ggplot(dat, aes) + geom_boxplot(aes) + extra) } - expect_warning(bplot(aes(x, y)), "Continuous x aesthetic") - expect_warning(bplot(aes(x, y), facet_wrap(~x)), "Continuous x aesthetic") - expect_warning(bplot(aes(Sys.Date() + x, y)), "Continuous x aesthetic") + expect_snapshot_warning(bplot(aes(x, y))) + expect_snapshot_warning(bplot(aes(x, y), facet_wrap(~x))) + expect_snapshot_warning(bplot(aes(Sys.Date() + x, y))) - expect_warning(bplot(aes(x, group = x, y)), NA) - expect_warning(bplot(aes(1, y)), NA) - expect_warning(bplot(aes(factor(x), y)), NA) - expect_warning(bplot(aes(x == 1, y)), NA) - expect_warning(bplot(aes(as.character(x), y)), NA) + expect_silent(bplot(aes(x, group = x, y))) + expect_silent(bplot(aes(1, y))) + expect_silent(bplot(aes(factor(x), y))) + expect_silent(bplot(aes(x == 1, y))) + expect_silent(bplot(aes(as.character(x), y))) }) test_that("can use US spelling of colour", { df <- data_frame(x = 1, y = c(1:5, 100)) plot <- ggplot(df, aes(x, y)) + geom_boxplot(outlier.color = "red") - gpar <- layer_grob(plot)[[1]]$children[[1]]$children[[1]]$gp + gpar <- get_layer_grob(plot)[[1]]$children[[1]]$children[[1]]$gp expect_equal(gpar$col, "#FF0000FF") }) @@ -70,7 +70,7 @@ test_that("boxes with variable widths do not overlap", { p <- ggplot(df, aes(group, value, colour = subgroup)) + geom_boxplot(varwidth = TRUE) - d <- layer_data(p)[c("xmin", "xmax")] + d <- get_layer_data(p)[c("xmin", "xmax")] xid <- find_x_overlaps(d) expect_false(any(duplicated(xid))) @@ -83,8 +83,8 @@ test_that("boxplots with a group size >1 error", { ) + geom_boxplot(stat = "identity") - expect_equal(nrow(layer_data(p, 1)), 3) - expect_snapshot_error(layer_grob(p, 1)) + expect_equal(nrow(get_layer_data(p, 1)), 3) + expect_snapshot_error(get_layer_grob(p, 1)) }) # Visual tests ------------------------------------------------------------ @@ -96,4 +96,16 @@ test_that("boxplot draws correctly", { expect_doppelganger("staples", ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + geom_boxplot(staplewidth = 0.5) ) + expect_doppelganger( + "customised style", + ggplot(mpg, aes(class, displ, colour = class)) + + geom_boxplot( + outlier.shape = 6, + whisker.linetype = 2, + median.colour = "red", + 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 17c61064d9..32840fbd9e 100644 --- a/tests/testthat/test-geom-col.R +++ b/tests/testthat/test-geom-col.R @@ -3,25 +3,20 @@ test_that("geom_col removes columns with parts outside the plot limits", { p <- ggplot(dat, aes(x, x)) + geom_col() - expect_warning( # warning created at render stage - ggplotGrob(p + ylim(0.5, 4)), - "Removed 3 rows containing missing values or values outside the scale range" - ) - expect_warning( # warning created at render stage - ggplotGrob(p + ylim(0, 2.5)), - "Removed 1 row containing missing values or values outside the scale range" - ) + # warnings created at render stage + expect_snapshot_warning(ggplotGrob(p + ylim(0.5, 4))) + expect_snapshot_warning(ggplotGrob(p + ylim(0, 2.5))) }) test_that("geom_col works in both directions", { dat <- data_frame(x = c("a", "b", "c"), y = c(1.2, 2.5, 3.1)) p <- ggplot(dat, aes(x, y)) + geom_col() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(dat, aes(y, x)) + geom_col() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -33,17 +28,17 @@ test_that("geom_col supports alignment of columns", { dat <- data_frame(x = c("a", "b"), y = c(1.2, 2.5)) p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.5) - y <- layer_data(p) + y <- get_layer_data(p) expect_equal(as.numeric(y$xmin), c(0.55, 1.55)) expect_equal(as.numeric(y$xmax), c(1.45, 2.45)) p <- ggplot(dat, aes(x, y)) + geom_col(just = 1.0) - y <- layer_data(p) + y <- get_layer_data(p) expect_equal(as.numeric(y$xmin), c(0.1, 1.1)) expect_equal(as.numeric(y$xmax), c(1.0, 2.0)) p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.0) - y <- layer_data(p) + y <- get_layer_data(p) expect_equal(as.numeric(y$xmin), c(1.0, 2.0)) expect_equal(as.numeric(y$xmax), c(1.9, 2.9)) }) diff --git a/tests/testthat/test-geom-curve.R b/tests/testthat/test-geom-curve.R new file mode 100644 index 0000000000..05f959916e --- /dev/null +++ b/tests/testthat/test-geom-curve.R @@ -0,0 +1,11 @@ +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)) + + geom_curve(arrow = arrow()) + + 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 8f9aae6024..f7159bdd80 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -11,13 +11,13 @@ test_that("dodging works", { position = "dodge", stackdir = "center" ) - df <- layer_data(p) + df <- get_layer_data(p) # Number of levels in the dodged variable ndodge <- 3 # The amount of space allocated within each dodge group - dwidth <- .9 / ndodge + dwidth <- 0.9 / ndodge # This should be the x position for each before dodging xbase <- ceiling(df$group / ndodge) @@ -36,20 +36,20 @@ test_that("dodging works", { test_that("binning works", { bp <- ggplot(dat, aes(y)) + - geom_dotplot(binwidth = .4, method = "histodot") - x <- layer_data(bp)$x + geom_dotplot(binwidth = 0.4, method = "histodot") + x <- get_layer_data(bp)$x # Need ugly hack to make sure mod function doesn't give values like -3.99999 # due to floating point error - expect_true(all(abs((x - min(x) + 1e-7) %% .4) < 1e-6)) + expect_true(all(abs((x - min(x) + 1e-7) %% 0.4) < 1e-6)) bp <- ggplot(dat, aes(x = y)) + - geom_dotplot(binwidth = .4, method = "dotdensity") - x <- layer_data(bp)$x + geom_dotplot(binwidth = 0.4, method = "dotdensity") + x <- get_layer_data(bp)$x # This one doesn't ensure that dotdensity works, but it does check that it's not # doing fixed bin sizes - expect_false(all(abs((x - min(x) + 1e-7) %% .4) < 1e-6)) + expect_false(all(abs((x - min(x) + 1e-7) %% 0.4) < 1e-6)) }) test_that("NA's result in warning from stat_bindot", { @@ -58,7 +58,7 @@ test_that("NA's result in warning from stat_bindot", { 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 = .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", { @@ -92,99 +92,99 @@ test_that("geom_dotplot draws correctly", { # Basic dotplot with binning along x axis expect_doppelganger("basic dotplot with dot-density binning, binwidth = .4", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4) + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4) ) expect_doppelganger("histodot binning (equal bin spacing)", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4, method = "histodot") + 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 = .4, 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 = .4, dotsize = 1.4, fill = "white") + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, dotsize = 1.4, fill = "white") ) # Stacking methods expect_doppelganger("stack up", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4, stackdir = "up") + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "up") ) expect_doppelganger("stack down", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4, stackdir = "down") + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "down") ) expect_doppelganger("stack center", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4, stackdir = "center") + ggplot(dat, aes(x)) + geom_dotplot(binwidth = 0.4, stackdir = "center") ) expect_doppelganger("stack centerwhole", - ggplot(dat, aes(x)) + geom_dotplot(binwidth = .4, stackdir = "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 = .4, stackdir = "up") + 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 = .4, stackdir = "down") + 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 = .4, stackdir = "center") + 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 = .4, stackdir = "centerwhole") + 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", - ggplot(dat, aes(x, fill = g)) + geom_dotplot(binwidth = .4, alpha = .4) + 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 = .4, alpha = .4, binpositions = "all") + 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 = .4, binaxis = "y", stackdir = "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 = .4, binaxis = "y", stackdir = "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 = .4, binaxis = "y", stackdir = "centerwhole", method = "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)) expect_doppelganger("bin x, three y groups, stack centerwhole", - ggplot(dat2, aes(y, x)) + geom_dotplot(binwidth = .25, binaxis = "x", stackdir = "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 = .25, binaxis = "y", stackdir = "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 = .25, binaxis = "y", stackdir = "center", binpositions = "all") + 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 = .25, binaxis = "y", stackdir = "center", binpositions = "all") + + 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, .4)) + - geom_dotplot(binwidth = .25, position = "dodge", binaxis = "y", stackdir = "center") + 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, .4)) + - geom_dotplot(binwidth = .25, position = "dodge", binaxis = "y", stackdir = "center") + + 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, .4)) + - geom_dotplot(binwidth = .2, position = "dodge", binaxis = "y", stackdir = "center") + 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 = .2, binaxis = "y", stackdir = "center") + 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 = .2, binaxis = "y", stackdir = "center") + ggplot(dat2, aes(as.numeric(x), y)) + geom_dotplot(binwidth = 0.2, binaxis = "y", stackdir = "center") ) # border width and size @@ -198,31 +198,31 @@ test_that("geom_dotplot draws correctly", { stroke = rep(c(1, 2), length.out = nrow(dat)) ) ) + - geom_dotplot(binwidth = .4, fill = "red", col = "blue") + + geom_dotplot(binwidth = 0.4, fill = "red", col = "blue") + 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 = .25, stackgroups = TRUE, binpositions = "all", alpha = 0.5) + 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 = .25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + 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 = .25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + 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", ggplot(dat2, aes(x, y, fill = g)) + - geom_dotplot(binaxis = "y", binwidth = .25, stackgroups = TRUE, method = "histodot", + 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 = .25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + + ggplot(dat2, aes(y, fill = g)) + geom_dotplot(binwidth = 0.25, stackgroups = TRUE, method = "histodot", alpha = 0.5) + facet_grid(x ~ .) ) @@ -230,11 +230,13 @@ test_that("geom_dotplot draws correctly", { dat2 <- dat dat2$x[c(1, 10)] <- NA - expect_warning(expect_doppelganger("2 NA values, dot-density binning, binwidth = .4", - ggplot(dat2, aes(x)) + geom_dotplot(binwidth = .4) + expect_snapshot_warning(expect_doppelganger( + "2 NA values, dot-density binning, binwidth = .4", + ggplot(dat2, aes(x)) + geom_dotplot(binwidth = 0.4) )) - expect_warning(expect_doppelganger("2 NA values, bin along y, stack center", - ggplot(dat2, aes(0, x)) + geom_dotplot(binwidth = .4, binaxis = "y", stackdir = "center") + 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") )) }) diff --git a/tests/testthat/test-geom-errorbar.R b/tests/testthat/test-geom-errorbar.R new file mode 100644 index 0000000000..bdfdf3f88d --- /dev/null +++ b/tests/testthat/test-geom-errorbar.R @@ -0,0 +1,16 @@ +test_that("geom_errorbarh throws deprecation messages", { + + lifecycle::expect_deprecated(geom_errorbarh()) + + p <- ggplot( + data.frame(y = "A", min = 0, max = 10), + aes(y = y, xmin = min, xmax = max) + ) + + layer( + geom = "errorbarh", + stat = "identity", + position = "identity" + ) + + lifecycle::expect_deprecated(ggplot_build(p)) +}) diff --git a/tests/testthat/test-geom-freqpoly.R b/tests/testthat/test-geom-freqpoly.R index 762b075977..09a6b7dc27 100644 --- a/tests/testthat/test-geom-freqpoly.R +++ b/tests/testthat/test-geom-freqpoly.R @@ -2,7 +2,7 @@ test_that("can do frequency polygon with categorical x", { df <- data_frame(x = rep(letters[1:3], 3:1)) p <- ggplot(df, aes(x)) + geom_freqpoly(stat = "count") - d <- layer_data(p) + d <- get_layer_data(p) expect_s3_class(d$x, "mapped_discrete") expect_equal(d$x, mapped_discrete(1:3)) diff --git a/tests/testthat/test-geom-hex.R b/tests/testthat/test-geom-hex.R index e63e159438..0934f8fd27 100644 --- a/tests/testthat/test-geom-hex.R +++ b/tests/testthat/test-geom-hex.R @@ -5,7 +5,7 @@ test_that("density and value summaries are available", { base <- ggplot(df, aes(x, y)) + geom_hex() - out <- layer_data(base) + out <- get_layer_data(base) expect_equal(nrow(out), 2) expect_equal(out$density, c(0.75, 0.25), tolerance = 1e-7) expect_equal(out$count, c(3, 1), tolerance = 1e-7) @@ -16,7 +16,7 @@ test_that("size and linetype are applied", { plot <- ggplot(df, aes(x, y)) + geom_hex(color = "red", linewidth = 4, linetype = 2) - gpar <- layer_grob(plot)[[1]]$children[[1]]$gp + gpar <- get_layer_grob(plot)[[1]]$children[[1]]$gp expect_equal(gpar$lwd, rep(4, 2) * .pt, tolerance = 1e-7) expect_equal(gpar$lty, rep(2, 2), tolerance = 1e-7) }) diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-hline-vline-abline.R index b637cd0a2f..8a324dcf4c 100644 --- a/tests/testthat/test-geom-hline-vline-abline.R +++ b/tests/testthat/test-geom-hline-vline-abline.R @@ -43,6 +43,25 @@ test_that("curved lines in map projections", { ) }) +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) + + geom_abline(aes(slope = slope, intercept = 0)) + + scale_x_continuous(limits = c(-1, 1), expand = FALSE) + + scale_y_continuous(limits = c(-1, 1), expand = FALSE) + + coord_cartesian(clip = "off") + + data <- layer_grob(p)[[1]] + + x <- c(as.numeric(data$x0), as.numeric(data$x1)) + expect_true(all(x >= 0 & x <= 1)) + + y <- c(as.numeric(data$y0), as.numeric(data$y1)) + expect_true(all(y >= 0 & y <= 1)) +}) + # Warning tests ------------------------------------------------------------ test_that("warnings are thrown when parameters cause mapping and data to be ignored", { diff --git a/tests/testthat/test-geom-label.R b/tests/testthat/test-geom-label.R index 2504787fd2..ec94fe7c4b 100644 --- a/tests/testthat/test-geom-label.R +++ b/tests/testthat/test-geom-label.R @@ -1,5 +1,5 @@ test_that("geom_label() throws meaningful errors", { - expect_snapshot_error(geom_label(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_label(position = "jitter", nudge_x = 0.5)) expect_snapshot_error(labelGrob(label = 1:3)) }) @@ -16,9 +16,20 @@ test_that("geom_label() rotates labels", { geom_label(angle = angle_in) vps <- lapply( - layer_grob(p, 1)[[1]]$children, + get_layer_grob(p, 1)[[1]]$children, `[[`, "vp" ) angle_out <- unname(vapply(vps, `[[`, numeric(1), "angle")) expect_equal(angle_in, angle_out) }) + +test_that("geom_label handles line parameters and colours", { + df <- data.frame(x = 1:3, labels = c("foo", "bar", "baz")) + + p <- ggplot(df, aes(x, label = labels, colour = labels, linewidth = x)) + + geom_label(aes(y = 1), border.colour = "black", linetype = 1) + + geom_label(aes(y = 2), text.colour = "black", linetype = 2) + + scale_linewidth(range = c(0.1, 1)) + + expect_doppelganger("geom_label with line parameters", p) +}) diff --git a/tests/testthat/test-geom-map.R b/tests/testthat/test-geom-map.R index 7e02599209..6bbfb065e4 100644 --- a/tests/testthat/test-geom-map.R +++ b/tests/testthat/test-geom-map.R @@ -2,3 +2,8 @@ test_that("geom_map() checks its input", { expect_snapshot_error(geom_map(map = letters)) expect_snapshot_error(geom_map(map = mtcars)) }) + +test_that("map_data() checks it input", { + skip_if_not_installed("maps") + expect_snapshot(map_data("world", namesonly = TRUE), error = TRUE) +}) diff --git a/tests/testthat/test-geom-path.R b/tests/testthat/test-geom-path.R index 6cf55aece9..161508459a 100644 --- a/tests/testthat/test-geom-path.R +++ b/tests/testthat/test-geom-path.R @@ -1,8 +1,8 @@ test_that("keep_mid_true drops leading/trailing FALSE", { - expect_equal(keep_mid_true(c(F, F)), c(F, F)) - expect_equal(keep_mid_true(c(F, T, F, T, F)), c(F, T, T, T, F)) - expect_equal(keep_mid_true(c(T, T, F, T, F)), c(T, T, T, T, F)) - expect_equal(keep_mid_true(c(F, T, F, T, T)), c(F, T, T, T, T)) + 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)) }) test_that("geom_path() throws meaningful error on bad combination of varying aesthetics", { @@ -35,7 +35,7 @@ test_that("stairstep() does not error with too few observations", { test_that("stairstep() exists with error when an invalid `direction` is given", { df <- data_frame(x = 1:3, y = 1:3) - expect_error(stairstep(df, direction="invalid")) + expect_snapshot(stairstep(df, direction = "invalid"), error = TRUE) }) test_that("stairstep() output is correct for direction = 'vh'", { @@ -90,11 +90,8 @@ test_that("geom_path draws correctly", { test_that("NA linetype is dropped with warning", { df <- data_frame(x = 1:2, y = 1:2, z = "a") - expect_warning( - expect_doppelganger( + expect_snapshot_warning(expect_doppelganger( "NA linetype", ggplot(df, aes(x, y)) + geom_path(linetype = NA) - ), - "containing missing values or values outside the scale range" - ) + )) }) diff --git a/tests/testthat/test-geom-quantile.R b/tests/testthat/test-geom-quantile.R index d9eaf84184..7b6feecb9b 100644 --- a/tests/testthat/test-geom-quantile.R +++ b/tests/testthat/test-geom-quantile.R @@ -8,7 +8,7 @@ test_that("geom_quantile matches quantile regression", { set.seed(6531) x <- rnorm(10) - df <- tibble::tibble( + df <- data_frame0( x = x, y = x^2 + 0.5 * rnorm(10) ) @@ -33,7 +33,7 @@ test_that("geom_quantile matches quantile regression", { # pred_rq is a matrix; convert it to data.frame so that it can be compared pred_rq <- as.data.frame(pred_rq) - ggplot_data <- layer_data(ps) + ggplot_data <- get_layer_data(ps) pred_rq_test_25 <- pred_rq[, c("x", "Q_25")] colnames(pred_rq_test_25) <- c("x", "y") diff --git a/tests/testthat/test-geom-raster.R b/tests/testthat/test-geom-raster.R index 2dfa1106e3..2a3ed66a31 100644 --- a/tests/testthat/test-geom-raster.R +++ b/tests/testthat/test-geom-raster.R @@ -6,7 +6,7 @@ test_that("geom_raster() checks input and coordinate system", { df <- data_frame(x = rep(c(-1, 1), each = 3), y = rep(-1:1, 2), z = 1:6) p <- ggplot(df, aes(x, y, fill = z)) + geom_raster() + coord_polar() - expect_snapshot_error(ggplotGrob(p)) + expect_message(ggplotGrob(p), "only works with") }) test_that("geom_raster() fails with pattern fills", { @@ -66,6 +66,14 @@ test_that("geom_raster draws correctly", { 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", + ggplot(df, aes(x, y, fill = fill)) + geom_raster() + coord_polar() + ) + ) + # Categorical fill, irregular swatches --------------------------------------- df <- expand.grid(x = 1:10, y = 1:10) diff --git a/tests/testthat/test-geom-rect.R b/tests/testthat/test-geom-rect.R new file mode 100644 index 0000000000..204df65ef2 --- /dev/null +++ b/tests/testthat/test-geom-rect.R @@ -0,0 +1,33 @@ +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) + ) + + test <- full[, c("xmin", "ymin", "width", "height")] + test <- GeomRect$setup_data(test, NULL) + expect_equal(full[, corners], test[, corners]) + + test <- full[, c("xmin", "ymin", "x", "y")] + test <- GeomRect$setup_data(test, NULL) + expect_equal(full[, corners], test[, corners]) + + test <- full[, c("x", "y", "width", "height")] + test <- GeomRect$setup_data(test, NULL) + expect_equal(full[, corners], test[, corners]) + + test <- full[, c("xmax", "ymax", "width", "height")] + test <- GeomRect$setup_data(test, NULL) + expect_equal(full[, corners], test[, corners]) + + test <- full[, c("xmax", "ymax", "x", "y")] + test <- GeomRect$setup_data(test, NULL) + expect_equal(full[, corners], test[, corners]) + + test <- full[, c("x", "y")] + expect_snapshot(GeomRect$setup_data(test, NULL), error = TRUE) +}) diff --git a/tests/testthat/test-geom-ribbon.R b/tests/testthat/test-geom-ribbon.R index bcc04bf6eb..6bd08875f1 100644 --- a/tests/testthat/test-geom-ribbon.R +++ b/tests/testthat/test-geom-ribbon.R @@ -7,19 +7,25 @@ test_that("geom_ribbon() checks the aesthetics", { 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, fill = year)) + 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")) }) -test_that("NAs are not dropped from the data", { +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))+ geom_ribbon(aes(ymin = y - 1, ymax = y + 1)) - - expect_equal(layer_data(p)$ymin, c(0, 0, NA, 0, 0)) + p <- ggplot_build(p) + + expect_equal(get_layer_data(p)$ymin, c(0, 0, NA, 0, 0)) + expect_snapshot_warning( + grob <- get_layer_grob(p)[[1]] + ) + # We expect the ribbon to be broken up into 2 parts + expect_length(grob$children, 2) }) test_that("geom_ribbon works in both directions", { @@ -28,11 +34,11 @@ test_that("geom_ribbon works in both directions", { ymax = c(4, 6, 5, 4.5, 5.2)) p <- ggplot(dat, aes(x, ymin = ymin, ymax = ymax)) + geom_ribbon() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(dat, aes(y = x, xmin = ymin, xmax = ymax)) + geom_ribbon() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -45,11 +51,11 @@ test_that("outline.type option works", { p <- ggplot(df, aes(x, ymin = -y, ymax = y)) - g_ribbon_default <- layer_grob(p + geom_ribbon())[[1]] - g_ribbon_upper <- layer_grob(p + geom_ribbon(outline.type = "upper"))[[1]] - g_ribbon_lower <- layer_grob(p + geom_ribbon(outline.type = "lower"))[[1]] - g_ribbon_full <- layer_grob(p + geom_ribbon(outline.type = "full"))[[1]] - g_area_default <- layer_grob(ggplot(df, aes(x, y)) + geom_area(stat = "identity"))[[1]] + 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]] # default expect_s3_class(g_ribbon_default$children[[1]]$children[[1]], "polygon") @@ -74,3 +80,19 @@ test_that("outline.type option works", { expect_s3_class(g_area_default$children[[1]]$children[[2]], "polyline") expect_equal(g_area_default$children[[1]]$children[[2]]$id, rep(1L, each = 4)) }) + +test_that("ribbons can have gradients", { + skip_if_not( + check_device("gradients", action = "test"), + "graphics device does not support gradients." + ) + + df <- data.frame(x = 1:2, ymin = c(-1:-2), ymax = 1:2) + p <- ggplot(df, aes(x, ymin = ymin, ymax = ymax, fill = x)) + + geom_ribbon(outline.type = "full") + + scale_fill_gradientn(colours = c("red", "blue")) + fill <- get_layer_grob(p)[[1]]$children[[1]]$gp$fill + + expect_s3_class(fill, "GridLinearGradient") + expect_equal(fill$colours, alpha(c("red", "blue"), NA)) +}) diff --git a/tests/testthat/test-geom-rug.R b/tests/testthat/test-geom-rug.R index 7171db1e10..108d030ca0 100644 --- a/tests/testthat/test-geom-rug.R +++ b/tests/testthat/test-geom-rug.R @@ -1,22 +1,22 @@ -n = 10 +n <- 10 df <- data_frame(x = 1:n, y = (1:n)^3) p <- ggplot(df, aes(x, y)) + geom_point() + geom_rug(sides = 'l') test_that("coord_flip flips the rugs", { - a <- layer_grob(p, 2) - b <- layer_grob(p + coord_flip(), 2) + a <- get_layer_grob(p, 2) + b <- get_layer_grob(p + coord_flip(), 2) # Rugs along y-axis, all x coordinates are the same - expect_equal(length(a[[1]]$children[[1]]$x0), 1) - expect_equal(length(a[[1]]$children[[1]]$x1), 1) - expect_equal(length(a[[1]]$children[[1]]$y0), n) - expect_equal(length(a[[1]]$children[[1]]$y1), n) + expect_length(a[[1]]$children[[1]]$x0, 1) + expect_length(a[[1]]$children[[1]]$x1, 1) + expect_length(a[[1]]$children[[1]]$y0, n) + expect_length(a[[1]]$children[[1]]$y1, n) # Rugs along x-axis, all y coordinates are the same - expect_equal(length(b[[1]]$children[[1]]$x0), n) - expect_equal(length(b[[1]]$children[[1]]$x1), n) - expect_equal(length(b[[1]]$children[[1]]$y0), 1) - expect_equal(length(b[[1]]$children[[1]]$y1), 1) + expect_length(b[[1]]$children[[1]]$x0, n) + expect_length(b[[1]]$children[[1]]$x1, n) + expect_length(b[[1]]$children[[1]]$y0, 1) + expect_length(b[[1]]$children[[1]]$y1, 1) }) test_that("Rug length needs unit object", { @@ -25,14 +25,14 @@ test_that("Rug length needs unit object", { }) test_that("Rug lengths are correct", { - a <- layer_grob(p, 2) + a <- get_layer_grob(p, 2) # Check default lengths 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")) - b <- layer_grob(p, 2) + b <- get_layer_grob(p, 2) # Check default length is changed expect_equal(a[[1]]$children[[1]]$x0, unit(0, "npc")) @@ -40,3 +40,17 @@ test_that("Rug lengths are correct", { }) +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) + + expect_snapshot_warning(ggplotGrob(p1)) + expect_no_warning(ggplotGrob(p2)) + } +) diff --git a/tests/testthat/test-geom-rule.R b/tests/testthat/test-geom-rule.R index e41ab41103..35bac24974 100644 --- a/tests/testthat/test-geom-rule.R +++ b/tests/testthat/test-geom-rule.R @@ -6,28 +6,28 @@ p_col <- ggplot(df, aes(x, y, colour = factor(x))) + geom_point() test_that("setting parameters makes one row df", { b <- p + geom_hline(yintercept = 1.5) - expect_equal(layer_data(b, 2)$yintercept, 1.5) + expect_equal(get_layer_data(b, 2)$yintercept, 1.5) b <- p + geom_vline(xintercept = 1.5) - expect_equal(layer_data(b, 2)$xintercept, 1.5) + expect_equal(get_layer_data(b, 2)$xintercept, 1.5) b <- p + geom_abline() - expect_equal(layer_data(b, 2)$intercept, 0) - expect_equal(layer_data(b, 2)$slope, 1) + expect_equal(get_layer_data(b, 2)$intercept, 0) + expect_equal(get_layer_data(b, 2)$slope, 1) b <- p + geom_abline(slope = 0, intercept = 1) - expect_equal(layer_data(b, 2)$intercept, 1) - expect_equal(layer_data(b, 2)$slope, 0) + expect_equal(get_layer_data(b, 2)$intercept, 1) + expect_equal(get_layer_data(b, 2)$slope, 0) }) test_that("setting aesthetics generates one row for each input row", { b <- p + geom_hline(aes(yintercept = 1.5)) - expect_equal(layer_data(b, 2)$yintercept, rep(1.5, 3)) + expect_equal(get_layer_data(b, 2)$yintercept, rep(1.5, 3)) b <- p + geom_vline(aes(xintercept = 1.5)) - expect_equal(layer_data(b, 2)$xintercept, rep(1.5, 3)) + expect_equal(get_layer_data(b, 2)$xintercept, rep(1.5, 3)) b <- p + geom_abline(aes(slope = 0, intercept = 1)) - expect_equal(layer_data(b, 2)$intercept, rep(1, 3)) - expect_equal(layer_data(b, 2)$slope, rep(0, 3)) + expect_equal(get_layer_data(b, 2)$intercept, rep(1, 3)) + expect_equal(get_layer_data(b, 2)$slope, rep(0, 3)) }) diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index af5d6bdb9d..29f5da8323 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -30,23 +30,23 @@ test_that("geom_sf() determines the legend type automatically", { } # test the automatic choice - expect_identical(fun_geom_sf(mp, TRUE)$plot$layers[[1]]$show.legend, TRUE) + 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(mls, TRUE)$plot$layers[[1]]$show.legend, TRUE) + 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(mpol, TRUE)$plot$layers[[1]]$show.legend, TRUE) - expect_identical(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "polygon") + 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") # test that automatic choice can be overridden manually - expect_identical(fun_geom_sf(mp, "point")$plot$layers[[1]]$show.legend, TRUE) + 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(mls, "point")$plot$layers[[1]]$show.legend, TRUE) + 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(mpol, "point")$plot$layers[[1]]$show.legend, TRUE) + 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") }) @@ -74,13 +74,6 @@ test_that("geom_sf() determines the legend type from mapped geometry column", { ggplot(d_sf) + geom_sf(aes(geometry = g_line, colour = "a")) ) expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "line") - - # If `geometry` is not a symbol, `LayerSf$setup_layer()` gives up guessing - # the legend type, and falls back to "polygon" - p <- ggplot_build( - ggplot(d_sf) + geom_sf(aes(geometry = identity(g_point), colour = "a")) - ) - expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "polygon") }) test_that("geom_sf() removes rows containing missing aes", { @@ -88,7 +81,7 @@ test_that("geom_sf() removes rows containing missing aes", { if (packageVersion("sf") < "0.5.3") skip("Need sf 0.5.3") grob_xy_length <- function(x) { - g <- layer_grob(x)[[1]] + g <- get_layer_grob(x)[[1]] c(length(g$x), length(g$y)) } @@ -100,19 +93,16 @@ test_that("geom_sf() removes rows containing missing aes", { ) p <- ggplot(pts) - expect_warning( - expect_identical(grob_xy_length(p + geom_sf(aes(size = size))), c(1L, 1L)), - "Removed 1 row containing missing values or values outside the scale range" + expect_snapshot_warning( + expect_identical(grob_xy_length(p + geom_sf(aes(size = size))), c(1L, 1L)) ) - expect_warning( - expect_identical(grob_xy_length(p + geom_sf(aes(shape = shape))), c(1L, 1L)), - "Removed 1 row containing missing values or values outside the scale range" + expect_snapshot_warning( + expect_identical(grob_xy_length(p + geom_sf(aes(shape = shape))), c(1L, 1L)) ) # default colour scale maps a colour even to a NA, so identity scale is needed to see if NA is removed - expect_warning( + expect_snapshot_warning( expect_identical(grob_xy_length(p + geom_sf(aes(colour = colour)) + scale_colour_identity()), - c(1L, 1L)), - "Removed 1 row containing missing values or values outside the scale range" + c(1L, 1L)) ) }) @@ -127,7 +117,7 @@ test_that("geom_sf() handles alpha properly", { ) red <- "#FF0000FF" p <- ggplot(sfc) + geom_sf(colour = red, fill = red, alpha = 0.5) - g <- layer_grob(p)[[1]] + g <- get_layer_grob(p)[[1]] # alpha affects the colour of points and lines expect_equal(g[[1]]$gp$col, alpha(red, 0.5)) @@ -147,8 +137,8 @@ test_that("errors are correctly triggered", { ) p <- ggplot(pts) + geom_sf() + coord_cartesian() expect_snapshot_error(ggplotGrob(p)) - expect_snapshot_error(geom_sf_label(position = "jitter", nudge_x = 0.5)) - expect_snapshot_error(geom_sf_text(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_sf_label(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_sf_text(position = "jitter", nudge_x = 0.5)) # #5204: missing linewidth should be dropped pts <- sf::st_sf( @@ -158,7 +148,7 @@ test_that("errors are correctly triggered", { ), linewidth = c(1, NA) ) - expect_snapshot_warning(sf_grob(pts, na.rm = FALSE)) + expect_snapshot_warning(GeomSf$handle_na(pts, list(na.rm = FALSE))) }) # Visual tests ------------------------------------------------------------ @@ -184,10 +174,10 @@ 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))) plot <- ggplot() + geom_sf(data = pts) - expect_error(regexp = NA, ggplot_build(plot)) + expect_no_error(ggplot_build(plot)) expect_doppelganger("North Carolina county boundaries", - ggplot() + geom_sf(data = nc) + coord_sf(datum = 4326) + 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))) @@ -196,6 +186,84 @@ test_that("geom_sf draws correctly", { ) }) +test_that("geom_sf data type renders appropriate legends", { + skip_if_not_installed("sf") + p <- ggplot() + geom_sf(aes(colour = col)) + + # Point data + data <- sf::st_as_sf( + data.frame(lon = c(1, 2), lat = c(3, 4), col = c("foo", "bar")), + coords = c("lon", "lat") + ) + expect_doppelganger( + "geom_sf point legend", + p %+% data + ) + + # Line data + data <- sf::st_as_sf( + sf::st_sfc( + sf::st_linestring(x = cbind(1:2, 3:4)), + sf::st_linestring(x = cbind(3:4, 5:6)) + ), + col = c("foo", "bar") + ) + expect_doppelganger( + "geom_sf line legend", + p %+% data + ) + + # Polygon data + data <- sf::st_as_sf( + sf::st_sfc( + sf::st_polygon(list(cbind(c(1, 2, 2, 1), c(3, 3, 4, 3)))), + sf::st_polygon(list(cbind(c(3, 3, 4, 3), c(5, 6, 6, 5)))) + ), + col = c("foo", "bar") + ) + expect_doppelganger( + "geom_sf polygon legend", + p %+% data + ) +}) + +test_that("geom_sf uses combinations of geometry correctly", { + skip_if_not_installed("sf") + + 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( + cbind(c(1, 1.8), c(3.8, 3)), + cbind(c(1.2, 2), c(4, 3.2)) + )), + sf::st_polygon(list( + 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_linestring(x = cbind(c(2, 6), c(-1, 3))), + sf::st_point(c(5, 0)) + )) + + update_geom_defaults("point", list(colour = "blue")) + update_geom_defaults("line", list(colour = "red")) + # Note: polygon defaults are mostly ignored or overridden + + withr::defer({ + update_geom_defaults("point", NULL) + update_geom_defaults("line", NULL) + }) + + expect_doppelganger( + "mixed geometry types", + ggplot(data) + geom_sf() + ) +}) + 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") diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index c8a7f3af32..270bf3760f 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -4,18 +4,18 @@ test_that("data is ordered by x", { ps <- ggplot(df, aes(x, y))+ geom_smooth(stat = "identity", se = FALSE) - expect_equal(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", { p <- ggplot(mpg, aes(displ, hwy)) + geom_smooth(method = 'loess', formula = y ~ x) - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(mpg, aes(hwy, displ)) + geom_smooth(orientation = "y", method = 'loess', formula = y ~ x) - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -45,7 +45,7 @@ test_that("default smoothing methods for small and large data sets work", { p <- ggplot(df, aes(x, y)) + geom_smooth() expect_message( - plot_data <- layer_data(p), + plot_data <- get_layer_data(p), "method = 'loess' and formula = 'y ~ x'" ) expect_equal(plot_data$y, as.numeric(out)) @@ -57,6 +57,8 @@ test_that("default smoothing methods for small and large data sets work", { y = x^2 + 0.5 * rnorm(1001) ) + skip_if_not_installed("mgcv") + m <- mgcv::gam(y ~ s(x, bs = "cs"), data = df, method = "REML") range <- range(df$x, na.rm = TRUE) xseq <- seq(range[1], range[2], length.out = 80) @@ -64,7 +66,7 @@ test_that("default smoothing methods for small and large data sets work", { p <- ggplot(df, aes(x, y)) + geom_smooth() expect_message( - plot_data <- layer_data(p), + plot_data <- get_layer_data(p), "method = 'gam' and formula = 'y ~ s\\(x, bs = \"cs\"\\)" ) expect_equal(plot_data$y, as.numeric(out)) @@ -73,7 +75,7 @@ test_that("default smoothing methods for small and large data sets work", { p <- ggplot(df, aes(x, y)) + geom_smooth(method = "auto") expect_message( - plot_data <- layer_data(p), + plot_data <- get_layer_data(p), "method = 'gam' and formula = 'y ~ s\\(x, bs = \"cs\"\\)" ) expect_equal(plot_data$y, as.numeric(out)) @@ -90,12 +92,24 @@ test_that("geom_smooth() works when one group fails", { geom_smooth(method = "loess", formula = y ~ x) suppressWarnings( - expect_warning(ld <- layer_data(p), "Failed to fit group 1") + expect_snapshot_warning(ld <- get_layer_data(p)) ) expect_equal(unique(ld$group), 2) expect_gte(nrow(ld), 2) }) +test_that("a fallback message is thrown when `method = 'gam'` and {mgcv} is absent", { + p <- ggplot(mpg, aes(displ, hwy)) + + geom_smooth(method = "gam", formula = y ~ x) + + with_mocked_bindings( + expect_message( + ggplot_build(p), regexp = "Falling back to `method = \"lm\"`" + ), + is_installed = function(...) FALSE + ) +}) + # Visual tests ------------------------------------------------------------ test_that("geom_smooth() works with alternative stats", { diff --git a/tests/testthat/test-geom-text.R b/tests/testthat/test-geom-text.R index 36c52a14a0..8fe509e724 100644 --- a/tests/testthat/test-geom-text.R +++ b/tests/testthat/test-geom-text.R @@ -1,5 +1,5 @@ test_that("geom_text() checks input", { - expect_snapshot_error(geom_text(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_text(position = "jitter", nudge_x = 0.5)) }) test_that("geom_text() drops missing angles", { @@ -12,27 +12,24 @@ test_that("geom_text() drops missing angles", { ) df$angle <- NA - expect_warning( - geom$geom$handle_na(df, geom$geom_params), - "Removed 1 row" - ) + expect_snapshot_warning(geom$geom$handle_na(df, geom$geom_params)) }) test_that("geom_text() accepts mm and pt size units", { p <- ggplot(data_frame0(x = 1, y = 1, label = "A"), aes(x, y, label = label)) - grob <- layer_grob(p + geom_text(size = 10, size.unit = "mm"))[[1]] + grob <- get_layer_grob(p + geom_text(size = 10, size.unit = "mm"))[[1]] expect_equal(grob$gp$fontsize, 10 * .pt) - grob <- layer_grob(p + geom_text(size = 10, size.unit = "pt"))[[1]] + grob <- get_layer_grob(p + geom_text(size = 10, size.unit = "pt"))[[1]] expect_equal(grob$gp$fontsize, 10) }) test_that("geom_text() rejects exotic units", { p <- ggplot(data_frame0(x = 1, y = 1, label = "A"), aes(x, y, label = label)) - expect_error( + expect_snapshot( ggplotGrob(p + geom_text(size = 10, size.unit = "npc")), - "must be one of" + error = TRUE ) }) diff --git a/tests/testthat/test-geom-tile.R b/tests/testthat/test-geom-tile.R index d0c8a6f073..9034e3c9f7 100644 --- a/tests/testthat/test-geom-tile.R +++ b/tests/testthat/test-geom-tile.R @@ -1,11 +1,11 @@ test_that("accepts width and height params", { df <- data_frame(x = c("a", "b"), y = c("a", "b")) - out1 <- layer_data(ggplot(df, aes(x, y)) + geom_tile()) + out1 <- get_layer_data(ggplot(df, aes(x, y)) + geom_tile()) 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 <- 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))) }) @@ -15,22 +15,36 @@ test_that("accepts width and height aesthetics", { p <- ggplot(df, aes(x, y, width = width, height = height)) + geom_tile(fill = NA, colour = "black", linewidth = 1) - out <- layer_data(p) + out <- get_layer_data(p) - boundary <- as.data.frame(tibble::tribble( - ~xmin, ~xmax, ~ymin, ~ymax, - -1, 1, -1, 1, - -2, 2, -2, 2 - )) + boundary <- data_frame0( + 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) }) test_that("accepts linejoin parameter", { df <- data_frame(x = c("a", "b"), y = c("a", "b")) - gp1 <- layer_grob(ggplot(df, aes(x, y)) + geom_tile())[[1]]$gp + gp1 <- get_layer_grob(ggplot(df, aes(x, y)) + geom_tile())[[1]]$gp expect_equal(gp1$linejoin, "mitre") - gp2 <- 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") }) + +test_that("width and height are inferred per panel", { + df <- data_frame0( + x = c(1, 2, 3, 10, 20, 30), + y = c(10, 10.5, 11, 100, 200, 300), + f = rep(c("A", "B"), each = 3) + ) + + ld <- get_layer_data( + ggplot(df, aes(x, y)) + geom_tile() + facet_wrap(~f, scales = "free") + ) + + expect_equal(ld$xmax - ld$xmin, c(1, 1, 1, 10, 10, 10)) + expect_equal(ld$ymax - ld$ymin, c(0.5, 0.5, 0.5, 100, 100, 100)) +}) diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index 5633e85d8f..ff3cae8de8 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -10,17 +10,17 @@ 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(layer_scales(p, 1)$y$dimension(), c(0 - expand_a, 1 + expand_a)) - expect_equal(layer_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", { p <- ggplot(mpg) + geom_violin(aes(drv, hwy)) - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(mpg) + geom_violin(aes(hwy, drv)) - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -40,18 +40,19 @@ test_that("create_quantile_segment_frame functions for 3 quantiles", { test_that("quantiles do not fail on zero-range data", { zero.range.data <- data_frame(y = rep(1,3)) - p <- ggplot(zero.range.data) + geom_violin(aes(1, y), draw_quantiles = 0.5) + p <- ggplot(zero.range.data) + + geom_violin(aes(1, y), quantiles = 0.5, quantile.linetype = NULL) # This should return without error and have length one - expect_equal(length(layer_grob(p)), 1) + expect_length(get_layer_grob(p), 1) }) test_that("quantiles fails outside 0-1 bound", { p <- ggplot(mtcars) + - geom_violin(aes(as.factor(gear), mpg), draw_quantiles = c(-1, 0.5)) + geom_violin(aes(as.factor(gear), mpg), quantiles = c(-1, 0.5)) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + - geom_violin(aes(as.factor(gear), mpg), draw_quantiles = c(0.5, 2)) + geom_violin(aes(as.factor(gear), mpg), quantiles = c(0.5, 2)) expect_snapshot_error(ggplotGrob(p)) }) @@ -70,9 +71,9 @@ test_that("quantiles do not issue warning", { data <- data_frame(x = 1, y = c(0, 0.25, 0.5, 0.75, 5)) p <- ggplot(data, aes(x = x, y = y)) + - geom_violin(draw_quantiles = 0.5) + geom_violin(quantiles = 0.5, quantile.linetype = NULL) - expect_warning(plot(p), regexp = NA) + expect_silent(plot(p)) }) @@ -81,7 +82,7 @@ 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(T, F),] # 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() @@ -90,13 +91,13 @@ test_that("geom_violin draws correctly", { ggplot(dat, aes(x = x, y = y)) + geom_violin(scale = "count"), ) expect_doppelganger("narrower (width=.5)", - ggplot(dat, aes(x = x, y = y)) + geom_violin(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 smaller bandwidth and points", - ggplot(dat, aes(x = x, y = y)) + geom_violin(adjust = .3) + geom_point(shape = 21) + ggplot(dat, aes(x = x, y = y)) + geom_violin(adjust = 0.3) + geom_point(shape = 21) ) expect_doppelganger("dodging", ggplot(dat, aes(x = "foo", y = y, fill = x)) + geom_violin() @@ -116,8 +117,13 @@ test_that("geom_violin draws correctly", { 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("quantiles", - ggplot(dat, aes(x=x, y=y)) + geom_violin(draw_quantiles=c(0.25,0.5,0.75)) + expect_doppelganger("styled quantiles", + ggplot(dat, aes(x=x, y=y)) + + geom_violin( + quantile.colour = "red", + quantile.linetype = "dotted", + quantile.linewidth = 2 + ) ) dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(letters[5:6]), 45)) @@ -126,6 +132,6 @@ test_that("geom_violin draws correctly", { ) 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 = .5)) + geom_violin(position = position_dodge(width = 0.5)) ) }) diff --git a/tests/testthat/test-ggsave.R b/tests/testthat/test-ggsave.R index 43af6fd715..af254f9f84 100644 --- a/tests/testthat/test-ggsave.R +++ b/tests/testthat/test-ggsave.R @@ -16,7 +16,10 @@ test_that("ggsave can create directories", { p <- ggplot(mpg, aes(displ, hwy)) + geom_point() - expect_error(ggsave(path, p)) + expect_snapshot( + ggsave(path, p), error = TRUE, + transform = function(x) gsub("directory '.*'\\.$", "directory 'PATH'", x) + ) expect_false(dir.exists(dirname(path))) # 2 messages: 1 for saving and 1 informing about directory creation @@ -83,23 +86,20 @@ test_that("ggsave warns about empty or multiple filenames", { plot <- ggplot(mtcars, aes(disp, mpg)) + geom_point() withr::with_tempfile(c("file1", "file2"), fileext = ".png", { - expect_warning( - suppressMessages(ggsave(c(file1, file2), plot)), - "`filename` must have length 1" + expect_snapshot( + x <- suppressMessages(ggsave(c(file1, file2), plot)), + transform = function(x) gsub(" \\'.*\\.png\\'", "'PATH'", x) ) }) - expect_error( - ggsave(character(), plot), - "`filename` must be a single string" - ) + expect_snapshot(ggsave(character(), plot), error = TRUE) }) test_that("ggsave fails informatively for no-extension filenames", { plot <- ggplot(mtcars, aes(disp, mpg)) + geom_point() - expect_error( - ggsave(tempfile(), plot), - "Can't save to" + expect_snapshot( + ggsave(tempfile(), plot), error = TRUE, + transform = function(x) gsub("to .*\\.$", "to PATH", x) ) }) @@ -118,9 +118,9 @@ test_that("uses 7x7 if no graphics device open", { }) test_that("warned about large plot unless limitsize = FALSE", { - expect_error(plot_dim(c(50, 50)), "exceed 50 inches") + expect_snapshot(plot_dim(c(50, 50)), error = TRUE) expect_equal(plot_dim(c(50, 50), limitsize = FALSE), c(50, 50)) - expect_error(plot_dim(c(15000, 15000), units = "px"), "in pixels).") + expect_snapshot(plot_dim(c(15000, 15000), units = "px"), error = TRUE) }) test_that("scale multiplies height & width", { @@ -131,19 +131,19 @@ test_that("scale multiplies height & width", { # plot_dev --------------------------------------------------------------------- test_that("unknown device triggers error", { - expect_snapshot_error(plot_dev(1)) - expect_error(plot_dev("xyz"), "Unknown graphics device") - expect_error(plot_dev(NULL, "test.xyz"), "Unknown graphics device") + expect_snapshot_error(validate_device(1)) + expect_snapshot(validate_device("xyz"), error = TRUE) + expect_snapshot(validate_device(NULL, "test.xyz"), error = TRUE) }) test_that("text converted to function", { - expect_identical(body(plot_dev("png"))[[1]], quote(png_dev)) - expect_identical(body(plot_dev("pdf"))[[1]], quote(grDevices::pdf)) + expect_identical(body(validate_device("png"))[[1]], quote(png_dev)) + expect_identical(body(validate_device("pdf"))[[1]], quote(grDevices::pdf)) }) test_that("if device is NULL, guess from extension", { - expect_identical(body(plot_dev(NULL, "test.png"))[[1]], quote(png_dev)) + expect_identical(body(validate_device(NULL, "test.png"))[[1]], quote(png_dev)) }) # parse_dpi --------------------------------------------------------------- diff --git a/tests/testthat/test-guide-.R b/tests/testthat/test-guide-.R new file mode 100644 index 0000000000..4f66920c3e --- /dev/null +++ b/tests/testthat/test-guide-.R @@ -0,0 +1,49 @@ +skip_on_cran() + +test_that("plotting does not induce state changes in guides", { + + guides <- guides( + x = guide_axis(title = "X-axis"), + colour = guide_colourbar(title = "Colourbar"), + shape = guide_legend(title = "Legend"), + size = guide_bins(title = "Bins") + ) + + p <- ggplot(mpg, aes(displ, hwy, colour = cty, shape = factor(cyl), + size = cyl)) + + geom_point() + + guides + + snapshot <- serialize(as.list(p$guides), NULL) + + grob <- ggplotGrob(p) + + expect_identical(as.list(p$guides), unserialize(snapshot)) +}) + +test_that("adding guides doesn't change plot state", { + + p1 <- ggplot(mtcars, aes(disp, mpg)) + + expect_length(p1$guides$guides, 0) + + p2 <- p1 + guides(y = guide_axis(angle = 45)) + + expect_length(p1$guides$guides, 0) + expect_length(p2$guides$guides, 1) + + p3 <- p2 + guides(y = guide_axis(angle = 90)) + + expect_length(p3$guides$guides, 1) + expect_equal(p3$guides$guides[[1]]$params$angle, 90) + expect_equal(p2$guides$guides[[1]]$params$angle, 45) +}) + +test_that("dots are checked when making guides", { + expect_snapshot_warning( + new_guide(foo = "bar", super = GuideAxis) + ) + expect_snapshot_warning( + guide_legend(foo = "bar") + ) +}) diff --git a/tests/testthat/test-guide-axis.R b/tests/testthat/test-guide-axis.R new file mode 100644 index 0000000000..5e2010d1c5 --- /dev/null +++ b/tests/testthat/test-guide-axis.R @@ -0,0 +1,399 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("axis_label_overlap_priority always returns the correct number of elements", { + expect_identical(axis_label_priority(0), numeric(0)) + expect_setequal(axis_label_priority(1), seq_len(1)) + expect_setequal(axis_label_priority(5), seq_len(5)) + expect_setequal(axis_label_priority(10), seq_len(10)) + expect_setequal(axis_label_priority(100), seq_len(100)) +}) + +test_that("a warning is generated when guides are drawn at a location that doesn't make sense", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + scale_y_continuous(guide = guide_axis(position = "top")) + expect_snapshot_warning(ggplot_build(plot)) +}) + +test_that("a warning is not generated when a guide is specified with duplicate breaks", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + scale_y_continuous(breaks = c(20, 20)) + built <- expect_silent(ggplot_build(plot)) + expect_silent(ggplot_gtable(built)) +}) + +test_that("a warning is generated when more than one position guide is drawn at a location", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + guides( + y = guide_axis(position = "left"), + y.sec = guide_axis(position = "left") + ) + built <- expect_silent(ggplot_build(plot)) + + expect_snapshot_warning(ggplot_gtable(built)) +}) + +test_that("a warning is not generated when properly changing the position of a guide_axis()", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + guides( + y = guide_axis(position = "right") + ) + built <- expect_silent(ggplot_build(plot)) + expect_silent(ggplot_gtable(built)) +}) + +test_that("Using non-position guides for position scales results in an informative error", { + p <- ggplot(mpg, aes(cty, hwy)) + + geom_point() + + scale_x_continuous(guide = guide_legend()) + expect_snapshot_warning(ggplot_build(p)) +}) + +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)) + view_scale_primary(scale) + } + + train_guide <- function(guide, scale) { + params <- guide$params + params$position <- "bottom" + guide$train(params, scale, "x") + } + + guide <- guide_axis_logticks(negative.small = 10) + 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))) + + # Test compound transformation + 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 + + 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))) + + # Test expanded argument + scale <- test_scale(transform_log10(), c(20, 900)) + scale$continuous_range <- c(1, 3) + + guide <- guide_axis_logticks(expanded = TRUE) + 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 + + expect_equal(sort(key$x), log10(outcome[-c(1, length(outcome))])) + + # Test with prescaled input + guide <- guide_axis_logticks(prescale.base = 2) + scale <- test_scale(limits = log2(c(10, 1000))) + + key <- train_guide(guide, scale)$logkey + expect_equal(sort(key$x), log2(outcome)) + + # Should warn when scale also has transformation + scale <- test_scale(transform_log10(), limits = c(10, 1000)) + expect_snapshot_warning(train_guide(guide, scale)$logkey) +}) + +# 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, + ...) { + + 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, ...) + }) + axes_grob <- gTree(children = do.call(gList, axes)) + + # arrange them so there's some padding on each side + gt <- gtable( + widths = unit(c(0.05, 0.9, 0.05), "npc"), + heights = unit(c(0.05, 0.9, 0.05), "npc") + ) + gt <- gtable_add_grob(gt, list(axes_grob), 2, 2, clip = "off") + plot(gt) + } + + # basic + expect_doppelganger("axis guides basic", function() test_draw_axis()) + 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) + ) + + # rotated text + expect_doppelganger( + "axis guides, zero rotation", + 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) + ) + + expect_doppelganger( + "axis guides, negative rotation", + 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) + ) + + expect_doppelganger( + "axis guides, vertical negative rotation", + 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) + ) +}) + +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 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")) + ) +}) + +test_that("axis guides can be customized", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + scale_y_continuous( + sec.axis = dup_axis(guide = guide_axis(n.dodge = 2)), + guide = guide_axis(n.dodge = 2) + ) + + scale_x_discrete(guide = guide_axis(n.dodge = 2)) + + expect_doppelganger("guide_axis() customization", plot) +}) + +test_that("guides can be specified in guides()", { + plot <- ggplot(mpg, aes(class, hwy)) + + geom_point() + + guides( + x = guide_axis(n.dodge = 2), + y = guide_axis(n.dodge = 2), + x.sec = guide_axis(n.dodge = 2), + y.sec = guide_axis(n.dodge = 2) + ) + + expect_doppelganger("guides specified in guides()", plot) +}) + +test_that("guides have the final say in x and y", { + df <- data_frame(x = 1, y = 1) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + guides( + x = guide_none(title = "x (primary)"), + y = guide_none(title = "y (primary)"), + x.sec = guide_none(title = "x (secondary)"), + y.sec = guide_none(title = "y (secondary)") + ) + + expect_doppelganger("position guide titles", plot) +}) + +test_that("Axis titles won't be blown away by coord_*()", { + df <- data_frame(x = 1, y = 1) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + guides( + x = guide_axis(title = "x (primary)"), + y = guide_axis(title = "y (primary)"), + x.sec = guide_axis(title = "x (secondary)"), + y.sec = guide_axis(title = "y (secondary)") + ) + + expect_doppelganger("guide titles with coord_trans()", plot + coord_trans()) + # TODO + # expect_doppelganger("guide titles with coord_polar()", plot + coord_polar()) + # TODO + # expect_doppelganger("guide titles with coord_sf()", plot + coord_sf()) +}) + +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")) + + scale_x_continuous(labels = label_math()) + + guides( + # Test for styling and style inheritance + x = guide_axis(minor.ticks = TRUE), + # # Test for opposed lengths + y = guide_axis(minor.ticks = TRUE), + # # Test for flipped lenghts + x.sec = guide_axis(minor.ticks = TRUE), + # # Test that minor.length doesn't influence spacing when no minor ticks are drawn + y.sec = guide_axis(minor.ticks = FALSE) + ) + expect_doppelganger("guides with minor ticks", p) +}) + +test_that("axis guides can be capped", { + p <- ggplot(mtcars, aes(hp, disp)) + + geom_point() + + theme(axis.line = element_line()) + + guides( + x = guide_axis(cap = "both"), + y = guide_axis(cap = "upper"), + y.sec = guide_axis(cap = "lower"), + x.sec = guide_axis(cap = "none") + ) + expect_doppelganger("axis guides with capped ends", p) +}) + +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") + bottom <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "bottom") + top <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "top") + + p <- ggplot(mtcars, aes(hp, disp)) + + geom_point() + + theme(axis.line = element_line()) + + guides(x = bottom, x.sec = top, y = left, y.sec = right) + 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")) + + p <- ggplot(mtcars, aes(hp, disp)) + + geom_point() + + theme(axis.line = element_line()) + + 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( + transform = transform_compose(transform_log10(), transform_reverse()), + expand = expansion(add = 0.5) + ) + + scale_x_continuous( + breaks = c(-100, -10, -1, 0, 1, 10, 100) + ) + + coord_trans(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")) + + guides( + x = guide_axis_logticks( + title = "Pseudo-logticks with 1 as smallest tick", + negative.small = 1 + ), + y = guide_axis_logticks( + title = "Inverted logticks with swapped tick lengths", + 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", + title = "Capped and not-expanded inverted logticks" + ) + ) + expect_doppelganger("logtick axes with customisation", p) +}) + +test_that("guide_axis_theta sets relative angle", { + + p <- ggplot(mtcars, aes(disp, mpg)) + + geom_point() + + scale_x_continuous(breaks = breaks_width(25)) + + coord_radial(inner.radius = 0.5) + + guides( + theta = guide_axis_theta(angle = 0, cap = "none"), + theta.sec = guide_axis_theta(angle = 90, cap = "both") + ) + + theme(axis.line = element_line(colour = "black")) + + expect_doppelganger("guide_axis_theta with angle adapting to theta", p) +}) + +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") + + 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") + ) + + 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 new file mode 100644 index 0000000000..7cfd96a2f1 --- /dev/null +++ b/tests/testthat/test-guide-colorbar.R @@ -0,0 +1,100 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("colourbar trains without labels", { + g <- guide_colorbar() + sc <- scale_colour_gradient(limits = c(0, 4), labels = NULL) + + out <- g$train(scale = sc) + expect_named(out$key, c("colour", ".value")) +}) + +test_that("Colorbar respects show.legend in layer", { + df <- data_frame(x = 1:3, y = 1) + p <- ggplot(df, aes(x = x, y = y, color = x)) + + geom_point(size = 20, shape = 21, show.legend = FALSE) + expect_length(ggplot_build(p)$plot$guides$guides, 0L) + p <- ggplot(df, aes(x = x, y = y, color = x)) + + geom_point(size = 20, shape = 21, show.legend = TRUE) + expect_length(ggplot_build(p)$plot$guides$guides, 1L) +}) + +test_that("colorsteps and bins checks the breaks format", { + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp, colour = paste("A", gear))) + + guides(colour = "colorsteps") + expect_snapshot_error(suppressWarnings(ggplotGrob(p))) + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp, colour = paste("A", gear))) + + guides(colour = "bins") + expect_snapshot_error(suppressWarnings(ggplotGrob(p))) +}) + +test_that("guide_colourbar merging preserves both aesthetics", { + # See issue 5324 + + scale1 <- scale_colour_viridis_c() + scale1$train(c(0, 2)) + + scale2 <- scale_fill_viridis_c() + scale2$train(c(0, 2)) + + g <- guide_colourbar() + p <- g$params + + p1 <- g$train(p, scale1, "colour") + p2 <- g$train(p, scale2, "fill") + + merged <- g$merge(p1, g, p2) + + expect_true(all(c("colour", "fill") %in% names(merged$params$key))) +}) + + +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", { + df <- data_frame(x = c(0, 1, 2)) + p <- ggplot(df, aes(x, x, color = x)) + geom_point() + + expect_doppelganger( + "white-to-red colorbar, white ticks, no frame", + p + scale_color_gradient(low = 'white', high = 'red') + ) + + 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 + ) + ) + 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)) + + 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") + ) + + expect_doppelganger("combined colour and fill aesthetics", p) +}) diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R new file mode 100644 index 0000000000..cd2311ee93 --- /dev/null +++ b/tests/testthat/test-guide-legend.R @@ -0,0 +1,239 @@ +skip_on_cran() + +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)) + sum(n) + } + + df <- data_frame(x = 1:3, y = 20:22) + p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + + geom_point(size = 20) + expect_equal(n_legends(p), 2) + + p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + + geom_point(size = 20, show.legend = c(color = FALSE)) + expect_equal(n_legends(p), 1) + + p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + + geom_point(size = 20, show.legend = c(color = FALSE, shape = FALSE)) + expect_equal(n_legends(p), 0) + + # c.f.https://github.com/tidyverse/ggplot2/issues/3461 + p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + + geom_point(size = 20, show.legend = c(shape = FALSE, color = TRUE)) + expect_equal(n_legends(p), 1) +}) + +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") + scales <- scales_list() + scales$add(scale1) + scales$add(scale2) + scales$set_palettes(NULL) + scales <- scales$scales + + aesthetics <- lapply(scales, `[[`, "aesthetics") + scales <- rep.int(scales, lengths(aesthetics)) + aesthetics <- unlist(aesthetics, FALSE, FALSE) + + guides <- guides_list(NULL) + guides <- guides$setup(scales, aesthetics) + guides$train(scales, labs()) + guides$merge() + guides$params + } + + different_limits <- merge_test_guides( + scale_colour_hue(limits = c("a", "b", "c", "d")), + scale_linetype_discrete(limits = c("a", "b", "c")) + ) + expect_length(different_limits, 2) + + same_limits <- merge_test_guides( + scale_colour_hue(limits = c("a", "b", "c")), + scale_linetype_discrete(limits = c("a", "b", "c")) + ) + expect_length(same_limits, 1) + expect_equal(same_limits[[1]]$key$.label, c("a", "b", "c")) + + 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")) + ) + 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_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")) + ) + expect_length(repeated_identical_labels, 1) + 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") + ) + p <- ggplot(df, aes(x = x, y = 0, colour = group)) + + geom_point(size = NA, na.rm = TRUE) + + expect_silent(plot(p)) +}) + +test_that("legend reverse argument reverses the key", { + + scale <- scale_colour_hue() + scale$train(LETTERS[1:4]) + + guides <- guides_list(NULL) + guides <- guides$setup(list(scale), "colour") + + guides$params[[1]]$reverse <- FALSE + guides$train(list(scale), labels = labs()) + fwd <- guides$get_params(1)$key + + guides$params[[1]]$reverse <- TRUE + guides$train(list(scale), labels = labs()) + rev <- guides$get_params(1)$key + + expect_equal(fwd$colour, rev(rev$colour)) +}) + +test_that("legends can be forced to display unrelated geoms", { + + df <- data.frame(x = 1:2) + + p <- ggplot(df, aes(x, x)) + + geom_tile(fill = "red", show.legend = TRUE) + + scale_colour_discrete( + limits = c("A", "B") + ) + + b <- ggplot_build(p) + legend <- b$plot$guides$params[[1]] + + expect_equal( + legend$decor[[1]]$data$fill, + c("red", "red") + ) +}) + +test_that("unresolved, modified expressions throw a warning (#6264)", { + # Snapshot is unstable in lesser R versions + skip_if_not(getRversion() >= "4.3.0") + p <- ggplot(mpg, aes(drv)) + + geom_bar( + aes(fill = stage(drv, after_scale = alpha(fill, prop))) + ) + expect_snapshot_warning(ggplot_build(p)) +}) + +# Visual tests ------------------------------------------------------------ + +test_that("legend directions are set correctly", { + + p <- ggplot(mtcars, aes(disp, mpg, shape = factor(cyl), colour = drat)) + + geom_point() + + theme_test() + + expect_doppelganger( + "vertical legend direction", + p + theme(legend.direction = "vertical") + ) + + expect_doppelganger( + "horizontal legend direction", + p + theme(legend.direction = "horizontal") + ) +}) + +test_that("guide_legend uses key.spacing correctly", { + p <- ggplot(mtcars, aes(disp, mpg, colour = factor(carb))) + + geom_point() + + guides(colour = guide_legend(ncol = 2)) + + theme_test() + + theme( + legend.key.spacing.x = unit(2, "lines"), + legend.key.spacing.y = unit(1, "lines") + ) + + expect_doppelganger("legend with widely spaced keys", p) +}) + +test_that("absent titles don't take up space", { + + p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + + geom_point() + + theme( + legend.title = element_blank(), + legend.margin = margin(), + legend.position = "top", + legend.justification = "left", + legend.key = element_rect(colour = "black"), + axis.line = element_line(colour = "black") + ) + + expect_doppelganger("left aligned legend key", p) +}) + +test_that("size and linewidth affect key size", { + df <- data_frame(x = c(0, 1, 2)) + p <- ggplot(df, aes(x, x)) + + geom_point(aes(size = x)) + + geom_line(aes(linewidth = 2 - x)) + + scale_size_continuous(range = c(1, 12)) + + scale_linewidth_continuous(range = c(1, 20)) + + expect_doppelganger("enlarged guides", p) +}) + +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)) + + geom_point() + + scale_colour_discrete( + guide = guide_legend( + ncol = 3, + theme = theme(legend.byrow = TRUE) + ) + ) + + expect_doppelganger("legend.byrow = TRUE", p) +}) + +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) + ) + + scale_colour_discrete( + 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 bc359938ae..1a3a31143a 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -1,137 +1,5 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped -test_that("plotting does not induce state changes in guides", { - - guides <- guides( - x = guide_axis(title = "X-axis"), - colour = guide_colourbar(title = "Colourbar"), - shape = guide_legend(title = "Legend"), - size = guide_bins(title = "Bins") - ) - - p <- ggplot(mpg, aes(displ, hwy, colour = cty, shape = factor(cyl), - size = cyl)) + - geom_point() + - guides - - snapshot <- serialize(as.list(p$guides), NULL) - - grob <- ggplotGrob(p) - - expect_identical(as.list(p$guides), unserialize(snapshot)) -}) - -test_that("adding guides doesn't change plot state", { - - p1 <- ggplot(mtcars, aes(disp, mpg)) - - expect_length(p1$guides$guides, 0) - - p2 <- p1 + guides(y = guide_axis(angle = 45)) - - expect_length(p1$guides$guides, 0) - expect_length(p2$guides$guides, 1) - - p3 <- p2 + guides(y = guide_axis(angle = 90)) - - expect_length(p3$guides$guides, 1) - expect_equal(p3$guides$guides[[1]]$params$angle, 90) - expect_equal(p2$guides$guides[[1]]$params$angle, 45) -}) - -test_that("colourbar trains without labels", { - g <- guide_colorbar() - sc <- scale_colour_continuous(limits = c(0, 4), labels = NULL) - - out <- g$train(scale = sc) - expect_equal(names(out$key), c("colour", ".value")) -}) - -test_that("Colorbar respects show.legend in layer", { - df <- data_frame(x = 1:3, y = 1) - p <- ggplot(df, aes(x = x, y = y, color = x)) + - geom_point(size = 20, shape = 21, show.legend = FALSE) - expect_length(ggplot_build(p)$plot$guides$guides, 0L) - p <- ggplot(df, aes(x = x, y = y, color = x)) + - geom_point(size = 20, shape = 21, show.legend = TRUE) - expect_length(ggplot_build(p)$plot$guides$guides, 1L) -}) - -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)) - sum(n) - } - - df <- data_frame(x = 1:3, y = 20:22) - p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + - geom_point(size = 20) - expect_equal(n_legends(p), 2) - - p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + - geom_point(size = 20, show.legend = c(color = FALSE)) - expect_equal(n_legends(p), 1) - - p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + - geom_point(size = 20, show.legend = c(color = FALSE, shape = FALSE)) - expect_equal(n_legends(p), 0) - - # c.f.https://github.com/tidyverse/ggplot2/issues/3461 - p <- ggplot(df, aes(x = x, y = y, color = x, shape = factor(y))) + - geom_point(size = 20, show.legend = c(shape = FALSE, color = TRUE)) - expect_equal(n_legends(p), 1) -}) - -test_that("axis_label_overlap_priority always returns the correct number of elements", { - expect_identical(axis_label_priority(0), numeric(0)) - expect_setequal(axis_label_priority(1), seq_len(1)) - expect_setequal(axis_label_priority(5), seq_len(5)) - expect_setequal(axis_label_priority(10), seq_len(10)) - expect_setequal(axis_label_priority(100), seq_len(100)) -}) - -test_that("a warning is generated when guides are drawn at a location that doesn't make sense", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - scale_y_continuous(guide = guide_axis(position = "top")) - expect_warning(ggplot_build(plot), "Position guide is perpendicular") -}) - -test_that("a warning is not generated when a guide is specified with duplicate breaks", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - scale_y_continuous(breaks = c(20, 20)) - built <- expect_silent(ggplot_build(plot)) - expect_silent(ggplot_gtable(built)) -}) - -test_that("a warning is generated when more than one position guide is drawn at a location", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - guides( - y = guide_axis(position = "left"), - y.sec = guide_axis(position = "left") - ) - built <- expect_silent(ggplot_build(plot)) - - expect_warning(ggplot_gtable(built), "Discarding guide") -}) - -test_that("a warning is not generated when properly changing the position of a guide_axis()", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - guides( - y = guide_axis(position = "right") - ) - built <- expect_silent(ggplot_build(plot)) - expect_silent(ggplot_gtable(built)) -}) - test_that("guide_none() can be used in non-position scales", { p <- ggplot(mpg, aes(cty, hwy, colour = class)) + geom_point() + @@ -149,80 +17,6 @@ test_that("guide_none() can be used in non-position scales", { expect_length(guides$guides, 0) }) -test_that("Using non-position guides for position scales results in an informative error", { - p <- ggplot(mpg, aes(cty, hwy)) + - geom_point() + - scale_x_continuous(guide = guide_legend()) - expect_snapshot_warning(ggplot_build(p)) -}) - -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") - scales <- scales_list() - scales$add(scale1) - scales$add(scale2) - scales <- scales$scales - - aesthetics <- lapply(scales, `[[`, "aesthetics") - scales <- rep.int(scales, lengths(aesthetics)) - aesthetics <- unlist(aesthetics, FALSE, FALSE) - - guides <- guides_list(NULL) - guides <- guides$setup(scales, aesthetics) - guides$train(scales, labs()) - guides$merge() - guides$params - } - - different_limits <- merge_test_guides( - scale_colour_discrete(limits = c("a", "b", "c", "d")), - scale_linetype_discrete(limits = c("a", "b", "c")) - ) - expect_length(different_limits, 2) - - same_limits <- merge_test_guides( - scale_colour_discrete(limits = c("a", "b", "c")), - scale_linetype_discrete(limits = c("a", "b", "c")) - ) - expect_length(same_limits, 1) - expect_equal(same_limits[[1]]$key$.label, c("a", "b", "c")) - - same_labels_different_limits <- merge_test_guides( - scale_colour_discrete(limits = 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_continuous(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_discrete(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")) -}) - -test_that("size = NA doesn't throw rendering errors", { - df = data.frame( - x = c(1, 2), - group = c("a","b") - ) - p <- ggplot(df, aes(x = x, y = 0, colour = group)) + - geom_point(size = NA, na.rm = TRUE) - - expect_silent(plot(p)) -}) - test_that("guide specifications are properly checked", { expect_snapshot_error(validate_guide("test")) expect_snapshot_error(validate_guide(1)) @@ -257,36 +51,6 @@ test_that("guide specifications are properly checked", { expect_snapshot_error(ggplotGrob(p)) }) -test_that("colorsteps and bins checks the breaks format", { - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp, colour = paste("A", gear))) + - guides(colour = "colorsteps") - expect_snapshot_error(suppressWarnings(ggplotGrob(p))) - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp, colour = paste("A", gear))) + - guides(colour = "bins") - expect_snapshot_error(suppressWarnings(ggplotGrob(p))) -}) - -test_that("legend reverse argument reverses the key", { - - scale <- scale_colour_discrete() - scale$train(LETTERS[1:4]) - - guides <- guides_list(NULL) - guides <- guides$setup(list(scale), "colour") - - guides$params[[1]]$reverse <- FALSE - guides$train(list(scale), labels = labs()) - fwd <- guides$get_params(1)$key - - guides$params[[1]]$reverse <- TRUE - guides$train(list(scale), labels = labs()) - rev <- guides$get_params(1)$key - - expect_equal(fwd$colour, rev(rev$colour)) -}) - test_that("guide_coloursteps and guide_bins return ordered breaks", { scale <- scale_colour_viridis_c(breaks = c(2, 3, 1)) scale$train(c(0, 4)) @@ -300,6 +64,14 @@ test_that("guide_coloursteps and guide_bins return ordered breaks", { g <- guide_bins() key <- g$train(scale = scale, aesthetics = "colour")$key 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$train(c(15, 45)) + + g <- guide_colorsteps() + key <- g$train(scale = scale, aesthetic = "colour")$key + expect_equal(sum(key$colour == "grey50"), 0) }) test_that("guide_coloursteps can parse (un)even steps from discrete scales", { @@ -317,27 +89,6 @@ test_that("guide_coloursteps can parse (un)even steps from discrete scales", { expect_equal(decor$max - decor$min, c(0.3, 0.2, 0.5)) }) - -test_that("guide_colourbar merging preserves both aesthetics", { - # See issue 5324 - - scale1 <- scale_colour_viridis_c() - scale1$train(c(0, 2)) - - scale2 <- scale_fill_viridis_c() - scale2$train(c(0, 2)) - - g <- guide_colourbar() - p <- g$params - - p1 <- g$train(p, scale1, "colour") - p2 <- g$train(p, scale2, "fill") - - merged <- g$merge(p1, g, p2) - - expect_true(all(c("colour", "fill") %in% names(merged$params$key))) -}) - test_that("get_guide_data retrieves keys appropriately", { p <- ggplot(mtcars, aes(mpg, disp, colour = drat, size = drat, fill = wt)) + @@ -364,8 +115,8 @@ test_that("get_guide_data retrieves keys appropriately", { # Non-existent panels expect_null(get_guide_data(b, "x", panel = 4)) - expect_error(get_guide_data(b, 1), "must be a single string") - expect_error(get_guide_data(b, "x", panel = "a"), "must be a whole number") + expect_snapshot(get_guide_data(b, 1), error = TRUE) + expect_snapshot(get_guide_data(b, "x", panel = "a"), error = TRUE) }) test_that("get_guide_data retrieves keys from exotic coords", { @@ -387,111 +138,6 @@ test_that("get_guide_data retrieves keys from exotic coords", { expect_equal(test$theta.labels, c("15", "20", "25", "30")) }) -test_that("guide_colourbar warns about discrete scales", { - - g <- guide_colourbar() - s <- scale_colour_discrete() - s$train(LETTERS[1:3]) - - expect_warning(g <- g$train(g$params, s, "colour"), "needs continuous scales") - expect_null(g) - -}) - -test_that("legend directions are set correctly", { - - p <- ggplot(mtcars, aes(disp, mpg, shape = factor(cyl), colour = drat)) + - geom_point() + - theme_test() - - expect_doppelganger( - "vertical legend direction", - p + theme(legend.direction = "vertical") - ) - - expect_doppelganger( - "horizontal legend direction", - p + theme(legend.direction = "horizontal") - ) -}) - -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)) - view_scale_primary(scale) - } - - train_guide <- function(guide, scale) { - params <- guide$params - params$position <- "bottom" - guide$train(params, scale, "x") - } - - guide <- guide_axis_logticks(negative.small = 10) - 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))) - - # Test compound transformation - 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 - - 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))) - - # Test expanded argument - scale <- test_scale(transform_log10(), c(20, 900)) - scale$continuous_range <- c(1, 3) - - guide <- guide_axis_logticks(expanded = TRUE) - 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 - - expect_equal(sort(key$x), log10(outcome[-c(1, length(outcome))])) - - # Test with prescaled input - guide <- guide_axis_logticks(prescale.base = 2) - scale <- test_scale(limits = log2(c(10, 1000))) - - key <- train_guide(guide, scale)$logkey - expect_equal(sort(key$x), log2(outcome)) - - # Should warn when scale also has transformation - scale <- test_scale(transform_log10(), limits = c(10, 1000)) - expect_snapshot_warning(train_guide(guide, scale)$logkey) -}) - -test_that("guide_legend uses key.spacing correctly", { - p <- ggplot(mtcars, aes(disp, mpg, colour = factor(carb))) + - geom_point() + - guides(colour = guide_legend(ncol = 2)) + - theme_test() + - theme( - legend.key.spacing.x = unit(2, "lines"), - legend.key.spacing.y = unit(1, "lines") - ) - - expect_doppelganger("legend with widely spaced keys", p) -}) - test_that("empty guides are dropped", { df <- data.frame(x = 1:2) @@ -510,10 +156,10 @@ test_that("empty guides are dropped", { expect_equal(nrow(gd), 0) # Draw guides - guides <- p$plot$guides$draw(theme_gray(), direction = "vertical") + guides <- p$plot$guides$assemble(theme_gray()) # All guide-boxes should be empty - expect_equal(lengths(guides, use.names = FALSE), rep(0, 5)) + expect_true(is.zero(guides)) }) test_that("bins can be parsed by guides for all scale types", { @@ -544,272 +190,21 @@ test_that("bins can be parsed by guides for all scale types", { ) }) -# 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, - ...) { - - 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, ...) - }) - axes_grob <- gTree(children = do.call(gList, axes)) - - # arrange them so there's some padding on each side - gt <- gtable( - widths = unit(c(0.05, 0.9, 0.05), "npc"), - heights = unit(c(0.05, 0.9, 0.05), "npc") - ) - gt <- gtable_add_grob(gt, list(axes_grob), 2, 2, clip = "off") - plot(gt) - } - - # basic - expect_doppelganger("axis guides basic", function() test_draw_axis()) - expect_doppelganger("axis guides, zero breaks", function() test_draw_axis(n_breaks = 0)) +test_that("binned breaks can have hardcoded labels when oob", { - # overlapping text - expect_doppelganger( - "axis guides, check overlap", - function() test_draw_axis(20, labels = function(b) comma(b * 1e9), check.overlap = TRUE) - ) + sc <- scale_colour_steps(breaks = 1:3, labels = as.character(1:3)) + sc$train(c(1, 2)) - # rotated text - expect_doppelganger( - "axis guides, zero rotation", - 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) - ) - - expect_doppelganger( - "axis guides, negative rotation", - 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) - ) - - expect_doppelganger( - "axis guides, vertical negative rotation", - 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) - ) -}) - -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 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")) - ) -}) - -test_that("axis guides can be customized", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - scale_y_continuous( - sec.axis = dup_axis(guide = guide_axis(n.dodge = 2)), - guide = guide_axis(n.dodge = 2) - ) + - scale_x_discrete(guide = guide_axis(n.dodge = 2)) - - expect_doppelganger("guide_axis() customization", plot) -}) - -test_that("guides can be specified in guides()", { - plot <- ggplot(mpg, aes(class, hwy)) + - geom_point() + - guides( - x = guide_axis(n.dodge = 2), - y = guide_axis(n.dodge = 2), - x.sec = guide_axis(n.dodge = 2), - y.sec = guide_axis(n.dodge = 2) - ) - - expect_doppelganger("guides specified in guides()", plot) -}) - -test_that("guides have the final say in x and y", { - df <- data_frame(x = 1, y = 1) - plot <- ggplot(df, aes(x, y)) + - geom_point() + - guides( - x = guide_none(title = "x (primary)"), - y = guide_none(title = "y (primary)"), - x.sec = guide_none(title = "x (secondary)"), - y.sec = guide_none(title = "y (secondary)") - ) - - expect_doppelganger("position guide titles", plot) -}) - -test_that("Axis titles won't be blown away by coord_*()", { - df <- data_frame(x = 1, y = 1) - plot <- ggplot(df, aes(x, y)) + - geom_point() + - guides( - x = guide_axis(title = "x (primary)"), - y = guide_axis(title = "y (primary)"), - x.sec = guide_axis(title = "x (secondary)"), - y.sec = guide_axis(title = "y (secondary)") - ) - - expect_doppelganger("guide titles with coord_trans()", plot + coord_trans()) - # TODO - # expect_doppelganger("guide titles with coord_polar()", plot + coord_polar()) - # TODO - # expect_doppelganger("guide titles with coord_sf()", plot + coord_sf()) -}) - -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")) + - scale_x_continuous(labels = label_math()) + - guides( - # Test for styling and style inheritance - x = guide_axis(minor.ticks = TRUE), - # # Test for opposed lengths - y = guide_axis(minor.ticks = TRUE), - # # Test for flipped lenghts - x.sec = guide_axis(minor.ticks = TRUE), - # # Test that minor.length doesn't influence spacing when no minor ticks are drawn - y.sec = guide_axis(minor.ticks = FALSE) - ) - expect_doppelganger("guides with minor ticks", p) -}) - -test_that("absent titles don't take up space", { - - p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + - geom_point() + - theme( - legend.title = element_blank(), - legend.margin = margin(), - legend.position = "top", - legend.justification = "left", - legend.key = element_rect(colour = "black"), - axis.line = element_line(colour = "black") - ) - - expect_doppelganger("left aligned legend key", p) -}) - -test_that("axis guides can be capped", { - p <- ggplot(mtcars, aes(hp, disp)) + - geom_point() + - theme(axis.line = element_line()) + - guides( - x = guide_axis(cap = "both"), - y = guide_axis(cap = "upper"), - y.sec = guide_axis(cap = "lower"), - x.sec = guide_axis(cap = "none") - ) - expect_doppelganger("axis guides with capped ends", p) -}) - -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") - bottom <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "bottom") - top <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "top") - - p <- ggplot(mtcars, aes(hp, disp)) + - geom_point() + - theme(axis.line = element_line()) + - guides(x = bottom, x.sec = top, y = left, y.sec = right) - 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")) - - p <- ggplot(mtcars, aes(hp, disp)) + - geom_point() + - theme(axis.line = element_line()) + - 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) + g <- guide_bins() + key <- g$train(scale = sc, aesthetic = "colour")$key + expect_equal(key$.label, c("1", "2")) + g <- guide_coloursteps() + key <- g$train(scale = sc, aesthetic = "colour")$key + expect_equal(key$.label, c("1", "2")) }) -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( - transform = transform_compose(transform_log10(), transform_reverse()), - expand = expansion(add = 0.5) - ) + - scale_x_continuous( - breaks = c(-100, -10, -1, 0, 1, 10, 100) - ) + - coord_trans(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")) + - guides( - x = guide_axis_logticks( - title = "Pseudo-logticks with 1 as smallest tick", - negative.small = 1 - ), - y = guide_axis_logticks( - title = "Inverted logticks with swapped tick lengths", - 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", - title = "Capped and not-expanded inverted logticks" - ) - ) - expect_doppelganger("logtick axes with customisation", p) -}) +# Visual tests ------------------------------------------------------------ test_that("guides are positioned correctly", { df <- data_frame(x = 1, y = 1, z = factor("a")) @@ -876,7 +271,7 @@ test_that("guides are positioned correctly", { p2 <- p2 + theme(legend.position = "inside") # Placement of legend inside expect_doppelganger("legend inside plot, centered", - p2 + theme(legend.position.inside = c(.5, .5)) + 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)) @@ -885,7 +280,26 @@ test_that("guides are positioned correctly", { 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(.5,.5)) + p2 + theme(legend.justification = c(0,0), legend.position.inside = c(0.5,0.5)) + ) + 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) + ) + ) + ) ) }) @@ -997,51 +411,20 @@ test_that("guides title and text are positioned correctly", { expect_doppelganger("legends with all title justifications", p) }) -test_that("size and linewidth affect key size", { - df <- data_frame(x = c(0, 1, 2)) - p <- ggplot(df, aes(x, x)) + - geom_point(aes(size = x)) + - geom_line(aes(linewidth = 2 - x)) + - scale_size_continuous(range = c(1, 12)) + - scale_linewidth_continuous(range = c(1, 20)) - - expect_doppelganger("enlarged guides", p) -}) - -test_that("colorbar can be styled", { - df <- data_frame(x = c(0, 1, 2)) - p <- ggplot(df, aes(x, x, color = x)) + geom_point() +test_that("bin guide can be reversed", { - expect_doppelganger("white-to-red colorbar, white ticks, no frame", - p + scale_color_gradient(low = 'white', high = 'red') - ) - - 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 <- 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, + override.aes = list(shape = 21) ) - ) + 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)) - - 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") ) - expect_doppelganger("one combined colorbar for colour and fill aesthetics", p) + expect_doppelganger("reversed guide_bins", p) + }) test_that("bin guide can be styled correctly", { @@ -1148,79 +531,25 @@ test_that("binning scales understand the different combinations of limits, break expect_snapshot_warning(ggplotGrob(p + scale_color_binned(labels = 1:4, show.limits = TRUE))) }) -test_that("guide_axis_theta sets relative angle", { - - p <- ggplot(mtcars, aes(disp, mpg)) + - geom_point() + - scale_x_continuous(breaks = breaks_width(25)) + - coord_radial(inner.radius = 0.5) + - guides( - theta = guide_axis_theta(angle = 0, cap = "none"), - theta.sec = guide_axis_theta(angle = 90, cap = "both") - ) + - theme(axis.line = element_line(colour = "black")) - - expect_doppelganger("guide_axis_theta with angle adapting to theta", p) -}) - -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") + - 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") - ) - - expect_doppelganger("guide_axis_theta in cartesian coordinates", p) -}) - test_that("a warning is generated when guides( = FALSE) is specified", { df <- data_frame(x = c(1, 2, 4), y = c(6, 5, 7)) # warn on guide( = FALSE) - expect_warning(g <- guides(colour = FALSE), "The `` argument of `guides()` cannot be `FALSE`. Use \"none\" instead as of ggplot2 3.3.4.", fixed = TRUE) + 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) - expect_snapshot_warning(ggplot_build(p)) + lifecycle::expect_deprecated(ggplot_build(p)) }) test_that("guides() warns if unnamed guides are provided", { - expect_warning( - guides("axis"), - "All guides are unnamed." - ) - expect_warning( - guides(x = "axis", "axis"), - "The 2nd guide is unnamed" - ) + expect_snapshot_warning(guides("axis")) + expect_snapshot_warning(guides(x = "axis", "axis")) expect_null(guides()) }) -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)) + - geom_point() + - scale_colour_discrete( - guide = guide_legend( - ncol = 3, - theme = theme(legend.byrow = TRUE) - ) - ) - - expect_doppelganger("legend.byrow = TRUE", p) - -}) - test_that("old S3 guides can be implemented", { my_env <- env() @@ -1264,12 +593,36 @@ test_that("old S3 guides can be implemented", { withr::local_environment(my_env) + my_guides <- guides(x = guide_circle()) + expect_length(my_guides$guides, 1) + expect_s3_class(my_guides$guides[[1]], "guide") + expect_snapshot_warning( expect_doppelganger( "old S3 guide drawing a circle", ggplot(mtcars, aes(disp, mpg)) + geom_point() + - guides(x = "circle") + my_guides ) ) }) + +test_that("guide_custom can be drawn and styled", { + + 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)) + ) + + expect_doppelganger( + "guide_custom with void theme", + p + theme_void() + ) +}) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index a19b84efe7..4befce8af6 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -61,6 +61,35 @@ test_that("Labels from default stat mapping are overwritten by default labels", expect_equal(get_labs(p)$colour, "drv") }) +test_that("Labels can be extracted from attributes", { + df <- mtcars + attr(df$mpg, "label") <- "Miles per gallon" + + p <- ggplot(df, aes(mpg, disp)) + geom_point() + + labels <- get_labs(p) + expect_equal(labels$x, "Miles per gallon") + expect_equal(labels$y, "disp") +}) + +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() + expect_equal(get_labs(p)$colour, "f") + + p <- ggplot(df, aes(x, y, colour = f)) + geom_point(colour = "blue") + expect_null(get_labs(p)$colour) +}) + +test_that("Labels from annotations are ignored (#6316)", { + df <- data.frame(a = 1, b = 2) + p <- ggplot(df, aes(a, b)) + annotate("point", x = 1, y = 2) + geom_point() + labs <- get_labs(p) + expect_equal(labs[c("x", "y")], list(x = "a", y = "b")) +}) + test_that("alt text is returned", { p <- ggplot(mtcars, aes(mpg, disp)) + geom_point() @@ -69,6 +98,21 @@ test_that("alt text is returned", { expect_equal(get_alt_text(p), "An alt text") }) +test_that("alt text can take a function", { + p <- ggplot(mpg, aes(class)) + + geom_bar() + + labs(alt = ~ generate_alt_text(.x)) + expect_snapshot(get_alt_text(p)) +}) + +test_that("get_alt_text checks dots", { + expect_snapshot_warning(get_alt_text(ggplot(), foo = "bar")) +}) + +test_that("warnings are thrown for unknown labels", { + p <- ggplot(mtcars, aes(mpg, disp)) + geom_point() + labs(foo = 'bar') + expect_snapshot_warning(ggplot_build(p)) +}) test_that("plot.tag.position rejects invalid input", { p <- ggplot(mtcars, aes(mpg, disp)) + geom_point() + labs(tag = "Fig. A)") @@ -79,13 +123,13 @@ test_that("plot.tag.position rejects invalid input", { expect_snapshot_error( ggplotGrob(p + theme(plot.tag.position = "foobar")) ) - expect_error( + expect_snapshot( ggplotGrob(p + theme(plot.tag.position = c(0, 0.5, 1))), - "must have length 2" + error = TRUE ) - expect_error( + expect_snapshot( ggplotGrob(p + theme(plot.tag.position = c(0, 0), plot.tag.location = "margin")), - "cannot be used with `\"margin\"" + error = TRUE ) }) @@ -162,6 +206,29 @@ 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( + y = to_upper_ascii, + shape = function(x) gsub("factor", "foo", x) + ) + + scale_shape_discrete( + name = to_upper_ascii, + guide = guide_legend(title = function(x) paste0(x, "!!!")) + ) + + scale_x_continuous(name = to_upper_ascii) + + guides(colour = guide_colourbar(title = to_upper_ascii)) + + labs <- get_labs(p) + expect_equal(labs$shape, "FOO(CYL)!!!") + expect_equal(labs$colour, "DRAT") + expect_equal(labs$x, "DISP") + expect_equal(labs$y, "MPG") + +}) + test_that("moving guide positions lets titles follow", { df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100)) @@ -209,6 +276,31 @@ test_that("moving guide positions lets titles follow", { expect_identical(labs[names(expect)], expect) }) +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" + )) + p <- ggplot_build(p) + + x <- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels) + expect_equal(x$primary, "Displacement") + + y <- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels) + expect_equal(y$primary, "Miles per gallon") + + shape <- p$plot$guides$get_params("shape")$title + expect_equal(shape, "Number of cylinders") + + size <- p$plot$guides$get_params("size")$title + expect_equal(size, "Rear axle ratio") +}) + # Visual tests ------------------------------------------------------------ test_that("tags are drawn correctly", { diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 3a7de53d8c..5e2dbf1d2b 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -8,8 +8,11 @@ test_that("layer() checks its input", { expect_snapshot_error(layer("point", "identity", mapping = 1:4, position = "identity")) expect_snapshot_error(layer("point", "identity", mapping = ggplot(), position = "identity")) - expect_snapshot_error(check_subclass("test", "geom")) - expect_snapshot_error(check_subclass(environment(), "geom")) + expect_snapshot_error(validate_subclass("test", "geom")) + expect_snapshot_error(validate_subclass(environment(), "geom")) + + geom_foo <- function(...) stop("This function is unconstructable.") + expect_snapshot_error(layer("foo", "identity", position = "identity")) }) test_that("aesthetics go in aes_params", { @@ -18,11 +21,15 @@ test_that("aesthetics go in aes_params", { }) test_that("unknown params create warning", { - expect_warning(geom_point(blah = "red"), "unknown parameters") + expect_snapshot_warning(geom_point(blah = "red")) }) test_that("unknown aesthetics create warning", { - expect_warning(geom_point(aes(blah = "red")), "unknown aesthetics") + expect_snapshot_warning(geom_point(aes(blah = "red"))) +}) + +test_that("empty aesthetics create warning", { + expect_snapshot_warning(geom_point(fill = NULL, shape = character())) }) test_that("invalid aesthetics throws errors", { @@ -36,25 +43,25 @@ test_that("invalid aesthetics throws errors", { }) test_that("unknown NULL aesthetic doesn't create warning (#1909)", { - expect_warning(geom_point(aes(blah = NULL)), NA) + expect_silent(geom_point(aes(blah = NULL))) }) test_that("column vectors are allowed (#2609)", { df <- data_frame(x = 1:10) df$y <- scale(1:10) # Returns a column vector p <- ggplot(df, aes(x, y)) - expect_s3_class(layer_data(p), "data.frame") + expect_s3_class(get_layer_data(p), "data.frame") }) test_that("missing aesthetics trigger informative error", { df <- data_frame(x = 1:10) - expect_error( + expect_snapshot( ggplot_build(ggplot(df) + geom_line()), - "requires the following missing aesthetics:" + error = TRUE ) - expect_error( + expect_snapshot( ggplot_build(ggplot(df) + geom_col()), - "requires the following missing aesthetics:" + error = TRUE ) }) @@ -80,7 +87,7 @@ test_that("if an aes is mapped to a function that returns NULL, it is removed", df <- data_frame(x = 1:10) null <- function(...) NULL p <- cdata(ggplot(df, aes(x, null()))) - expect_identical(names(p[[1]]), c("x", "PANEL", "group")) + expect_named(p[[1]], c("x", "PANEL", "group")) }) test_that("layers are stateless except for the computed params", { @@ -107,12 +114,12 @@ test_that("inherit.aes works", { test_that("retransform works on computed aesthetics in `map_statistic`", { df <- data.frame(x = rep(c(1,2), c(9, 25))) p <- ggplot(df, aes(x)) + geom_bar() + scale_y_sqrt() - expect_equal(layer_data(p)$y, c(3, 5)) + expect_equal(get_layer_data(p)$y, c(3, 5)) # To double check: should be original values when `retransform = FALSE` parent <- p$layers[[1]]$stat p$layers[[1]]$stat <- ggproto(NULL, parent, retransform = FALSE) - expect_equal(layer_data(p)$y, c(9, 25)) + expect_equal(get_layer_data(p)$y, c(9, 25)) }) test_that("layer reports the error with correct index etc", { @@ -138,17 +145,69 @@ test_that("layer warns for constant aesthetics", { expect_snapshot_warning(ggplot_build(p)) }) +test_that("layer names can be resolved", { + + p <- ggplot() + geom_point() + geom_point() + expect_equal(names(p$layers), c("geom_point", "geom_point...2")) + + p <- ggplot() + geom_point(name = "foo") + geom_point(name = "bar") + expect_equal(names(p$layers), c("foo", "bar")) + + l <- geom_point(name = "foobar") + expect_snapshot(p + l + l, error = TRUE) +}) + +test_that("check_subclass can resolve classes via constructors", { + + env <- new_environment(list( + geom_foobar = geom_point, + stat_foobar = stat_boxplot, + position_foobar = position_nudge, + guide_foobar = guide_axis_theta + )) + + 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") + +}) + +test_that("attributes on layer data are preserved", { + # This is a good layer for testing because: + # * It needs to compute a statistic at the group level + # * It needs to setup data to reshape x/y/width/height into xmin/xmax/ymin/ymax + # * It needs to use a position adjustment + # * 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" + ) + # We modify the compute aesthetics method to append a test attribute + new <- ggproto(NULL, old, compute_aesthetics = function(self, data, plot) { + data <- ggproto_parent(old, self)$compute_aesthetics(data, plot) + attr(data, "test") <- "preserve me" + data + }) + # 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) + + scale_y_sqrt() + ) + expect_equal(attr(ld, "test"), "preserve me") +}) + # Data extraction --------------------------------------------------------- test_that("AsIs data passes unmodified", { p <- ggplot() + geom_blank(aes(x = 1:2, y = 1:2)) - ld <- layer_data(p + geom_point(aes(x = I(0.5), y = I(0.5))), 2) + ld <- get_layer_data(p + geom_point(aes(x = I(0.5), y = I(0.5))), 2) expect_s3_class(ld$x, "AsIs") expect_equal(ld$y, I(0.5)) - ld <- layer_data(p + geom_point(x = I(0.5), y = I(0.5), data = mtcars), 2) + ld <- get_layer_data(p + geom_point(x = I(0.5), y = I(0.5), data = mtcars), 2) expect_s3_class(ld$x, "AsIs") expect_equal(ld$y[1], I(0.5)) - ld <- layer_data(p + annotate("point", x = I(0.5), y = I(0.5)), 2) + ld <- get_layer_data(p + annotate("point", x = I(0.5), y = I(0.5)), 2) expect_s3_class(ld$x, "AsIs") expect_equal(ld$y, I(0.5)) }) @@ -165,3 +224,20 @@ test_that("layer_data returns a data.frame", { l <- geom_point(data = nrow) expect_snapshot_error(l$layer_data(mtcars)) }) + +test_that("data.frames and matrix aesthetics survive the build stage", { + df <- data_frame0( + x = 1:2, + g = matrix(1:4, 2), + f = data_frame0(a = 1:2, b = c("c", "d")) + ) + + p <- layer_data( + ggplot(df, aes(x, x, colour = g, shape = f)) + + geom_point() + + scale_colour_identity() + + 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) +}) diff --git a/tests/testthat/test-legend-draw.R b/tests/testthat/test-legend-draw.R new file mode 100644 index 0000000000..5f4cc01032 --- /dev/null +++ b/tests/testthat/test-legend-draw.R @@ -0,0 +1,66 @@ + +test_that("all keys can be drawn without 'params'", { + + params <- list() + size <- convertUnit(calc_element("legend.key.size", theme_gray()), "cm", valueOnly = TRUE) + size <- size * 10 # cm to mm + + # Render every key + # If we're to develop new legend keys, we can keep appending this pattern + # 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) + ) + + # Test that we've covered all exported keys above + nse <- getNamespaceExports(asNamespace("ggplot2")) + nse <- grep("^draw_key", nse, value = TRUE) + nse <- gsub("^draw_key_", "", nse) + expect_in(nse, names(keys)) + + # Add title to every key + template <- gtable(width = 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) + ) + + # Set layout + n <- length(keys) + nrow <- ceiling(n / 5) + ncol <- ceiling(n / nrow) + mtx <- matrix(list(zeroGrob()), nrow = nrow, ncol = ncol) + mtx[seq_along(keys)] <- keys + + # Render as gtable + gt <- gtable_matrix( + name = "layout", grobs = mtx, + widths = unit(rep(size, ncol(mtx)), "mm"), + heights = unit(rep(size, nrow(mtx)), "mm") + unit(1, "lines"), + clip = "off" + ) + gt <- gtable_add_col_space(gt, unit(1, "cm")) + gt <- gtable_add_row_space(gt, unit(1, "cm")) + + expect_doppelganger("all legend keys", gt) +}) diff --git a/tests/testthat/test-margins.R b/tests/testthat/test-margins.R deleted file mode 100644 index 522c457445..0000000000 --- a/tests/testthat/test-margins.R +++ /dev/null @@ -1,3 +0,0 @@ -test_that("justify_grobs() checks input", { - expect_snapshot_error(justify_grobs(1)) -}) diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R index 8e2b64d82e..4939c393b0 100644 --- a/tests/testthat/test-patterns.R +++ b/tests/testthat/test-patterns.R @@ -61,7 +61,10 @@ 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.0") + skip_if_not_installed("svglite", "2.1.2") + # TODO: ideally we should test this on all platforms, but currently they + # don't all produce the same result + skip_if_not(.Platform$OS.type == "windows") # Workaround for vdiffr's lack of pattern support # See also https://github.com/r-lib/vdiffr/issues/132 diff --git a/tests/testthat/test-performance.R b/tests/testthat/test-performance.R index 1c65622b4a..bd737f7c26 100644 --- a/tests/testthat/test-performance.R +++ b/tests/testthat/test-performance.R @@ -12,7 +12,7 @@ testappend <- list( ) test_that("modifyList is masked", { - expect_error(modifyList(testlist, testappend)) + expect_snapshot(modifyList(testlist, testappend), error = TRUE) }) test_that("modify_list retains unreferenced elements", { diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index dc1b507c13..2cccf79034 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -1,6 +1,7 @@ test_that("ggplot() throws informative errors", { expect_snapshot_error(ggplot(mapping = letters)) expect_snapshot_error(ggplot(data)) + expect_snapshot_warning(ggplot(foobar = "nonsense")) }) test_that("construction have user friendly errors", { diff --git a/tests/testthat/test-position-dodge2.R b/tests/testthat/test-position-dodge2.R index 2ef17a4347..5377f14b2d 100644 --- a/tests/testthat/test-position-dodge2.R +++ b/tests/testthat/test-position-dodge2.R @@ -32,7 +32,7 @@ test_that("rectangles are dodged", { p <- ggplot(df, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax)) + geom_rect(aes(fill = fill), position = "dodge2", alpha = 0.8) - expect_false(any(duplicated(find_x_overlaps(layer_data(p))))) + expect_false(any(duplicated(find_x_overlaps(get_layer_data(p))))) }) test_that("cols at the same x position are dodged", { @@ -44,7 +44,7 @@ test_that("cols at the same x position are dodged", { p <- ggplot(df, aes(1, n, fill = x)) + geom_col(position = "dodge2", alpha = 0.5) - expect_false(any(duplicated(find_x_overlaps(layer_data(p))))) + expect_false(any(duplicated(find_x_overlaps(get_layer_data(p))))) }) test_that("padding argument controls space between elements", { @@ -55,8 +55,8 @@ test_that("padding argument controls space between elements", { p2 <- ggplot(df, aes(1, value, fill = group)) + geom_boxplot(position = position_dodge2(padding = 0.1)) - d1 <- layer_data(p1) - d2 <- layer_data(p2) + d1 <- get_layer_data(p1) + d2 <- get_layer_data(p2) gaps <- function(df) { gap <- vector() @@ -81,7 +81,7 @@ test_that("boxes in facetted plots keep the correct width", { facet_wrap( ~ group) + geom_boxplot() - d <- layer_data(p) + d <- get_layer_data(p) expect_true(all(d$xmax - d$xmin == 0.75)) }) @@ -97,7 +97,7 @@ test_that("width of groups is computed per facet", { geom_col(position = position_dodge2(preserve = "single")) + facet_wrap(vars(g1)) - d <- layer_data(p) + d <- get_layer_data(p) width <- d$xmax - d$xmin expect_true(all(width == (0.9 / 3) * 0.9)) @@ -118,3 +118,11 @@ test_that("groups are different when two blocks have externall touching point",{ ) expect_equal(find_x_overlaps(df1), seq_len(2)) }) + +test_that("overlaps are identified correctly", { + df <- data.frame( + xmin = c(1, 2, 3, 5), + xmax = c(4, 3, 4, 6) + ) + expect_equal(find_x_overlaps(df), c(1, 1, 1, 2)) +}) diff --git a/tests/testthat/test-position-jitter.R b/tests/testthat/test-position-jitter.R new file mode 100644 index 0000000000..7442c7877c --- /dev/null +++ b/tests/testthat/test-position-jitter.R @@ -0,0 +1,15 @@ +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) + 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 + + # 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-jitterdodge.R b/tests/testthat/test-position-jitterdodge.R index 8f6b9227eb..fb3274e61a 100644 --- a/tests/testthat/test-position-jitterdodge.R +++ b/tests/testthat/test-position-jitterdodge.R @@ -1,4 +1,11 @@ -test_that("position_jitterdodge() fails with meaningful error", { - p <- ggplot(mtcars) + geom_point(aes(disp, mpg), position = 'jitterdodge') - expect_snapshot_error(ggplot_build(p)) +test_that("position_jitterdodge preserves widths", { + ld <- layer_data( + ggplot(mtcars, aes(factor(cyl), fill = factor(am))) + + geom_bar(position = position_jitterdodge()) + ) + + expect_equal( + as.numeric(ld$xmax - ld$xmin), + rep(0.45, nrow(ld)) + ) }) diff --git a/tests/testthat/test-position-nudge.R b/tests/testthat/test-position-nudge.R index 2ec0e767e2..564595b36e 100644 --- a/tests/testthat/test-position-nudge.R +++ b/tests/testthat/test-position-nudge.R @@ -5,7 +5,7 @@ test_that("nudging works in both dimensions simultaneously", { p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + geom_point(position = position_nudge(x = 1, y = 2)) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$x, 2:4) expect_equal(data$xmin, 2:4) @@ -20,7 +20,7 @@ test_that("nudging works in both dimensions simultaneously", { p <- ggplot(df, aes(x, x, xmax = x, xmin = x, ymax = x, ymin = x)) + geom_point(position = position_nudge(x = c(0, -1, 0), y = c(0, 1, 2))) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$x, c(1, 1, 1)) expect_equal(data$xmin, c(1, 1, 1)) @@ -39,7 +39,7 @@ test_that("nudging works in individual dimensions", { p <- ggplot(df, aes(x = x, xmax = x, xmin = x)) + layer(geom = Geom, stat = StatIdentity, position = position_nudge(x = 1)) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$x, 2:4) expect_equal(data$xmin, 2:4) @@ -49,7 +49,7 @@ test_that("nudging works in individual dimensions", { p <- ggplot(df, aes(x = x, xmax = x, xmin = x)) + layer(geom = Geom, stat = StatIdentity, position = position_nudge(x = c(0, -1, -2))) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$x, c(1, 1, 1)) expect_equal(data$xmin, c(1, 1, 1)) @@ -61,7 +61,7 @@ test_that("nudging works in individual dimensions", { p <- ggplot(df, aes(y = x, ymax = x, ymin = x)) + layer(geom = Geom, stat = StatIdentity, position = position_nudge(y = 2)) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$y, 3:5) expect_equal(data$ymin, 3:5) @@ -71,7 +71,7 @@ test_that("nudging works in individual dimensions", { p <- ggplot(df, aes(y = x, ymax = x, ymin = x)) + layer(geom = Geom, stat = StatIdentity, position = position_nudge(y = c(0, -1, -2))) - data <- layer_data(p) + data <- get_layer_data(p) expect_equal(data$y, c(1, 1, 1)) expect_equal(data$ymin, c(1, 1, 1)) diff --git a/tests/testthat/test-position-stack.R b/tests/testthat/test-position-stack.R index 6b404284de..54c6b858e8 100644 --- a/tests/testthat/test-position-stack.R +++ b/tests/testthat/test-position-stack.R @@ -6,7 +6,7 @@ test_that("data keeps its order after stacking", { ) p <- ggplot(df, aes(x = x, y = y, fill = var)) + geom_area(stat = "identity", position = "stack") - dat <- layer_data(p) + dat <- get_layer_data(p) expect_true(all(dat$group == rep(1:3, each = 10))) expect_true(all(dat$x == df$x)) }) @@ -18,13 +18,19 @@ test_that("negative and positive values are handled separately", { y = c(1,-1,1,2,-3) ) p <- ggplot(df, aes(x, y, fill = factor(g))) + geom_col() - dat <- layer_data(p) + dat <- get_layer_data(p) expect_equal(dat$ymin[dat$x == 1], c(1, -1, 0)) expect_equal(dat$ymax[dat$x == 1], c(2, 0, 1)) expect_equal(dat$ymin[dat$x == 2], c(0, -3)) expect_equal(dat$ymax[dat$x == 2], c(2, 0)) + + # Test only negatives #6088 + df <- data_frame0(x = c(1, 1, 2, 2), y = c(-1, -1, -1, -1), g = LETTERS[1:4]) + dat <- get_layer_data(ggplot(df, aes(x, y, fill = factor(g))) + geom_col()) + expect_equal(dat$ymax, dat$ymin + 1) + expect_equal(dat$ymin, c(-2, -1, -2, -1)) }) test_that("can request reverse stacking", { @@ -34,7 +40,7 @@ test_that("can request reverse stacking", { ) p <- ggplot(df, aes(1, y, fill = g)) + geom_col(position = position_stack(reverse = TRUE)) - dat <- layer_data(p) + dat <- get_layer_data(p) expect_equal(dat$ymin, c(-2, 0, -3, 2)) }) @@ -48,14 +54,14 @@ test_that("data with no extent is stacked correctly", { p0 <- base + geom_text(aes(label = y), position = position_stack(vjust = 0)) p1 <- base + geom_text(aes(label = y), position = position_stack(vjust = 1)) - expect_equal(layer_data(p0)$y, c(-115, -75)) - expect_equal(layer_data(p1)$y, c(-75, 0)) + expect_equal(get_layer_data(p0)$y, c(-115, -75)) + expect_equal(get_layer_data(p1)$y, c(-75, 0)) }) test_that("position_stack() can stack correctly when ymax is NA", { df <- data_frame(x = c(1, 1), y = c(1, 1)) p <- ggplot(df, aes(x, y, ymax = NA_real_)) + geom_point(position = "stack") - expect_equal(layer_data(p)$y, c(1, 2)) + expect_equal(get_layer_data(p)$y, c(1, 2)) }) # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-position_dodge.R b/tests/testthat/test-position_dodge.R index 4d540176ad..878ee6d155 100644 --- a/tests/testthat/test-position_dodge.R +++ b/tests/testthat/test-position_dodge.R @@ -6,6 +6,65 @@ test_that("can control whether to preserve total or individual width", { p_single <- ggplot(df, aes(x, fill = y)) + geom_bar(position = position_dodge(preserve = "single"), width = 1) - expect_equal(layer_data(p_total)$x, new_mapped_discrete(c(1, 1.75, 2.25))) - expect_equal(layer_data(p_single)$x, new_mapped_discrete(c(0.75, 1.75, 2.25))) + 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))) +}) + +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))) + + geom_point(position = position_dodge(width = 1, orientation = "x")) + 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") + +}) + +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 + p <- ggplot(df, aes(x, y = 1, fill = group, label = group)) + + ld <- get_layer_data(p + geom_col(position = position_dodge(reverse = TRUE))) + expect_equal(ld$label[order(ld$x)], c("A", "B", "A", "C", "B")) + + ld <- get_layer_data(p + geom_col(position = position_dodge(reverse = FALSE))) + expect_equal(ld$label[order(ld$x)], c("A", "A", "B", "B", "C")) +}) + +test_that("position_dodge() can use the order aesthetic", { + + 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], + g = c("X", "Y", "Z")[minor] + ) + ld <- layer_data( + ggplot(df, aes(x, 1, colour = g, order = g)) + + geom_point(position = position_dodge(preserve = "single", width = 0.6)) + ) + expect_equal(ld$x, major + c(-0.2, 0, 0.2)[minor], ignore_attr = TRUE) +}) + +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") + + p <- ggplot(mtcars, aes(cyl, disp, colour = factor(vs))) + + layer( + geom = GeomDummy, + stat = "identity", + position = position_dodge(width = 0.5), + mapping = aes(x = NULL) + ) + + expect_snapshot(ggplot_build(p), error = TRUE) }) diff --git a/tests/testthat/test-qplot.R b/tests/testthat/test-qplot.R index 12fd2f229f..74ab153c39 100644 --- a/tests/testthat/test-qplot.R +++ b/tests/testthat/test-qplot.R @@ -37,7 +37,7 @@ test_that("qplot() evaluates constants in the right place", { qplot(1, 1, colour = I(paste0("re", foo))) }) ) - expect_identical(layer_data(p)$colour, I("red")) + expect_identical(get_layer_data(p)$colour, I("red")) }) test_that("qplot() evaluates layers in package environment", { @@ -46,7 +46,7 @@ test_that("qplot() evaluates layers in package environment", { } lifecycle::expect_deprecated( - expect_error(p <- qplot(1, 1, geom = "line"), NA) + expect_no_error(p <- qplot(1, 1, geom = "line")) ) }) diff --git a/tests/testthat/test-scale-binned.R b/tests/testthat/test-scale-binned.R index 31e32e9eba..22ce6ef12a 100644 --- a/tests/testthat/test-scale-binned.R +++ b/tests/testthat/test-scale-binned.R @@ -44,6 +44,16 @@ test_that("binned limits should not compute out-of-bounds breaks", { )) }) +test_that("binned scales can use limits and transformations simultaneously (#6144)", { + s <- scale_x_binned( + limits = function(x) x + 1, + transform = transform_log10() + ) + s$train(c(0, 1)) # c(1, 10) in untransformed space + out <- s$get_limits() + expect_equal(s$get_limits(), log10(c(2, 11))) +}) + test_that("binned scales can use NAs in limits", { scale <- scale_x_binned(limits = c(NA, 10)) scale$train(c(-20, 20)) @@ -94,3 +104,9 @@ test_that('binned scales can calculate breaks on date-times', { ))) ) }) + +test_that("binned scales can calculate breaks for zero-width data", { + scale <- scale_x_binned() + scale$train(c(1, 1)) + expect_equal(scale$get_breaks(), c(0.95, 1.05)) +}) diff --git a/tests/testthat/test-scale-brewer.R b/tests/testthat/test-scale-brewer.R index b838952fbe..d14edd1a8b 100644 --- a/tests/testthat/test-scale-brewer.R +++ b/tests/testthat/test-scale-brewer.R @@ -5,11 +5,11 @@ test_that("mid-point in diverging brewer color scale", { aes(x = x, y = 1, color = x) + scale_color_distiller(palette = 'RdBu', direction = 1, limits = c(-1, 1)) - expect_equal(layer_data(p)$colour, c("#B2182B", "#F7F7F7", "#2166AC")) + expect_equal(get_layer_data(p)$colour, c("#B2182B", "#F7F7F7", "#2166AC")) p <- ggplot(d) + aes(x = x, y = 1, fill = x) + scale_fill_distiller(palette = 'RdBu', direction = 1, limits = c(-1, 1)) - expect_equal(layer_data(p)$fill, c("#B2182B", "#F7F7F7", "#2166AC")) + expect_equal(get_layer_data(p)$fill, c("#B2182B", "#F7F7F7", "#2166AC")) }) diff --git a/tests/testthat/test-scale-colour-continuous.R b/tests/testthat/test-scale-colour-continuous.R deleted file mode 100644 index e97e3d5b01..0000000000 --- a/tests/testthat/test-scale-colour-continuous.R +++ /dev/null @@ -1,20 +0,0 @@ -test_that("type argument is checked for proper input", { - expect_snapshot_error( - scale_colour_continuous(type = function() "abc") - ) - expect_snapshot_error( - suppressWarnings(scale_fill_continuous(type = geom_point)) - ) - expect_snapshot_error( - scale_colour_binned(type = function(...) scale_colour_binned(aesthetics = c("fill", "point_colour"))) - ) - expect_snapshot_error( - scale_fill_binned(type = scale_fill_brewer) - ) - expect_snapshot_error( - scale_fill_continuous(type = "abc") - ) - expect_snapshot_error( - scale_colour_continuous(type = "abc") - ) -}) diff --git a/tests/testthat/test-scale-colour.R b/tests/testthat/test-scale-colour.R new file mode 100644 index 0000000000..bcdbc90892 --- /dev/null +++ b/tests/testthat/test-scale-colour.R @@ -0,0 +1,51 @@ +test_that("type argument is checked for proper input", { + expect_snapshot_error( + scale_colour_continuous(type = function() "abc") + ) + expect_snapshot_error( + suppressWarnings(scale_fill_continuous(type = geom_point)) + ) + expect_snapshot_error( + scale_colour_binned(type = function(...) scale_colour_binned(aesthetics = c("fill", "point_colour"))) + ) + expect_snapshot_error( + scale_fill_binned(type = scale_fill_brewer) + ) + expect_snapshot_error( + scale_fill_continuous(type = "abc") + ) + expect_snapshot_error( + scale_colour_continuous(type = "abc") + ) +}) + +test_that("palette arguments can take alternative input", { + + cols <- c("red", "gold", "green", "cyan", "blue", "magenta") + hex <- alpha(cols, 1) + + sc <- scale_colour_continuous(palette = cols) + test <- sc$palette(seq(0, 1, length.out = length(cols))) + expect_equal(alpha(test, 1), hex) + + sc <- scale_fill_continuous(palette = cols) + test <- sc$palette(seq(0, 1, length.out = length(cols))) + expect_equal(alpha(test, 1), hex) + + sc <- scale_colour_binned(palette = cols) + test <- sc$palette(seq_along(cols)) + expect_equal(alpha(test, 1), hex) + + sc <- scale_fill_binned(palette = cols) + test <- sc$palette(seq_along(cols)) + expect_equal(alpha(test, 1), hex) + + sc <- scale_colour_discrete(palette = cols) + test <- sc$palette(length(cols)) + expect_equal(alpha(test, 1), hex) + + 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 8f0e1fa410..48259e3261 100644 --- a/tests/testthat/test-scale-date.R +++ b/tests/testthat/test-scale-date.R @@ -15,14 +15,14 @@ test_that("inherits timezone from data", { # Local time p <- ggplot(df, aes(y = y)) + geom_point(aes(time1)) - sc <- layer_scales(p)$x + sc <- get_panel_scales(p)$x expect_true(identical(sc$timezone, NULL)) expect_equal(sc$get_labels()[1], "00:00") # UTC p <- ggplot(df, aes(y = y)) + geom_point(aes(time2)) - sc <- layer_scales(p)$x + sc <- get_panel_scales(p)$x expect_equal(sc$timezone, "UTC") expect_equal(sc$get_labels()[1], "00:00") }) @@ -33,7 +33,7 @@ test_that("first timezone wins", { geom_point(aes(time2)) + geom_point(aes(time3), colour = "red") + scale_x_datetime(date_breaks = "hour", date_labels = "%H:%M") - sc <- layer_scales(p)$x + sc <- get_panel_scales(p)$x expect_equal(sc$timezone, "UTC") }) @@ -43,22 +43,36 @@ test_that("not cached across calls", { p1 <- ggplot(df, aes(y = y)) + geom_point(aes(time2)) + scale_x p2 <- ggplot(df, aes(y = y)) + geom_point(aes(time3)) + scale_x - expect_equal(layer_scales(p1)$x$timezone, "UTC") - expect_equal(layer_scales(p2)$x$timezone, "Australia/Lord_Howe") + expect_equal(get_panel_scales(p1)$x$timezone, "UTC") + expect_equal(get_panel_scales(p2)$x$timezone, "Australia/Lord_Howe") +}) + +test_that("time scale date breaks and labels work", { + skip_if_not_installed("hms") + + d <- c(base_time(), base_time() + 5 * 24 * 3600) - base_time() + + sc <- scale_x_time(date_breaks = "1 day", date_labels = "%d") + sc$train(d) + + breaks <- sc$get_breaks() + expect_length(breaks, 6) + labels <- sc$get_labels(breaks) + expect_equal(labels, paste0("0", 1:6)) }) test_that("datetime size scales work", { p <- ggplot(df, aes(y = y)) + geom_point(aes(time1, size = time1)) # Default size range is c(1, 6) - expect_equal(range(layer_data(p)$size), c(1, 6)) + expect_equal(range(get_layer_data(p)$size), c(1, 6)) }) test_that("datetime alpha scales work", { p <- ggplot(df, aes(y = y)) + geom_point(aes(time1, alpha = time1)) # Default alpha range is c(0.1, 1.0) - expect_equal(range(layer_data(p)$alpha), c(0.1, 1.0)) + expect_equal(range(get_layer_data(p)$alpha), c(0.1, 1.0)) }) test_that("datetime colour scales work", { @@ -66,5 +80,27 @@ test_that("datetime colour scales work", { geom_point(aes(time1, colour = time1)) + scale_colour_datetime() - expect_equal(range(layer_data(p)$colour), c("#132B43", "#56B1F7")) + expect_equal(range(get_layer_data(p)$colour), c("#132B43", "#56B1F7")) +}) + +test_that("date(time) scales throw warnings when input is incorrect", { + p <- ggplot(data.frame(x = 1, y = 1), aes(x, y)) + geom_point() + + expect_snapshot_warning(ggplot_build(p + scale_x_date())) + expect_snapshot_warning(ggplot_build(p + scale_x_datetime())) + + expect_snapshot( + ggplot_build(p + scale_x_date(date_breaks = c(11, 12))), + error = TRUE + ) + + expect_snapshot( + ggplot_build(p + scale_x_date(date_minor_breaks = c(11, 12))), + error = TRUE + ) + + expect_snapshot( + ggplot_build(p + scale_x_date(date_labels = c(11, 12))), + error = TRUE + ) }) diff --git a/tests/testthat/test-scale-discrete.R b/tests/testthat/test-scale-discrete.R index d9ce98c494..50f7b585fe 100644 --- a/tests/testthat/test-scale-discrete.R +++ b/tests/testthat/test-scale-discrete.R @@ -1,10 +1,9 @@ # Missing values ---------------------------------------------------------- -df <- tibble::tibble( +df <- data_frame0( x1 = c("a", "b", NA), - x2 = factor(x1), - x3 = addNA(x2), - + x2 = factor(c("a", "b", NA)), + x3 = factor(c("a", "b", NA), levels = c("a", "b", NA), exclude = NULL), y = 1:3 ) @@ -13,35 +12,35 @@ test_that("NAs are translated/preserved for position scales", { p2a <- ggplot(df, aes(x2, y)) + geom_point() p3a <- ggplot(df, aes(x3, y)) + geom_point() - expect_equal(layer_data(p1a)$x, new_mapped_discrete(c(1, 2, 3))) - expect_equal(layer_data(p2a)$x, new_mapped_discrete(c(1, 2, 3))) - expect_equal(layer_data(p3a)$x, new_mapped_discrete(c(1, 2, 3))) + expect_equal(get_layer_data(p1a)$x, new_mapped_discrete(c(1, 2, 3))) + expect_equal(get_layer_data(p2a)$x, new_mapped_discrete(c(1, 2, 3))) + expect_equal(get_layer_data(p3a)$x, new_mapped_discrete(c(1, 2, 3))) rm_na_x <- scale_x_discrete(na.translate = FALSE) p1b <- p1a + rm_na_x p2b <- p2a + rm_na_x p3b <- p3a + rm_na_x - expect_equal(layer_data(p1b)$x, new_mapped_discrete(c(1, 2, NA))) - expect_equal(layer_data(p2b)$x, new_mapped_discrete(c(1, 2, NA))) - expect_equal(layer_data(p3b)$x, new_mapped_discrete(c(1, 2, NA))) + expect_equal(get_layer_data(p1b)$x, new_mapped_discrete(c(1, 2, NA))) + expect_equal(get_layer_data(p2b)$x, new_mapped_discrete(c(1, 2, NA))) + expect_equal(get_layer_data(p3b)$x, new_mapped_discrete(c(1, 2, NA))) }) test_that("NAs are translated/preserved for non-position scales", { p1a <- ggplot(df, aes(y, y, colour = x1)) + geom_point() p2a <- ggplot(df, aes(y, y, colour = x2)) + geom_point() p3a <- ggplot(df, aes(y, y, colour = x3)) + geom_point() - expect_equal(layer_data(p1a)$colour, c("#F8766D", "#00BFC4", "grey50")) - expect_equal(layer_data(p2a)$colour, c("#F8766D", "#00BFC4", "grey50")) - expect_equal(layer_data(p3a)$colour, c("#F8766D", "#00BFC4", "grey50")) + expect_equal(get_layer_data(p1a)$colour, c("#F8766D", "#00BFC4", "grey50")) + expect_equal(get_layer_data(p2a)$colour, c("#F8766D", "#00BFC4", "grey50")) + expect_equal(get_layer_data(p3a)$colour, c("#F8766D", "#00BFC4", "grey50")) rm_na_colour <- scale_colour_discrete(na.translate = FALSE) p1b <- p1a + rm_na_colour p2b <- p2a + rm_na_colour p3b <- p3a + rm_na_colour - expect_equal(layer_data(p1b)$colour, c("#F8766D", "#00BFC4", NA)) - expect_equal(layer_data(p2b)$colour, c("#F8766D", "#00BFC4", NA)) - expect_equal(layer_data(p3b)$colour, c("#F8766D", "#00BFC4", NA)) + expect_equal(get_layer_data(p1b)$colour, c("#F8766D", "#00BFC4", NA)) + expect_equal(get_layer_data(p2b)$colour, c("#F8766D", "#00BFC4", NA)) + expect_equal(get_layer_data(p3b)$colour, c("#F8766D", "#00BFC4", NA)) }) # Ranges ------------------------------------------------------------------ @@ -52,7 +51,7 @@ test_that("discrete ranges also encompass continuous values", { base <- ggplot(df, aes(y = y)) + scale_x_discrete() x_range <- function(x) { - layer_scales(x)$x$dimension() + get_panel_scales(x)$x$dimension() } expect_equal(x_range(base + geom_point(aes(x1))), c(1, 3)) @@ -71,7 +70,7 @@ test_that("discrete scale shrinks to range when setting limits", { p <- ggplot(df, aes(x, y)) + geom_point() + scale_x_discrete(limits = c("a", "b")) - expect_equal(layer_scales(p)$x$dimension(c(0, 1)), c(0, 3)) + expect_equal(get_panel_scales(p)$x$dimension(c(0, 1)), c(0, 3)) }) test_that("discrete position scales can accept functional limits", { @@ -98,14 +97,14 @@ test_that("discrete scale defaults can be set globally", { ggplot2.discrete.colour = c("#FFFFFF", "#000000")), { # nlevels == ncodes two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point() - expect_equal(layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) - expect_equal(layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2)) + expect_equal(get_layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) + expect_equal(get_layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2)) # nlevels > ncodes (so should fallback to scale_fill_hue()) four_default <- ggplot(df, aes(x, y, colour = four, fill = four)) + geom_point() four_hue <- four_default + scale_fill_hue() - expect_equal(layer_data(four_default)$colour, layer_data(four_hue)$colour) + expect_equal(get_layer_data(four_default)$colour, get_layer_data(four_hue)$colour) } ) @@ -122,25 +121,25 @@ test_that("discrete scale defaults can be set globally", { ), { # nlevels == 2 two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point() - expect_equal(layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) - expect_equal(layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2)) + expect_equal(get_layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2)) + expect_equal(get_layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2)) # nlevels == 4 four <- ggplot(df, aes(x, y, colour = four, fill = four)) + geom_point() - expect_equal(layer_data(four)$colour, c("#FF0000", "#00FF00", "#0000FF", "#FF00FF")) - expect_equal(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_error(scale_colour_discrete(type = scale_colour_gradient)) - expect_error(scale_fill_discrete(type = scale_fill_gradient)) + expect_snapshot(scale_colour_discrete(type = scale_colour_gradient), error = TRUE) + expect_snapshot(scale_fill_discrete(type = scale_fill_gradient), error = TRUE) # Check aesthetic - expect_error(scale_colour_discrete(type = scale_fill_hue)) - expect_error(scale_fill_discrete(type = scale_colour_hue)) + expect_snapshot(scale_colour_discrete(type = scale_fill_hue), error = TRUE) + expect_snapshot(scale_fill_discrete(type = scale_colour_hue), error = TRUE) }) test_that("Aesthetics with no continuous interpretation fails when called", { @@ -154,7 +153,7 @@ test_that("mapped_discrete vectors behaves as predicted", { expect_null(mapped_discrete(NULL)) expect_s3_class(mapped_discrete(c(0, 3.5)), "mapped_discrete") expect_s3_class(mapped_discrete(seq_len(4)), "mapped_discrete") - expect_error(mapped_discrete(letters)) + expect_snapshot(mapped_discrete(letters), error = TRUE) x <- mapped_discrete(1:10) expect_s3_class(x[2:4], "mapped_discrete") @@ -162,3 +161,45 @@ test_that("mapped_discrete vectors behaves as predicted", { x[5:7] <- mapped_discrete(seq_len(3)) expect_s3_class(x, "mapped_discrete") }) + +# Palettes ---------------------------------------------------------------- + +test_that("palettes work for discrete scales", { + + df <- data.frame(x = c("A", "B", "C"), y = 1:3) + values <- c(1, 10, 100) + + p <- ggplot(df, aes(x, y)) + + geom_point() + + scale_x_discrete(palette = function(x) values) + + # Check limits are translated to correct values + ld <- get_layer_data(p) + expect_equal(ld$x, values, ignore_attr = TRUE) + + # Check discsrete expansion is applied + b <- ggplot_build(p) + expect_equal( + b$layout$panel_params[[1]]$x.range, + range(values) + c(-0.6, 0.6) + ) +}) + +test_that("invalid palettes trigger errors", { + + df <- data.frame(x = c("A", "B", "C"), y = 1:3) + + p <- ggplot(df, aes(x, y)) + + geom_point() + + expect_snapshot( + ggplot_build(p + scale_x_discrete(palette = function(x) LETTERS[1:3])), + error = TRUE + ) + + expect_snapshot( + ggplot_build(p + scale_x_discrete(palette = function(x) 1:2)), + error = TRUE + ) +}) + diff --git a/tests/testthat/test-scale-expansion.R b/tests/testthat/test-scale-expansion.R index 7d1b5b30ae..331c6a651d 100644 --- a/tests/testthat/test-scale-expansion.R +++ b/tests/testthat/test-scale-expansion.R @@ -1,6 +1,6 @@ test_that("expand_scale() produces a deprecation warning", { - expect_warning(expand_scale(), "deprecated") + lifecycle::expect_deprecated(expand_scale()) }) test_that("expansion() checks input", { @@ -65,7 +65,7 @@ test_that("expand_limits_discrete() can override limits with an empty range", { 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(3, 2)) + 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", { @@ -96,6 +96,27 @@ test_that("expand_limits_discrete() can override limits with a both discrete and 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)), + c(0, 3) + ) + expect_identical( + 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)), + c(0, 2) + ) + expect_identical( + 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)), + c(0, 3) + ) }) test_that("expand_limits_continuous_trans() works with inverted transformations", { @@ -106,7 +127,7 @@ test_that("expand_limits_continuous_trans() works with inverted transformations" ) expect_identical(limit_info$continuous_range, c(0, 3)) - expect_identical(limit_info$continuous_range_coord, c(0, -3)) + expect_identical(limit_info$continuous_range_coord, c(-3, 0)) }) test_that("expand_limits_scale_discrete() begrudgingly handles numeric limits", { @@ -116,6 +137,6 @@ test_that("expand_limits_scale_discrete() begrudgingly handles numeric limits", coord_limits = c(NA, NA), range_continuous = c(-15, -2) ), - c(-15, -2) + c(-16, -1) ) }) diff --git a/tests/testthat/test-scale-gradient.R b/tests/testthat/test-scale-gradient.R index b6da7049bb..771490f945 100644 --- a/tests/testthat/test-scale-gradient.R +++ b/tests/testthat/test-scale-gradient.R @@ -7,7 +7,7 @@ test_that("points outside the limits are plotted as NA", { scale_fill_gradient2(limits = c(-1, 1), midpoint = 2, na.value = "orange") correct_fill <- c("#B26D65", "#DCB4AF", "orange") - expect_equal(layer_data(p)$fill, correct_fill) + expect_equal(get_layer_data(p)$fill, correct_fill) }) test_that("midpoints are transformed", { @@ -20,8 +20,7 @@ test_that("midpoints are transformed", { scale$train(scale$transform(c(1, 1000))) ans <- scale$rescale(c(0, 3), c(0.25, 1)) - expect_warning( - scale_colour_gradient2(midpoint = 0, transform = "log10"), - "introduced infinite values" + expect_snapshot_warning( + scale_colour_gradient2(midpoint = 0, transform = "log10") ) }) diff --git a/tests/testthat/test-scale-hue.R b/tests/testthat/test-scale-hue.R index 12568590a8..6f0b0c5234 100644 --- a/tests/testthat/test-scale-hue.R +++ b/tests/testthat/test-scale-hue.R @@ -1,6 +1,5 @@ test_that("scale_hue() checks the type input", { - pal <- pal_qualitative(type = 1:4) - expect_snapshot_error(pal(4)) + expect_snapshot_error(pal_qualitative(type = 1:4)) pal <- pal_qualitative(type = colors()) expect_silent(pal(4)) pal <- pal_qualitative(type = list(colors()[1:10], colors()[11:30])) diff --git a/tests/testthat/test-scale-manual.R b/tests/testthat/test-scale-manual.R index 532e18b2f6..324485952b 100644 --- a/tests/testthat/test-scale-manual.R +++ b/tests/testthat/test-scale-manual.R @@ -47,15 +47,14 @@ test_that("missing values are replaced with na.value", { geom_point() + scale_colour_manual(values = c("black", "black"), na.value = "red") - expect_equal(layer_data(p)$colour, c("black", "black", "red")) + expect_equal(get_layer_data(p)$colour, c("black", "black", "red")) }) 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_error(ggplot_build(p + scale_colour_manual(values = "black")), - "Insufficient values") + 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"))) @@ -80,7 +79,7 @@ test_that("generic scale can be used in place of aesthetic-specific scales", { 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(layer_data(p1), layer_data(p2)) + expect_equal(get_layer_data(p1), get_layer_data(p2)) }) test_that("named values do not match with breaks in manual scales", { @@ -122,7 +121,7 @@ test_that("fewer values (#3451)", { # unnamed character vector s2 <- scale_colour_manual(values = c("4", "8"), na.value = NA) s2$train(c("4", "6", "8")) - expect_error(s2$map(c("4", "6", "8")), "Insufficient values") + expect_snapshot(s2$map(c("4", "6", "8")), error = TRUE) }) test_that("limits and breaks (#4619)", { @@ -152,3 +151,34 @@ test_that("limits and breaks (#4619)", { expect_equal(s3$map(c("4", "6", "8")), c("a", "b", "c")) expect_equal(s3$break_positions(), c("a", "c")) }) + +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" + ) + 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 + ) + 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" + ) + 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) + 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-type.R b/tests/testthat/test-scale-type.R index 4be2fe9ebf..3ca1f06637 100644 --- a/tests/testthat/test-scale-type.R +++ b/tests/testthat/test-scale-type.R @@ -1,9 +1,9 @@ test_that("no scale for NULL aesthetic", { - expect_equal(find_scale("colour", NULL), NULL) + expect_null(find_scale("colour", NULL)) }) test_that("no scale for Inf aesthetic", { - expect_equal(find_scale("colour", Inf), NULL) + expect_null(find_scale("colour", Inf)) }) test_that("message + continuous for unknown type", { diff --git a/tests/testthat/test-scale_date.R b/tests/testthat/test-scale_date.R index f12a35716c..b9a788bb70 100644 --- a/tests/testthat/test-scale_date.R +++ b/tests/testthat/test-scale_date.R @@ -1,4 +1,19 @@ +test_that("date(time) scales coerce data types", { + + date <- as.Date("2024-11-11") + datetime <- as.POSIXct(date) + + sc <- scale_x_datetime() + df <- sc$transform_df(data_frame0(x = date)) + expect_equal(df$x, as.numeric(datetime)) + + sc <- scale_x_date() + df <- sc$transform_df(data_frame0(x = datetime)) + expect_equal(df$x, as.numeric(date)) + +}) + # Visual tests ------------------------------------------------------------ test_that("date scale draws correctly", { diff --git a/tests/testthat/test-scales-breaks-labels.R b/tests/testthat/test-scales-breaks-labels.R index 49f86136fc..e0b8474a40 100644 --- a/tests/testthat/test-scales-breaks-labels.R +++ b/tests/testthat/test-scales-breaks-labels.R @@ -7,15 +7,13 @@ test_that("labels match breaks, even when outside limits", { }) test_that("labels match breaks", { - expect_error(scale_x_discrete(breaks = 1:3, labels = 1:2), - "must have the same length") - expect_error(scale_x_continuous(breaks = 1:3, labels = 1:2), - "must have the same length") + expect_snapshot(scale_x_discrete(breaks = 1:3, labels = 1:2), error = TRUE) + expect_snapshot(scale_x_continuous(breaks = 1:3, labels = 1:2), error = TRUE) }) test_that("labels don't have to match null breaks", { - expect_true(check_breaks_labels(breaks = 1:3, labels = NULL)) - expect_true(check_breaks_labels(breaks = NULL, labels = 1:2)) + expect_silent(check_breaks_labels(breaks = 1:3, labels = NULL)) + expect_silent(check_breaks_labels(breaks = NULL, labels = 1:2)) }) test_that("labels don't have extra spaces", { @@ -47,9 +45,9 @@ test_that("out-of-range breaks are dropped", { # 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)) bi <- sc$break_info() - expect_equal(length(bi$labels), 0) - expect_equal(length(bi$major), 0) - expect_equal(length(bi$major_source), 0) + expect_length(bi$labels, 0) + expect_length(bi$major, 0) + expect_length(bi$major_source, 0) # limits aren't specified, automatic labels # limits are set by the data @@ -72,36 +70,36 @@ test_that("out-of-range breaks are dropped", { 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_equal(length(bi$labels), 0) - expect_equal(length(bi$major), 0) - expect_equal(length(bi$major_source), 0) + expect_length(bi$labels, 0) + expect_length(bi$major, 0) + expect_length(bi$major_source, 0) }) test_that("no minor breaks when only one break", { sc1 <- scale_x_discrete(limits = "a") - sc2 <- scale_x_continuous(limits = 1) + sc2 <- scale_x_continuous(limits = c(1, 1)) - expect_equal(length(sc1$get_breaks_minor()), 0) - expect_equal(length(sc2$get_breaks_minor()), 0) + expect_length(sc1$get_breaks_minor(), 0) + expect_length(sc2$get_breaks_minor(), 0) }) init_scale <- function(...) { sc <- scale_x_discrete(...) sc$train(factor(1:100)) - expect_equal(length(sc$get_limits()), 100) + expect_length(sc$get_limits(), 100) sc } test_that("discrete labels match breaks", { sc <- init_scale(breaks = 0:5 * 10) - expect_equal(length(sc$get_breaks()), 5) - expect_equal(length(sc$get_labels()), 5) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) expect_equal(sc$get_labels(), sc$get_breaks(), ignore_attr = TRUE) sc <- init_scale(breaks = 0:5 * 10, labels = letters[1:6]) - expect_equal(length(sc$get_breaks()), 5) - expect_equal(length(sc$get_labels()), 5) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) expect_equal(sc$get_labels(), letters[2:6]) sc <- init_scale(breaks = 0:5 * 10, labels = @@ -110,8 +108,8 @@ test_that("discrete labels match breaks", { pick_5 <- function(x) sample(x, 5) sc <- init_scale(breaks = pick_5) - expect_equal(length(sc$get_breaks()), 5) - expect_equal(length(sc$get_labels()), 5) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) }) test_that("scale breaks work with numeric log transformation", { @@ -137,35 +135,53 @@ test_that("discrete scales with no data have no breaks or labels", { }) test_that("passing continuous limits to a discrete scale generates a warning", { - expect_warning(scale_x_discrete(limits = 1:3), "Continuous limits supplied to discrete scale") + expect_snapshot_warning(scale_x_discrete(limits = 1:3)) }) test_that("suppressing breaks, minor_breask, and labels works", { - expect_equal(scale_x_continuous(breaks = NULL, limits = c(1, 3))$get_breaks(), NULL) - expect_equal(scale_x_discrete(breaks = NULL, limits = c("one", "three"))$get_breaks(), NULL) - expect_equal(scale_x_continuous(minor_breaks = NULL, limits = c(1, 3))$get_breaks_minor(), NULL) + 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_equal(scale_x_continuous(labels = NULL, limits = c(1, 3))$get_labels(), NULL) - expect_equal(scale_x_discrete(labels = NULL, limits = c("one", "three"))$get_labels(), NULL) + 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()) # date, datetime lims <- as.Date(c("2000/1/1", "2000/2/1")) - expect_equal(scale_x_date(breaks = NULL, limits = lims)$get_breaks(), NULL) + expect_null(scale_x_date(breaks = NULL, limits = lims)$get_breaks()) # NA is defunct, should throw error - expect_error(scale_x_date(breaks = NA, limits = lims)$get_breaks()) - expect_equal(scale_x_date(labels = NULL, limits = lims)$get_labels(), NULL) - expect_error(scale_x_date(labels = NA, limits = lims)$get_labels()) - expect_equal(scale_x_date(minor_breaks = NULL, limits = lims)$get_breaks_minor(), NULL) - expect_error(scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor()) + expect_snapshot( + scale_x_date(breaks = NA, limits = lims)$get_breaks(), + error = TRUE + ) + expect_null(scale_x_date(labels = NULL, limits = lims)$get_labels()) + expect_snapshot( + 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_snapshot( + scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor(), + error = TRUE + ) # date, datetime lims <- as.POSIXct(c("2000/1/1 0:0:0", "2010/1/1 0:0:0")) - expect_equal(scale_x_datetime(breaks = NULL, limits = lims)$get_breaks(), NULL) - expect_error(scale_x_datetime(breaks = NA, limits = lims)$get_breaks()) - expect_equal(scale_x_datetime(labels = NULL, limits = lims)$get_labels(), NULL) - expect_error(scale_x_datetime(labels = NA, limits = lims)$get_labels()) - expect_equal(scale_x_datetime(minor_breaks = NULL, limits = lims)$get_breaks_minor(), NULL) - expect_error(scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor()) + expect_null(scale_x_datetime(breaks = NULL, limits = lims)$get_breaks()) + expect_snapshot( + scale_x_datetime(breaks = NA, limits = lims)$get_breaks(), + error = TRUE + ) + expect_null(scale_x_datetime(labels = NULL, limits = lims)$get_labels()) + expect_snapshot( + 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_snapshot( + scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor(), + error = TRUE + ) }) test_that("scale_breaks with explicit NA options (deprecated)", { @@ -174,34 +190,34 @@ test_that("scale_breaks with explicit NA options (deprecated)", { # X sxc <- scale_x_continuous(breaks = NA) sxc$train(1:3) - expect_error(sxc$get_breaks()) - expect_error(sxc$get_breaks_minor()) + expect_snapshot(sxc$get_breaks(), error = TRUE) + expect_snapshot(sxc$get_breaks_minor(), error = TRUE) # Y syc <- scale_y_continuous(breaks = NA) syc$train(1:3) - expect_error(syc$get_breaks()) - expect_error(syc$get_breaks_minor()) + expect_snapshot(syc$get_breaks(), error = TRUE) + expect_snapshot(syc$get_breaks_minor(), error = TRUE) # Alpha sac <- scale_alpha_continuous(breaks = NA) sac$train(1:3) - expect_error(sac$get_breaks()) + expect_snapshot(sac$get_breaks(), error = TRUE) # Size ssc <- scale_size_continuous(breaks = NA) ssc$train(1:3) - expect_error(ssc$get_breaks()) + expect_snapshot(ssc$get_breaks(), error = TRUE) # Fill sfc <- scale_fill_continuous(breaks = NA) sfc$train(1:3) - expect_error(sfc$get_breaks()) + expect_snapshot(sfc$get_breaks(), error = TRUE) # Colour scc <- scale_colour_continuous(breaks = NA) scc$train(1:3) - expect_error(scc$get_breaks()) + expect_snapshot(scc$get_breaks(), error = TRUE) }) test_that("breaks can be specified by names of labels", { @@ -246,7 +262,10 @@ test_that("continuous limits accepts functions", { p <- ggplot(mpg, aes(class, hwy)) + scale_y_continuous(limits = function(lims) (c(lims[1] - 10, lims[2] + 100))) - expect_equal(layer_scales(p)$y$get_limits(), c(range(mpg$hwy)[1] - 10, range(mpg$hwy)[2] + 100)) + expect_equal( + get_panel_scales(p)$y$get_limits(), + c(range(mpg$hwy)[1] - 10, range(mpg$hwy)[2] + 100) + ) }) test_that("equal length breaks and labels can be passed to ViewScales with limits", { @@ -270,6 +289,17 @@ test_that("equal length breaks and labels can be passed to ViewScales with limit 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")) + + sc <- scale_x_discrete(breaks = c(foo = "A", bar = "B", qux = "C")) + sc$train(c(LETTERS[1:3])) + expect_equal(sc$get_labels(), c("foo", "bar", "qux")) +}) + # Visual tests ------------------------------------------------------------ test_that("minor breaks draw correctly", { diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 691f0920aa..5f14a7189c 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -2,10 +2,10 @@ test_that("building a plot does not affect its scales", { dat <- data_frame(x = rnorm(20), y = rnorm(20)) p <- ggplot(dat, aes(x, y)) + geom_point() - expect_equal(length(p$scales$scales), 0) + expect_length(p$scales$scales, 0) ggplot_build(p) - expect_equal(length(p$scales$scales), 0) + expect_length(p$scales$scales, 0) }) test_that("ranges update only for variables listed in aesthetics", { @@ -52,7 +52,7 @@ test_that("identity scale preserves input values", { scale_shape_identity() + scale_size_identity() + scale_alpha_identity() - d1 <- layer_data(p1) + d1 <- get_layer_data(p1) expect_equal(d1$colour, as.character(df$z)) expect_equal(d1$fill, as.character(df$z)) @@ -66,7 +66,7 @@ test_that("identity scale preserves input values", { geom_point() + scale_discrete_identity(aesthetics = c("colour", "fill", "shape")) + scale_continuous_identity(aesthetics = c("size", "alpha")) - d2 <- layer_data(p2) + d2 <- get_layer_data(p2) expect_equal(d1, d2) }) @@ -115,10 +115,12 @@ test_that("oob affects position values", { mid_censor <- cdata(base + y_scale(c(3, 7), censor)) handle <- GeomBar$handle_na - expect_warning(low_censor[[1]] <- handle(low_censor[[1]], list(na.rm = FALSE)), - "Removed 1 row containing missing values or values outside the scale range") - expect_warning(mid_censor[[1]] <- handle(mid_censor[[1]], list(na.rm = FALSE)), - "Removed 3 rows containing missing values or values outside the scale range") + expect_snapshot_warning( + low_censor[[1]] <- handle(low_censor[[1]], list(na.rm = FALSE)), + ) + expect_snapshot_warning( + mid_censor[[1]] <- handle(mid_censor[[1]], list(na.rm = FALSE)), + ) low_squish <- cdata(base + y_scale(c(0, 5), squish)) mid_squish <- cdata(base + y_scale(c(3, 7), squish)) @@ -201,7 +203,7 @@ test_that("scales warn when transforms introduces non-finite values", { geom_point(size = 5) + scale_y_log10() - expect_warning(ggplot_build(p), "log-10 transformation introduced infinite values.") + expect_snapshot_warning(ggplot_build(p)) }) test_that("size and alpha scales throw appropriate warnings for factors", { @@ -214,21 +216,18 @@ test_that("size and alpha scales throw appropriate warnings for factors", { p <- ggplot(df, aes(x, y)) # There should be warnings when unordered factors are mapped to size/alpha - expect_warning( - ggplot_build(p + geom_point(aes(size = d))), - "Using size for a discrete variable is not advised." + expect_snapshot_warning( + ggplot_build(p + geom_point(aes(size = d))) ) - expect_warning( - ggplot_build(p + geom_point(aes(alpha = d))), - "Using alpha for a discrete variable is not advised." + expect_snapshot_warning( + ggplot_build(p + geom_point(aes(alpha = d))) ) - expect_warning( - ggplot_build(p + geom_line(aes(linewidth = d, group = 1))), - "Using linewidth for a discrete variable is not advised." + expect_snapshot_warning( + ggplot_build(p + geom_line(aes(linewidth = d, group = 1))) ) # There should be no warnings for ordered factors - expect_warning(ggplot_build(p + geom_point(aes(size = o))), NA) - expect_warning(ggplot_build(p + geom_point(aes(alpha = o))), NA) + expect_no_warning(ggplot_build(p + geom_point(aes(size = o)))) + expect_no_warning(ggplot_build(p + geom_point(aes(alpha = o)))) }) test_that("shape scale throws appropriate warnings for factors", { @@ -241,12 +240,11 @@ test_that("shape scale throws appropriate warnings for factors", { p <- ggplot(df, aes(x, y)) # There should be no warnings when unordered factors are mapped to shape - expect_warning(ggplot_build(p + geom_point(aes(shape = d))), NA) + expect_no_warning(ggplot_build(p + geom_point(aes(shape = d)))) # There should be warnings for ordered factors - expect_warning( - ggplot_build(p + geom_point(aes(shape = o))), - "Using shapes for an ordinal variable is not advised" + expect_snapshot_warning( + ggplot_build(p + geom_point(aes(shape = o))) ) }) @@ -258,7 +256,7 @@ test_that("aesthetics can be set independently of scale name", { p <- ggplot(df, aes(x, y, fill = y)) + scale_colour_manual(values = c("red", "green", "blue"), aesthetics = "fill") - expect_equal(layer_data(p)$fill, c("red", "green", "blue")) + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) }) test_that("multiple aesthetics can be set with one function call", { @@ -272,8 +270,8 @@ test_that("multiple aesthetics can be set with one function call", { aesthetics = c("colour", "fill") ) - expect_equal(layer_data(p)$colour, c("grey20", "grey40", "grey60")) - expect_equal(layer_data(p)$fill, c("red", "green", "blue")) + expect_equal(get_layer_data(p)$colour, c("grey20", "grey40", "grey60")) + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) # color order is determined by data order, and breaks are combined where possible df <- data_frame( @@ -286,8 +284,8 @@ test_that("multiple aesthetics can be set with one function call", { aesthetics = c("fill", "colour") ) - expect_equal(layer_data(p)$colour, c("cyan", "red", "green")) - expect_equal(layer_data(p)$fill, c("red", "green", "blue")) + expect_equal(get_layer_data(p)$colour, c("cyan", "red", "green")) + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) }) test_that("limits with NA are replaced with the min/max of the data for continuous scales", { @@ -459,7 +457,7 @@ test_that("staged aesthetics are backtransformed properly (#4155)", { scale_x_sqrt(limits = c(0, 16), breaks = c(2, 4, 8)) # x / 2 should be 16 / 2 = 8, thus the result should be sqrt(8) on scale_x_sqrt() - expect_equal(layer_data(p)$x, sqrt(8)) + expect_equal(get_layer_data(p)$x, sqrt(8)) }) test_that("numeric scale transforms can produce breaks", { @@ -471,59 +469,24 @@ test_that("numeric scale transforms can produce breaks", { scale$get_transformation()$inverse(view$get_breaks()) } - expect_equal(test_breaks("asn", limits = c(0, 1)), - seq(0, 1, by = 0.25)) - - expect_equal(test_breaks("sqrt", limits = c(0, 10)), - seq(0, 10, by = 2.5)) - - expect_equal(test_breaks("atanh", limits = c(-0.9, 0.9)), - c(NA, -0.5, 0, 0.5, NA)) - - expect_equal(test_breaks(transform_boxcox(0), limits = c(1, 10)), - c(NA, 2.5, 5.0, 7.5, 10)) - - expect_equal(test_breaks(transform_modulus(0), c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks(transform_yj(0), c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("exp", c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("identity", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - # irrational numbers, so snapshot values + expect_snapshot(test_breaks("asn", limits = c(0, 1))) + expect_snapshot(test_breaks("sqrt", limits = c(0, 10))) + expect_snapshot(test_breaks("atanh", limits = c(-0.9, 0.9))) + expect_snapshot(test_breaks(transform_boxcox(0), limits = c(1, 10))) + expect_snapshot(test_breaks(transform_modulus(0), c(-10, 10))) + expect_snapshot(test_breaks(transform_yj(0), c(-10, 10))) + expect_snapshot(test_breaks("exp", c(-10, 10))) + expect_snapshot(test_breaks("identity", limits = c(-10, 10))) expect_snapshot(test_breaks("log", limits = c(0.1, 1000))) - - expect_equal(test_breaks("log10", limits = c(0.1, 1000)), - 10 ^ seq(-1, 3)) - - expect_equal(test_breaks("log2", limits = c(0.5, 32)), - c(0.5, 2, 8, 32)) - - expect_equal(test_breaks("log1p", limits = c(0, 10)), - seq(0, 10, by = 2.5)) - - expect_equal(test_breaks("pseudo_log", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("logit", limits = c(0.001, 0.999)), - c(NA, 0.25, 0.5, 0.75, NA)) - - expect_equal(test_breaks("probit", limits = c(0.001, 0.999)), - c(NA, 0.25, 0.5, 0.75, NA)) - - expect_equal(test_breaks("reciprocal", limits = c(1, 10)), - c(NA, 2.5, 5, 7.5, 10)) - - expect_equal(test_breaks("reverse", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("sqrt", limits = c(0, 10)), - seq(0, 10, by = 2.5)) + expect_snapshot(test_breaks("log10", limits = c(0.1, 1000))) + expect_snapshot(test_breaks("log2", limits = c(0.5, 32))) + expect_snapshot(test_breaks("log1p", limits = c(0, 10))) + expect_snapshot(test_breaks("pseudo_log", limits = c(-10, 10))) + expect_snapshot(test_breaks("logit", limits = c(0.001, 0.999))) + expect_snapshot(test_breaks("probit", limits = c(0.001, 0.999))) + expect_snapshot(test_breaks("reciprocal", limits = c(1, 10))) + expect_snapshot(test_breaks("reverse", limits = c(-10, 10))) + expect_snapshot(test_breaks("sqrt", limits = c(0, 10))) }) test_that("scale functions accurately report their calls", { @@ -730,3 +693,112 @@ test_that("Discrete scales with only NAs return `na.value`", { sc$train(x) expect_equal(sc$map(x), c(NA_real_, NA_real_)) }) + +test_that("continuous scales warn about faulty `limits`", { + expect_snapshot(scale_x_continuous(limits = c("A", "B")), error = TRUE) + expect_snapshot(scale_x_continuous(limits = 1:3), error = TRUE) +}) + +test_that("populating palettes works", { + + scl <- scales_list() + scl$add(scale_colour_discrete(aesthetics = c("colour", "fill"))) + + my_theme <- theme( + palette.colour.discrete = c("white", "black"), + palette.fill.discrete = c("red", "blue") + ) + + scl$set_palettes(my_theme) + expect_equal(scl$scales[[1]]$palette(2), c("white", "black")) + + # Scales with >1 aesthetic + scl <- scales_list() + scl$add(scale_colour_discrete(aesthetics = c("colour", "fill"))) + + my_theme$palette.colour.discrete <- NULL + + 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", { + # Prevents intermediate caching of palettes + map <- function(x, limits) { + sc <- scale_colour_manual( + values = c("red", "green", "blue"), + na.value = "gray" + ) + sc$map(x, limits) + } + + # All inputs should yield output regardless of where NA is + input <- c("A", "B", "C", NA) + output <- c("red", "green", "blue", "gray") + + test <- map(input, limits = c("A", "B", "C", NA)) + expect_equal(test, output) + + test <- map(input, limits = c("A", NA, "B", "C")) + expect_equal(test, output) + + 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) + + scale_x_discrete(labels = c("four-wheel", "forward", "reverse")) + + b1 <- ggplot_build(p1)$layout$panel_params[[1]] + + # We build a second plot with the first plot's scales + p2 <- ggplot(mpg, aes(drv, cyl)) + + geom_violin() + + annotate("point", x = 15, y = 100) + + b1$x$make_fixed_copy() + + b1$y$make_fixed_copy() + b2 <- ggplot_build(p2) + + # Breaks and labels should respect p1's limits + x <- get_guide_data(b2, "x") + expect_equal(x$x, 0.6:2.6 / diff(b1$x.range)) + expect_equal(x$.label, c("four-wheel", "forward", "reverse")) + + y <- get_guide_data(b2, "y") + expect_equal(y$y, rescale(seq(2.5, 10, by = 2.5), from = b1$y.range)) +}) + +test_that("discrete scales can map to 2D structures", { + + p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + + geom_point() + + # Test it can map to a vctrs rcrd class + rcrd <- new_rcrd(list(a = LETTERS[1:3], b = 3:1)) + + ld <- layer_data(p + scale_colour_manual(values = rcrd, na.value = NA)) + expect_s3_class(ld$colour, "vctrs_rcrd") + expect_length(ld$colour, nrow(mtcars)) + + # Test it can map to data.frames + df <- data_frame0(a = LETTERS[1:3], b = 3:1) + my_pal <- function(n) vec_slice(df, seq_len(n)) + + ld <- layer_data(p + discrete_scale("colour", palette = my_pal)) + expect_s3_class(ld$colour, "data.frame") + expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df))) + + # Test it can map to matrices + mtx <- cbind(a = LETTERS[1:3], b = LETTERS[4:6]) + my_pal <- function(n) vec_slice(mtx, seq_len(n)) + + ld <- layer_data(p + discrete_scale("colour", palette = my_pal)) + expect_true(is.matrix(ld$colour)) + expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df))) +}) diff --git a/tests/testthat/test-sec-axis.R b/tests/testthat/test-sec-axis.R index bcef0ae7aa..7530c4a70c 100644 --- a/tests/testthat/test-sec-axis.R +++ b/tests/testthat/test-sec-axis.R @@ -25,7 +25,7 @@ test_that("dup_axis() works", { name = "Unit A", sec.axis = dup_axis() ) - scale <- layer_scales(p)$x + scale <- get_panel_scales(p)$x expect_equal(scale$sec_name(), scale$name) breaks <- scale$break_info() expect_equal(breaks$minor_source, breaks$sec.minor_source_user) @@ -45,7 +45,7 @@ test_that("sec_axis() works with subtraction", { scale_y_continuous( sec.axis = sec_axis(~1-.) ) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y expect_equal(scale$sec_name(), scale$name) breaks <- scale$break_info() expect_equal(breaks$minor_source, breaks$sec.minor_source_user) @@ -81,7 +81,7 @@ test_that("sec_axis() breaks work for log-transformed scales", { geom_point() + scale_y_log10(sec.axis = dup_axis()) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y breaks <- scale$break_info() # test value @@ -96,7 +96,7 @@ test_that("sec_axis() breaks work for log-transformed scales", { geom_point() + scale_y_log10(sec.axis = sec_axis(~ . * 100)) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y breaks <- scale$break_info() # test value @@ -113,7 +113,7 @@ test_that("sec_axis() breaks work for log-transformed scales", { geom_point() + scale_y_log10(breaks = custom_breaks, sec.axis = sec_axis(~ . * 100)) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y breaks <- scale$break_info() expect_equal(breaks$major_source, log(custom_breaks, base = 10)) @@ -131,7 +131,7 @@ test_that("custom breaks work", { breaks = custom_breaks ) ) - scale <- layer_scales(p)$x + scale <- get_panel_scales(p)$x breaks <- scale$break_info() expect_equal(custom_breaks, breaks$sec.major_source_user) }) @@ -171,11 +171,11 @@ test_that("sec axis works with tidy eval", { g } - t <- tibble(x = letters, y = seq(10, 260, 10), z = 1:26) + t <- data_frame0(x = letters, y = seq(10, 260, 10), z = 1:26) p <- f(t, x, y, z) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y breaks <- scale$break_info() # test transform @@ -194,7 +194,7 @@ test_that("sec_axis() handles secondary power transformations", { geom_point() + scale_y_continuous(sec.axis = sec_axis(transform = (~ 2^.))) - scale <- layer_scales(p)$y + 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)) @@ -242,7 +242,7 @@ test_that("sec_axis() respects custom transformations", { expect_doppelganger( "sec_axis, custom transform", ggplot(dat, aes(x = x, y = y)) + - geom_line(linewidth = 1, na.rm = T) + + 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 = @@ -274,7 +274,7 @@ test_that("sec_axis works with date/time/datetime scales", { dt <- ggplot(df, aes(dx, price)) + geom_line() + scale_x_datetime(sec.axis = dup_axis()) - scale <- layer_scales(dt)$x + scale <- get_panel_scales(dt)$x breaks <- scale$break_info() expect_equal(breaks$major_source, breaks$sec.major_source_user) @@ -282,7 +282,7 @@ test_that("sec_axis works with date/time/datetime scales", { dt <- ggplot(df, aes(date, price)) + geom_line() + scale_x_date(sec.axis = dup_axis()) - scale <- layer_scales(dt)$x + scale <- get_panel_scales(dt)$x breaks <- scale$break_info() expect_equal(breaks$major_source, breaks$sec.major_source_user) @@ -295,7 +295,7 @@ test_that("sec_axis works with date/time/datetime scales", { name = "UTC+12" ) ) - scale <- layer_scales(dt)$x + scale <- get_panel_scales(dt)$x breaks <- scale$break_info() expect_equal( @@ -362,21 +362,60 @@ test_that("sec_axis() works for power transformations (monotonicity test doesn't p <- ggplot(data = testdat, aes(x = x, y = y)) + geom_point() + scale_y_continuous(sec.axis = sec_axis(transform = ~ .^0.5)) - scale <- layer_scales(p)$y + scale <- get_panel_scales(p)$y breaks <- scale$break_info() - expect_equal(breaks$major, sqrt(breaks$sec.major), tolerance = .005) + expect_equal(breaks$major, sqrt(breaks$sec.major), tolerance = 0.005) p <- ggplot(foo, aes(x, y)) + geom_point() + scale_x_sqrt(sec.axis = dup_axis()) - scale <- layer_scales(p)$x + scale <- get_panel_scales(p)$x breaks <- scale$break_info() - expect_equal(breaks$major, breaks$sec.major, tolerance = .001) + expect_equal(breaks$major, breaks$sec.major, tolerance = 0.001) p <- ggplot(foo, aes(x, y)) + geom_point() + scale_x_sqrt(sec.axis = sec_axis(~ . * 100)) - scale <- layer_scales(p)$x + scale <- get_panel_scales(p)$x breaks <- scale$break_info() - expect_equal(breaks$major, breaks$sec.major, tolerance = .001) + expect_equal(breaks$major, breaks$sec.major, tolerance = 0.001) +}) + +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") + )) + b <- ggplot_build(p) + + x <- get_guide_data(b, "x.sec") + expect_equal(x$.value, 1:3, ignore_attr = TRUE) + expect_equal(x$.label, c("foo", "bar", "baz")) + + y <- get_guide_data(b, "y.sec") + expect_equal(y$.value, c(1.5, 2.5), ignore_attr = TRUE) + expect_equal(y$.label, c("grault", "garply")) +}) + +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) + ) + ) + + # We get scale breaks via guide data + prim <- get_guide_data(b, "y") + 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))) }) diff --git a/tests/testthat/test-stat-align.R b/tests/testthat/test-stat-align.R index 411e29b2b8..457992e747 100644 --- a/tests/testthat/test-stat-align.R +++ b/tests/testthat/test-stat-align.R @@ -1,44 +1,29 @@ test_that("standard alignment works", { - df <- tibble::tribble( - ~g, ~x, ~y, - "a", 1, 2, - "a", 3, 5, - "a", 5, 1, - "b", 2, 3, - "b", 4, 6, - "b", 6, 7 + df <- data_frame0( + g = rep(c("a", "b"), each = 3L), + x = c(1, 3, 5, 2, 4, 6), + y = c(2, 5, 1, 3, 6, 7) ) p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") expect_doppelganger("align two areas", p) }) test_that("alignment with cliffs works", { - df <- tibble::tribble( - ~g, ~x, ~y, - "a", 1, 2, - "a", 3, 5, - "a", 5, 1, - "b", 2, 3, - "b", 4, 3, - "b", 4, 6, - "b", 6, 7 + df <- data_frame0( + g = rep(c("a", "b"), 3:4), + x = c(1, 3, 5, 2, 4, 4, 6), + y = c(2, 5, 1, 3, 3, 6, 7) ) - p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") expect_doppelganger("align two areas with cliff", p) }) test_that("alignment with negative and positive values works", { - df <- tibble::tribble( - ~g, ~x, ~y, - "a", 1, 1, - "a", 2, 4, - "a", 3, -4, - "a", 8, 0, - "b", 2, 4, - "b", 6, -4 + df <- data_frame0( + g = rep(c("a", "b"), c(4L, 2L)), + x = c(1, 2, 3, 8, 2, 6), + y = c(1, 4, -4, 0, 4, -4) ) - p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") expect_doppelganger("align two areas with pos/neg y", p) }) @@ -48,19 +33,20 @@ test_that("alignment adjusts per panel", { # data into account (#5227) df <- data_frame0( - x = c(0, 1, 1000, 1001), - y = c(-1, 1, -1, 1), - g = c("A", "A", "B", "B") + x = c(0, 1, 1000, 1001, 0, 1, 1000, 1001), + y = c(-1, 1, -1, 1, -1, 1, -1, 1), + f = c("A", "A", "B", "B", "A", "A", "B", "B"), + g = c("a", "a", "b", "b", "c", "c", "d", "d") ) - p <- ggplot(df, aes(x, y)) + p <- ggplot(df, aes(x, y, group = g)) # Here, x-range is large, so adjustment should be larger - ld <- layer_data(p + geom_area(aes(fill = g))) + ld <- get_layer_data(p + geom_area(aes(fill = f))) 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 <- layer_data(p + geom_area() + facet_wrap(vars(g), scales = "free_x")) + 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 6ab5ec96b2..de1c941b1e 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -10,11 +10,11 @@ test_that("stat_bin throws error when wrong combination of aesthetic is present" test_that("stat_bin works in both directions", { p <- ggplot(mpg, aes(hwy)) + stat_bin(bins = 30) - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(mpg, aes(y = hwy)) + stat_bin(bins = 30) - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -25,7 +25,7 @@ test_that("stat_bin works in both directions", { test_that("bins specifies the number of bins", { df <- data_frame(x = 1:10) out <- function(x, ...) { - layer_data(ggplot(df, aes(x)) + geom_histogram(...)) + get_layer_data(ggplot(df, aes(x)) + geom_histogram(...)) } expect_equal(nrow(out(bins = 2)), 2) @@ -34,38 +34,46 @@ test_that("bins specifies the number of bins", { test_that("binwidth computes widths for function input", { df <- data_frame(x = 1:100) - out <- 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) }) test_that("geom_histogram defaults to pad = FALSE", { df <- data_frame(x = 1:3) - out <- layer_data(ggplot(df, aes(x)) + geom_histogram(binwidth = 1)) + out <- get_layer_data(ggplot(df, aes(x)) + geom_histogram(binwidth = 1)) expect_equal(out$count, c(1, 1, 1)) }) test_that("geom_freqpoly defaults to pad = TRUE", { df <- data_frame(x = 1:3) - out <- layer_data(ggplot(df, aes(x)) + geom_freqpoly(binwidth = 1)) + out <- get_layer_data(ggplot(df, aes(x)) + geom_freqpoly(binwidth = 1)) expect_equal(out$count, c(0, 1, 1, 1, 0)) }) test_that("can use breaks argument", { df <- data_frame(x = 1:3) - out <- 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))) + + expect_equal(out$count, c(3, 2, 1)) +}) + test_that("fuzzy breaks are used when cutting", { df <- data_frame(x = c(-1, -0.5, -0.4, 0)) p <- ggplot(df, aes(x)) + geom_histogram(binwidth = 0.1, boundary = 0.1, closed = "left") - bins <- layer_data(p) %>% subset(count > 0) %>% .[1:5] + bins <- get_layer_data(p) %>% subset(count > 0) %>% .[1:5] expect_equal(bins$count, c(1, 1, 1, 1)) }) @@ -73,15 +81,15 @@ 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)) - out1 <- layer_data(base) - out2 <- layer_data(base + scale_x_sqrt()) + 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)", { df <- data_frame(x = rep(1, 100)) - out <- layer_data(ggplot(df, aes(x)) + geom_histogram(bins = 30)) + out <- get_layer_data(ggplot(df, aes(x)) + geom_histogram(bins = 30)) expect_equal(nrow(out), 1) expect_equal(out$xmin, 0.95) @@ -103,13 +111,27 @@ test_that("stat_bin() provides width (#3522)", { geom = "rect", binwidth = binwidth ) - out <- layer_data(p) + out <- get_layer_data(p) expect_equal(nrow(out), 10) # (x + width / 2) - (x - width / 2) = width expect_equal(out$xmax - out$xmin, rep(binwidth, 10)) }) +test_that("stat_bin(drop) options work as intended", { + p <- ggplot(data.frame(x = c(1, 2, 2, 3, 5, 6, 6, 7)), aes(x)) + + scale_x_continuous(limits = c(-1, 9)) + + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "none")) + expect_equal(ld$x, -1:9) + + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "extremes")) + expect_equal(ld$x, c(1:7)) + + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "all")) + expect_equal(ld$x, c(1:3, 5:7)) +}) + # Underlying binning algorithm -------------------------------------------- test_that("bins() computes fuzz with non-finite breaks", { @@ -119,20 +141,41 @@ test_that("bins() computes fuzz with non-finite breaks", { expect_equal(difference[2], 1000 * .Machine$double.eps, tolerance = 0) }) +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)) + 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)) + 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)) + expect_equal(nbreaks, nbins + 1) + +}) + comp_bin <- function(df, ...) { plot <- ggplot(df, aes(x = x)) + stat_bin(...) - layer_data(plot) + get_layer_data(plot) } test_that("inputs to binning are checked", { dat <- data_frame(x = c(0, 10)) - expect_snapshot_error(comp_bin(dat, breaks = letters)) - expect_snapshot_error(bin_breaks_width(3)) - expect_snapshot_error(comp_bin(dat, binwidth = letters)) - expect_snapshot_error(comp_bin(dat, binwidth = -4)) - - expect_snapshot_error(bin_breaks_bins(3)) - expect_snapshot_error(comp_bin(dat, bins = -4)) + expect_snapshot_error(compute_bins(dat, breaks = letters)) + expect_snapshot_error(compute_bins(dat, binwidth = letters)) + expect_snapshot_error(compute_bins(dat, binwidth = -4)) + expect_snapshot_error(compute_bins(dat, bins = -4)) }) test_that("closed left or right", { @@ -162,14 +205,14 @@ test_that("setting boundary and center", { df <- data_frame(x = c(0, 30)) # Error if both boundary and center are specified - expect_error(comp_bin(df, boundary = 5, center = 0), "one of `boundary` and `center`") + expect_snapshot_warning(comp_bin(df, boundary = 5, center = 0, bins = 30)) res <- comp_bin(df, binwidth = 10, boundary = 0, pad = FALSE) expect_identical(res$count, c(1, 0, 1)) expect_identical(res$xmin[1], 0) expect_identical(res$xmax[3], 30) - res <- comp_bin(df, binwidth = 10, center = 0, pad = FALSE) + res <- comp_bin(df, binwidth = 10, center = 0, boundary = NULL, pad = FALSE) expect_identical(res$count, c(1, 0, 0, 1)) expect_identical(res$xmin[1], df$x[1] - 5) expect_identical(res$xmax[4], df$x[2] + 5) @@ -178,13 +221,13 @@ test_that("setting boundary and center", { test_that("weights are added", { df <- data_frame(x = 1:10, y = 1:10) p <- ggplot(df, aes(x = x, weight = y)) + geom_histogram(binwidth = 1) - out <- layer_data(p) + out <- get_layer_data(p) expect_equal(out$count, df$y) }) test_that("bin errors at high bin counts", { - expect_error(bin_breaks_width(c(1, 2e6), 1), "The number of histogram bins") + expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) }) # stat_count -------------------------------------------------------------- diff --git a/tests/testthat/test-stat-bin2d.R b/tests/testthat/test-stat-bin2d.R index 5a30466bff..6d83448956 100644 --- a/tests/testthat/test-stat-bin2d.R +++ b/tests/testthat/test-stat-bin2d.R @@ -3,7 +3,7 @@ test_that("binwidth is respected", { base <- ggplot(df, aes(x, y)) + stat_bin_2d(geom = "tile", binwidth = 0.25) - out <- layer_data(base) + out <- get_layer_data(base) expect_equal(nrow(out), 2) # Adjust tolerance to account for fuzzy breaks adjustment expect_equal(out$xmin, c(1, 1.75), tolerance = 1e-7) @@ -14,7 +14,7 @@ test_that("binwidth is respected", { expect_snapshot_warning(ggplot_build(p)) p <- ggplot(df, aes(x, y)) + - stat_bin_2d(geom = "tile", origin = c(0.25, 0.5, 0.75)) + stat_bin_2d(geom = "tile", boundary = c(0.25, 0.5, 0.75)) expect_snapshot_warning(ggplot_build(p)) }) @@ -31,9 +31,9 @@ test_that("breaks override binwidth", { binwidth = c(0.5, 0.5) ) - out <- layer_data(base) - expect_equal(out$xbin, cut(df$x, adjust_breaks(integer_breaks), include.lowest = TRUE, labels = FALSE)) - expect_equal(out$ybin, cut(df$y, adjust_breaks(half_breaks), include.lowest = TRUE, labels = FALSE)) + 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)) }) test_that("breaks are transformed by the scale", { @@ -42,8 +42,8 @@ test_that("breaks are transformed by the scale", { stat_bin_2d( breaks = list(x = c(5, 50, 500), y = c(0.5, 1.5, 2.5))) - out1 <- layer_data(base) - out2 <- layer_data(base + scale_x_log10()) + out1 <- get_layer_data(base) + out2 <- get_layer_data(base + scale_x_log10()) expect_equal(out1$x, c(27.5, 275)) expect_equal(out2$x, c(1.19897, 2.19897)) }) diff --git a/tests/testthat/test-stat-connect.R b/tests/testthat/test-stat-connect.R new file mode 100644 index 0000000000..16c3ed44fd --- /dev/null +++ b/tests/testthat/test-stat-connect.R @@ -0,0 +1,85 @@ +test_that("stat_connect closes off ends", { + + data <- data.frame(x = 1:3, y = c(1, 2, 0)) + + ld <- get_layer_data( + ggplot(data, aes(x, y)) + + stat_connect(connection = "mid") + ) + + i <- c(1L, nrow(ld)) + 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", { + data <- data.frame(x = 1:3, y = c(1, 2, 0)) + + ld <- get_layer_data( + ggplot(data, aes(x, y)) + + stat_connect(connection = cbind(0.5, 0.5)) + ) + + expect_equal(ld$x, c(1, 1.5, 2.5, 3)) + expect_equal(ld$y, c(1, 1.5, 1.0, 0)) +}) + +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), + ymin = c(1, 1, 2, 2, 0, 0, 1), + ymax = c(3, 3, 4, 4, 3, 3, 4) + ) + + ld <- layer_data( + ggplot(data, aes(x, ymin = ymin, ymax = ymax)) + + geom_ribbon(stat = "connect", connection = "hv") + ) + + expect_equal(ld[c("x", "ymin", "ymax")], expected) + + ld <- layer_data( + ggplot(data, aes(y = x, xmin = ymin, xmax = ymax)) + + geom_ribbon(stat = "connect", connection = "hv", orientation = "y") + ) + + expect_equal(ld[c("y", "xmin", "xmax")], flip_data(expected, TRUE)) +}) + +test_that("stat_connect rejects invalid connections", { + + test_setup <- function(...) { + StatConnect$setup_params(NULL, list(...)) + } + + # Accept keyword parameter + p <- test_setup(connection = "linear") + expect_vector(p$connection, size = 2L, ptype = matrix(NA_real_, 0, 2)) + + # Accept xy coord matrix + 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) + + expect_snapshot( + test_setup(connection = "foobar"), + error = TRUE + ) + + expect_snapshot( + test_setup(connection = matrix(1:3, ncol = 1)), + error = TRUE + ) + + expect_snapshot( + test_setup(connection = matrix(c(1:3, NA), ncol = 2)), + error = TRUE + ) +}) diff --git a/tests/testthat/test-stat-contour.R b/tests/testthat/test-stat-contour.R index 0711fae3fc..df9a27132c 100644 --- a/tests/testthat/test-stat-contour.R +++ b/tests/testthat/test-stat-contour.R @@ -3,7 +3,7 @@ test_that("a warning is issued when there is more than one z per x+y", { p <- ggplot(tbl, aes(x, y, z = z)) + geom_contour() # Ignore other warnings than the one stat_contour() issued suppressWarnings( - expect_warning(ggplot_build(p), "Zero contours were generated") + expect_snapshot_warning(ggplot_build(p)) ) }) @@ -14,7 +14,7 @@ test_that("contouring sparse data results in a warning", { # TODO: These multiple warnings should be summarized nicely. Until this gets # fixed, this test ignores all the following errors than the first one. suppressWarnings( - expect_warning(ggplot_build(p), "Zero contours were generated") + expect_snapshot_warning(ggplot_build(p)) ) }) @@ -26,7 +26,7 @@ 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 <- layer_data(p) + d <- get_layer_data(p) d4 <- d[d$level == 4,] expect_equal(nrow(d4), 7) expect_setequal(d4$x, c(4, 10, 100, 700)) @@ -53,14 +53,14 @@ test_that("geom_contour_filled() and stat_contour_filled() result in identical l p <- ggplot(faithfuld, aes(waiting, eruptions, z = density)) p1 <- p + stat_contour_filled() p2 <- p + geom_contour_filled() - expect_identical(layer_data(p1), layer_data(p2)) + expect_identical(get_layer_data(p1), get_layer_data(p2)) }) test_that("geom_contour() and stat_contour() result in identical layer data", { p <- ggplot(faithfuld, aes(waiting, eruptions, z = density)) p1 <- p + stat_contour() p2 <- p + geom_contour() - expect_identical(layer_data(p1), layer_data(p2)) + expect_identical(get_layer_data(p1), get_layer_data(p2)) }) test_that("basic stat_contour() plot builds", { @@ -93,10 +93,32 @@ test_that("stat_contour() removes duplicated coordinates", { layer <- stat_contour() expect_silent(layer$stat$setup_data(df)) - expect_warning( - new <- layer$stat$setup_data(transform(df, group = 1)), - "has duplicated" + expect_snapshot_warning( + new <- layer$stat$setup_data(transform(df, group = 1)) ) expect_equal(new, df[1:4,], ignore_attr = TRUE) }) +test_that("stat_contour() can infer rotations", { + df <- data_frame0( + x = c(0, 1, 2, 1), + y = c(1, 2, 1, 0), + z = c(1, 1, 2, 2) + ) + + ld <- layer_data( + ggplot(df, aes(x, y, z = z)) + geom_contour(breaks = 1.5) + ) + expect_equal(ld$x, c(1.5, 0.5)) + expect_equal(ld$y, c(1.5, 0.5)) + + # Also for unordered data + df <- df[c(1, 4, 2, 3), ] + + ld <- layer_data( + ggplot(df, aes(x, y, z = z)) + geom_contour(breaks = 1.5) + ) + + expect_equal(ld$x, c(0.5, 1.5)) + expect_equal(ld$y, c(0.5, 1.5)) +}) diff --git a/tests/testthat/test-stat-count.R b/tests/testthat/test-stat-count.R index 7483becf94..b014fc672e 100644 --- a/tests/testthat/test-stat-count.R +++ b/tests/testthat/test-stat-count.R @@ -10,7 +10,7 @@ test_that("stat_count() respects uniqueness of `x`", { # if they are retained 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 <- layer_data(p) + data <- get_layer_data(p) expect_length(vec_unique(df$x), 4) expect_equal(data$y, rep(1, 4)) diff --git a/tests/testthat/test-stat-density.R b/tests/testthat/test-stat-density.R index 677dfe5100..62104feb7a 100644 --- a/tests/testthat/test-stat-density.R +++ b/tests/testthat/test-stat-density.R @@ -5,7 +5,7 @@ test_that("stat_density actually computes density", { expected_density_fun <- stats::approxfun(data.frame(x = dens$x, y = dens$y)) plot <- ggplot(mtcars, aes(mpg)) + stat_density() - actual_density_fun <- stats::approxfun(layer_data(plot)[, c("x", "y")]) + actual_density_fun <- stats::approxfun(get_layer_data(plot)[, c("x", "y")]) test_sample <- unique(mtcars$mpg) expect_equal( @@ -17,13 +17,16 @@ test_that("stat_density actually computes density", { test_that("stat_density can make weighted density estimation", { df <- mtcars - df$weight <- mtcars$cyl / sum(mtcars$cyl) + df$weight <- mtcars$cyl - dens <- stats::density(df$mpg, weights = df$weight, bw = bw.nrd0(df$mpg)) + dens <- stats::density( + df$mpg, weights = df$weight / sum(df$weight), + bw = bw.nrd0(df$mpg) + ) expected_density_fun <- stats::approxfun(data.frame(x = dens$x, y = dens$y)) - plot <- ggplot(df, aes(mpg, weight = weight)) + stat_density() - actual_density_fun <- stats::approxfun(layer_data(plot)[, c("x", "y")]) + plot <- get_layer_data(ggplot(df, aes(mpg, weight = weight)) + stat_density()) + actual_density_fun <- stats::approxfun(plot[, c("x", "y")]) test_sample <- unique(df$mpg) expect_equal( @@ -31,6 +34,11 @@ test_that("stat_density can make weighted density estimation", { actual_density_fun(test_sample), tolerance = 1e-3 ) + + expect_equal( + plot$wdensity, + plot$density * sum(mtcars$cyl) + ) }) test_that("stat_density uses `bounds`", { @@ -46,7 +54,7 @@ test_that("stat_density uses `bounds`", { ) bounded_plot <- ggplot(mtcars, aes(mpg)) + stat_density(bounds = bounds) - bounded_data <- layer_data(bounded_plot)[, c("x", "y")] + bounded_data <- get_layer_data(bounded_plot)[, c("x", "y")] plot_density <- stats::approxfun(bounded_data, yleft = 0, yright = 0) test_sample <- seq(mpg_min, mpg_max, by = 0.1) @@ -58,7 +66,7 @@ test_that("stat_density uses `bounds`", { expect_equal( orig_density(test_sample) + left_reflection + right_reflection, plot_density(test_sample), - tolerance = 1e-4 + tolerance = 1e-3 ) } @@ -72,21 +80,20 @@ test_that("stat_density handles data outside of `bounds`", { cutoff <- mtcars$mpg[1] # Both `x` and `weight` should be filtered out for out of `bounds` points - expect_warning( - data_actual <- layer_data( + expect_snapshot_warning( + data_actual <- get_layer_data( ggplot(mtcars, aes(mpg, weight = cyl)) + stat_density(bounds = c(cutoff, Inf)) - ), - "outside of `bounds`" + ) ) mtcars_filtered <- mtcars[mtcars$mpg >= cutoff, ] - data_expected <- layer_data( + data_expected <- get_layer_data( ggplot(mtcars_filtered, aes(mpg, weight = cyl)) + stat_density(bounds = c(cutoff, Inf)) ) - expect_equal(data_actual, data_expected) + expect_equal(data_actual, data_expected, tolerance = 1e-4) }) test_that("compute_density succeeds when variance is zero", { @@ -96,11 +103,11 @@ test_that("compute_density succeeds when variance is zero", { test_that("stat_density works in both directions", { p <- ggplot(mpg, aes(hwy)) + stat_density() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(mpg, aes(y = hwy)) + stat_density() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -112,10 +119,10 @@ test_that("stat_density works in both directions", { }) test_that("compute_density returns useful df and throws warning when <2 values", { - expect_warning(dens <- compute_density(1, NULL, from = 0, to = 0)) + expect_snapshot_warning(dens <- compute_density(1, NULL, from = 0, to = 0)) expect_equal(nrow(dens), 1) - expect_equal(names(dens), c("x", "density", "scaled", "ndensity", "count", "n")) + expect_named(dens, c("x", "density", "scaled", "ndensity", "count", "wdensity", "n")) expect_type(dens$x, "double") }) diff --git a/tests/testthat/test-stat-density2d.R b/tests/testthat/test-stat-density2d.R index 59445805c2..43a99e9513 100644 --- a/tests/testthat/test-stat-density2d.R +++ b/tests/testthat/test-stat-density2d.R @@ -1,10 +1,12 @@ +skip_if_not_installed("MASS") + test_that("uses scale limits, not data limits", { base <- ggplot(mtcars, aes(wt, mpg)) + stat_density_2d() + scale_x_continuous(limits = c(1, 6)) + scale_y_continuous(limits = c(5, 40)) - ret <- layer_data(base) + ret <- get_layer_data(base) # Check that the contour data goes beyond data range. # The specific values below are sort of arbitrary; but they go beyond the range # of the data @@ -21,17 +23,17 @@ test_that("stat_density2d can produce contour and raster data", { p_contour_bands <- p + stat_density_2d_filled() p_raster <- p + stat_density_2d(contour = FALSE) - d_lines <- layer_data(p_contour_lines) + d_lines <- get_layer_data(p_contour_lines) expect_true("level" %in% names(d_lines)) expect_false("level_low" %in% names(d_lines)) expect_true(is.numeric(d_lines$level)) - d_bands <- layer_data(p_contour_bands) + d_bands <- get_layer_data(p_contour_bands) expect_true("level" %in% names(d_bands)) expect_true("level_low" %in% names(d_bands)) expect_true(is.ordered(d_bands$level)) - d_raster <- layer_data(p_raster) + d_raster <- get_layer_data(p_raster) expect_true("density" %in% names(d_raster)) expect_true("ndensity" %in% names(d_raster)) expect_true("count" %in% names(d_raster)) @@ -41,7 +43,7 @@ test_that("stat_density2d can produce contour and raster data", { # stat_density_2d() and stat_density_2d_filled() produce identical # density output with `contour = FALSE` # (`fill` and `colour` will differ due to different default aesthetic mappings) - d_raster2 <- layer_data(p + stat_density_2d_filled(contour = FALSE)) + d_raster2 <- get_layer_data(p + stat_density_2d_filled(contour = FALSE)) expect_identical(d_raster$x, d_raster2$x) expect_identical(d_raster$y, d_raster2$y) expect_identical(d_raster$density, d_raster2$density) @@ -50,7 +52,7 @@ test_that("stat_density2d can produce contour and raster data", { # stat_density_2d() with contouring is the same as stat_contour() on calculated density p_lines2 <- ggplot(d_raster, aes(x, y, z = density)) + stat_contour() - d_lines2 <- layer_data(p_lines2) + d_lines2 <- get_layer_data(p_lines2) expect_identical(d_lines$x, d_lines2$x) expect_identical(d_lines$y, d_lines2$y) expect_identical(d_lines$piece, d_lines2$piece) @@ -59,7 +61,7 @@ test_that("stat_density2d can produce contour and raster data", { # same for stat_density_2d_filled() p_bands2 <- ggplot(d_raster, aes(x, y, z = density)) + stat_contour_filled() - d_bands2 <- layer_data(p_bands2) + d_bands2 <- get_layer_data(p_bands2) expect_identical(d_bands$x, d_bands2$x) expect_identical(d_bands$y, d_bands2$y) expect_identical(d_bands$piece, d_bands2$piece) @@ -69,9 +71,9 @@ test_that("stat_density2d can produce contour and raster data", { # and for contour_var = "ndensity" p_contour_lines <- p + stat_density_2d(contour_var = "ndensity") - d_lines <- layer_data(p_contour_lines) + d_lines <- get_layer_data(p_contour_lines) p_lines2 <- ggplot(d_raster, aes(x, y, z = ndensity)) + stat_contour() - d_lines2 <- layer_data(p_lines2) + d_lines2 <- get_layer_data(p_lines2) expect_identical(d_lines$x, d_lines2$x) expect_identical(d_lines$y, d_lines2$y) expect_identical(d_lines$piece, d_lines2$piece) @@ -80,9 +82,9 @@ test_that("stat_density2d can produce contour and raster data", { # and for contour_var = "count" p_contour_bands <- p + stat_density_2d_filled(contour_var = "count") - d_bands <- layer_data(p_contour_bands) + d_bands <- get_layer_data(p_contour_bands) p_bands2 <- ggplot(d_raster, aes(x, y, z = count)) + stat_contour_filled() - d_bands2 <- layer_data(p_bands2) + d_bands2 <- get_layer_data(p_bands2) expect_identical(d_bands$x, d_bands2$x) expect_identical(d_bands$y, d_bands2$y) expect_identical(d_bands$piece, d_bands2$piece) @@ -93,3 +95,10 @@ test_that("stat_density2d can produce contour and raster data", { # error on incorrect contouring variable expect_snapshot_error(ggplot_build(p + stat_density_2d(contour_var = "abcd"))) }) + +test_that("stat_density_2d handles faulty bandwidth", { + p <- ggplot(faithful, aes(eruptions, waiting)) + + stat_density_2d(h = c(0, NA)) + expect_snapshot_warning(b <- ggplot_build(p)) + expect_s3_class(layer_grob(b)[[1]], "zeroGrob") +}) diff --git a/tests/testthat/test-stat-ecdf.R b/tests/testthat/test-stat-ecdf.R index 6fd8297e18..1ea0a69a56 100644 --- a/tests/testthat/test-stat-ecdf.R +++ b/tests/testthat/test-stat-ecdf.R @@ -1,10 +1,10 @@ test_that("stat_ecdf works in both directions", { p <- ggplot(mpg, aes(hwy)) + stat_ecdf() - x <- layer_data(p) + x <- get_layer_data(p) expect_false(x$flipped_aes[1]) p <- ggplot(mpg, aes(y = hwy)) + stat_ecdf() - y <- layer_data(p) + y <- get_layer_data(p) expect_true(y$flipped_aes[1]) x$flipped_aes <- NULL @@ -15,15 +15,54 @@ test_that("stat_ecdf works in both directions", { expect_snapshot_error(ggplot_build(p)) }) +test_that("weighted ecdf computes sensible results", { + + set.seed(42) + x <- rpois(100, 5) + ux <- sort(unique0(x)) + + # Absent weights should be the same as the original + expect_equal( + ecdf(x)(ux), + wecdf(x, NULL)(ux) + ) + + # Uniform weights should be the same as the original + expect_equal( + ecdf(x)(ux), + wecdf(x, pi)(ux) + ) + + # Tabulated weights should be the same as the original + tab <- as.data.frame(table(x), stringsAsFactors = FALSE) + tab$x <- as.numeric(tab$x) + expect_equal( + ecdf(x)(ux), + wecdf(tab$x, tab$Freq)(ux) + ) +}) + +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)))) + + # Should warn when provided with near-0 weights + expect_snapshot_warning(wecdf(1:10, .Machine$double.eps)) + + # Should error when weights sum to 0 + expect_snapshot(wecdf(1:10, rep(c(-1, 1), 5)), error = TRUE) +}) + # See #5113 and #5112 test_that("stat_ecdf responds to axis transformations", { n <- 4 answer <- c(seq(0, 1, length.out = n + 1), 1) p <- ggplot(data_frame0(x = seq_len(n)), aes(x)) + stat_ecdf() - ld <- layer_data(p) + ld <- get_layer_data(p) expect_equal(ld$y, answer) - ld <- layer_data(p + scale_y_sqrt()) + ld <- get_layer_data(p + scale_y_sqrt()) expect_equal(ld$y, sqrt(answer)) }) diff --git a/tests/testthat/test-stat-ellipsis.R b/tests/testthat/test-stat-ellipsis.R index 95a5df9ad7..7615091376 100644 --- a/tests/testthat/test-stat-ellipsis.R +++ b/tests/testthat/test-stat-ellipsis.R @@ -1,10 +1,12 @@ +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)) p <- ggplot(d, aes(x = x, y = y, group = id)) + geom_point() + stat_ellipse(segments = n_seg) - out <- layer_data(p, 2) + out <- get_layer_data(p, 2) expect_equal(nrow(out), (n_seg + 1) * 2) expect_equal(unique(out$group), c(1, 2)) }) diff --git a/tests/testthat/test-stat-function.R b/tests/testthat/test-stat-function.R index 497c18ef41..f9073086df 100644 --- a/tests/testthat/test-stat-function.R +++ b/tests/testthat/test-stat-function.R @@ -8,18 +8,18 @@ test_that("uses scale limits, not data limits", { full <- base + scale_x_continuous(limits = c(0.1, 100)) + scale_y_continuous() - ret <- layer_data(full) + ret <- get_layer_data(full) full_log <- base + scale_x_log10(limits = c(0.1, 100)) + scale_y_continuous() - ret_log <- layer_data(full_log) + ret_log <- get_layer_data(full_log) expect_equal(ret$y[c(1, 101)], ret_log$y[c(1, 101)]) expect_equal(range(ret$x), c(0.1, 100)) expect_equal(range(ret_log$x), c(-1, 2)) - expect_false(any(is.na(ret$y))) - expect_false(any(is.na(ret_log$y))) + expect_false(anyNA(ret$y)) + expect_false(anyNA(ret_log$y)) }) test_that("works in plots without any data", { @@ -27,19 +27,19 @@ test_that("works in plots without any data", { # default limits, 0 to 1 base <- ggplot() + geom_function(fun = f, n = 6) - ret <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) expect_identical(ret$y, 2*ret$x) # manually set limits with xlim() base <- ggplot() + xlim(0, 2) + geom_function(fun = f, n = 6) - ret <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 2, length.out = 6)) 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 <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 2, length.out = 6)) expect_identical(ret$y, 2*ret$x) @@ -47,7 +47,7 @@ test_that("works in plots without any data", { base <- ggplot() + geom_function(aes(color = "fun"), fun = f, n = 6) + scale_color_manual(values = c(fun = "#D55E00")) - ret <- layer_data(base) + 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$colour, rep("#D55E00", 6)) @@ -58,7 +58,7 @@ test_that("works with discrete x", { base <- ggplot(dat, aes(x, group = 1)) + stat_function(fun = as.numeric, geom = "point", n = 2) - ret <- layer_data(base) + ret <- get_layer_data(base) expect_equal(ret$x, mapped_discrete(1:2)) expect_equal(ret$y, 1:2) @@ -71,22 +71,22 @@ test_that("works with transformed scales", { base <- ggplot(dat, aes(x, group = 1)) + stat_function(fun = ~ .x^2, n = 5) - ret <- layer_data(base) + ret <- get_layer_data(base) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(1, 10, length.out = 5)) expect_equal(ret$y, ret$x^2) - ret <- layer_data(base + scale_x_log10()) + ret <- get_layer_data(base + scale_x_log10()) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(0, 1, length.out = 5)) expect_equal(ret$y, (10^ret$x)^2) - ret <- layer_data(base + scale_y_log10()) + ret <- get_layer_data(base + scale_y_log10()) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(1, 10, length.out = 5)) expect_equal(10^ret$y, ret$x^2) - ret <- layer_data(base + scale_x_log10() + scale_y_log10()) + ret <- get_layer_data(base + scale_x_log10() + scale_y_log10()) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(0, 1, length.out = 5)) expect_equal(10^ret$y, (10^ret$x)^2) @@ -95,22 +95,22 @@ test_that("works with transformed scales", { base <- ggplot(dat, aes(x, y)) + geom_point() + stat_function(fun = ~ .x^2, n = 5) - ret <- layer_data(base, 2) + ret <- get_layer_data(base, 2) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(1, 10, length.out = 5)) expect_equal(ret$y, ret$x^2) - ret <- layer_data(base + scale_x_log10(), 2) + ret <- get_layer_data(base + scale_x_log10(), 2) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(0, 1, length.out = 5)) expect_equal(ret$y, (10^ret$x)^2) - ret <- layer_data(base + scale_y_log10(), 2) + ret <- get_layer_data(base + scale_y_log10(), 2) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(1, 10, length.out = 5)) expect_equal(10^ret$y, ret$x^2) - ret <- layer_data(base + scale_x_log10() + scale_y_log10(), 2) + ret <- get_layer_data(base + scale_x_log10() + scale_y_log10(), 2) expect_equal(nrow(ret), 5) expect_equal(ret$x, seq(0, 1, length.out = 5)) expect_equal(10^ret$y, (10^ret$x)^2) @@ -123,7 +123,7 @@ test_that("works with formula syntax", { base <- ggplot(dat, aes(x, group = 1)) + stat_function(fun = ~ .x^2, geom = "point", n = 5) + scale_x_continuous(limits = c(0, 10)) - ret <- layer_data(base) + ret <- get_layer_data(base) s <- seq(0, 10, length.out = 5) expect_equal(ret$x, s) @@ -134,7 +134,7 @@ 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()} - expect_warning(f(), "Multiple drawing groups") + expect_snapshot_warning(f()) }) test_that("Line style can be changed via provided data", { @@ -143,7 +143,7 @@ test_that("Line style can be changed via provided data", { base <- ggplot(df) + geom_function(aes(color = fun), fun = identity, n = 6) + scale_color_identity() - ret <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) expect_identical(ret$y, ret$x) expect_identical(ret$colour, rep("#D55E00", 6)) @@ -153,7 +153,7 @@ test_that("Line style can be changed via provided data", { data = df, aes(color = fun), fun = identity, n = 6 ) + scale_color_identity() - ret <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) expect_identical(ret$y, ret$x) expect_identical(ret$colour, rep("#D55E00", 6)) @@ -163,7 +163,7 @@ test_that("Line style can be changed via provided data", { data = df, aes(color = fun), fun = identity, n = 6 ) + scale_color_identity() - ret <- layer_data(base) + ret <- get_layer_data(base) expect_identical(ret$x, seq(0, 1, length.out = 6)) expect_identical(ret$y, ret$x) expect_identical(ret$colour, rep("#D55E00", 6)) diff --git a/tests/testthat/test-stat-hex.R b/tests/testthat/test-stat-hex.R index 1bb2904f3d..c0355acc6b 100644 --- a/tests/testthat/test-stat-hex.R +++ b/tests/testthat/test-stat-hex.R @@ -3,5 +3,5 @@ test_that("can use length 1 binwidth", { df <- data_frame(x = c(1, 1, 2), y = c(1, 1, 2)) p <- ggplot(df, aes(x, y)) + stat_binhex(binwidth = 1) - expect_equal(nrow(layer_data(p)), 2) + expect_equal(nrow(get_layer_data(p)), 2) }) diff --git a/tests/testthat/test-stat-manual.R b/tests/testthat/test-stat-manual.R new file mode 100644 index 0000000000..5e2ca54376 --- /dev/null +++ b/tests/testthat/test-stat-manual.R @@ -0,0 +1,18 @@ +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( + ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + + stat_manual(fun = centroid, size = 5, shape = 21) + ) + + expect_equal( + layer$x, + vapply(split(mtcars$disp, mtcars$cyl), mean, numeric(1), USE.NAMES = FALSE) + ) + expect_equal( + layer$y, + vapply(split(mtcars$mpg, mtcars$cyl), mean, numeric(1), USE.NAMES = FALSE) + ) +}) diff --git a/tests/testthat/test-stat-sf-coordinates.R b/tests/testthat/test-stat-sf-coordinates.R index 80307cfa3a..c6e3a21920 100644 --- a/tests/testthat/test-stat-sf-coordinates.R +++ b/tests/testthat/test-stat-sf-coordinates.R @@ -1,6 +1,6 @@ comp_sf_coord <- function(df, ...) { plot <- ggplot(df) + stat_sf_coordinates(...) - layer_data(plot) + get_layer_data(plot) } test_that("stat_sf_coordinates() retrieves coordinates from sf objects", { diff --git a/tests/testthat/test-stat-sum.R b/tests/testthat/test-stat-sum.R index 350665d561..b4fe14b79f 100644 --- a/tests/testthat/test-stat-sum.R +++ b/tests/testthat/test-stat-sum.R @@ -4,37 +4,37 @@ test_that("handles grouping correctly", { base <- ggplot(d, aes(cut, clarity)) - ret <- layer_data(base + stat_sum()) + ret <- get_layer_data(base + stat_sum()) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_true(all_ones(ret$prop)) - ret <- layer_data(base + stat_sum(aes(group = 1))) + ret <- get_layer_data(base + stat_sum(aes(group = 1))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_equal(sum(ret$prop), 1) - ret <- layer_data(base + stat_sum(aes(group = cut))) + ret <- get_layer_data(base + stat_sum(aes(group = cut))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_true(all_ones(tapply(ret$prop, ret$x, FUN = sum))) - ret <- layer_data(base + stat_sum(aes(group = cut, colour = cut))) + ret <- get_layer_data(base + stat_sum(aes(group = cut, colour = cut))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_true(all_ones(tapply(ret$prop, ret$x, FUN = sum))) - ret <- layer_data(base + stat_sum(aes(group = clarity))) + ret <- get_layer_data(base + stat_sum(aes(group = clarity))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_true(all_ones(tapply(ret$prop, ret$y, FUN = sum))) - ret <- layer_data(base + stat_sum(aes(group = clarity, colour = cut))) + ret <- get_layer_data(base + stat_sum(aes(group = clarity, colour = cut))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), nrow(d)) expect_true(all_ones(tapply(ret$prop, ret$y, FUN = sum))) - ret <- layer_data(base + stat_sum(aes(group = 1, weight = price))) + ret <- get_layer_data(base + stat_sum(aes(group = 1, weight = price))) expect_equal(nrow(ret), 38) expect_equal(sum(ret$n), sum(d$price)) expect_equal(sum(ret$prop), 1) diff --git a/tests/testthat/test-stat-summary.R b/tests/testthat/test-stat-summary.R index 925ba8d4b1..abc2ffe5dd 100644 --- a/tests/testthat/test-stat-summary.R +++ b/tests/testthat/test-stat-summary.R @@ -20,8 +20,8 @@ test_that("stat_summary(_bin) work with lambda expressions", { }) expect_equal( - layer_data(p1), - layer_data(p2) + get_layer_data(p1), + get_layer_data(p2) ) @@ -34,14 +34,22 @@ test_that("stat_summary(_bin) work with lambda expressions", { ) expect_equal( - layer_data(p1), - layer_data(p3) + 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 + ) - + ld <- layer_data(p) + expect_equal(unique(ld$width), 2) +}) test_that("stat_summary_(2d|hex) work with lambda expressions", { @@ -60,8 +68,8 @@ test_that("stat_summary_(2d|hex) work with lambda expressions", { stat_summary_2d(fun = ~ mean(.x)) expect_equal( - layer_data(p1), - layer_data(p2) + get_layer_data(p1), + get_layer_data(p2) ) @@ -76,8 +84,8 @@ test_that("stat_summary_(2d|hex) work with lambda expressions", { stat_summary_hex(fun = ~ mean(.x)) expect_equal( - layer_data(p1), - layer_data(p2) + 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 98138d2d21..fb5d39c036 100644 --- a/tests/testthat/test-stat-ydensity.R +++ b/tests/testthat/test-stat-ydensity.R @@ -13,17 +13,15 @@ test_that("`drop = FALSE` preserves groups with 1 observations", { p <- ggplot(df, mapping = aes(x, y, fill = g)) - expect_warning( - ld <- layer_data(p + geom_violin(drop = TRUE)), - "Groups with fewer than two datapoints have been dropped" + expect_snapshot_warning( + ld <- get_layer_data(p + geom_violin(drop = TRUE)) ) - expect_equal(length(unique(ld$x)), 3) + expect_length(unique(ld$x), 3) - expect_warning( - ld <- layer_data(p + geom_violin(drop = FALSE)), - "Cannot compute density for groups with fewer than two datapoints" + expect_snapshot_warning( + ld <- get_layer_data(p + geom_violin(drop = FALSE)) ) - expect_equal(length(unique(ld$x)), 4) + expect_length(unique(ld$x), 4) }) test_that("mapped_discrete class is preserved", { @@ -33,7 +31,7 @@ test_that("mapped_discrete class is preserved", { y = 1:6 ) - ld <- layer_data( + ld <- get_layer_data( ggplot(df, aes(x, y)) + geom_violin() + scale_x_discrete(drop = FALSE) ) @@ -41,3 +39,15 @@ test_that("mapped_discrete class is preserved", { expect_s3_class(ld$x, "mapped_discrete") expect_equal(unique(ld$x), c(1, 3)) }) + +test_that("quantiles are based on actual data (#4120)", { + + df <- data.frame(y = 0:10) + q <- seq(0.1, 0.9, by = 0.1) + + p <- ggplot(df, aes("X", y)) + + stat_ydensity(quantiles = q) + ld <- get_layer_data(p) + + expect_equal(ld$y[!is.na(ld$quantile)], 1:9) +}) diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index b1acda601e..f8e8b37f31 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -3,17 +3,17 @@ test_that("plot succeeds even if some computation fails", { p1 <- ggplot(df, aes(x, y)) + geom_point() b1 <- ggplot_build(p1) - expect_equal(length(b1$data), 1) + expect_length(b1$data, 1) p2 <- p1 + stat_summary(fun = function(x) stop("Failed computation")) - expect_warning(b2 <- ggplot_build(p2), "Computation failed") - expect_equal(length(b2$data), 2) + expect_snapshot_warning(b2 <- ggplot_build(p2)) + expect_length(b2$data, 2) }) test_that("error message is thrown when aesthetics are missing", { p <- ggplot(mtcars) + stat_sum() - expect_error(ggplot_build(p), "x and y\\.$") + expect_snapshot(ggplot_build(p), error = TRUE) }) test_that("erroneously dropped aesthetics are found and issue a warning", { @@ -29,7 +29,7 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { g = rep(1:2, each = 5) ) p1 <- ggplot(df1, aes(x, fill = g)) + geom_density() - expect_warning(ggplot_build(p1), "aesthetics were dropped") + expect_snapshot_warning(ggplot_build(p1)) # case 2-1) dropped partially @@ -47,7 +47,7 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA) expect_true(all(is.na(b2$data[[1]]$colour))) # fill is dropped because group b's fill is not constant - expect_true(all(b2$data[[1]]$fill == GeomBar$default_aes$fill)) + expect_true(all(b2$data[[1]]$fill == "#595959FF")) # case 2-1) dropped partially with NA @@ -59,10 +59,7 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { p3 <- ggplot(df3, aes(id, colour = colour, fill = fill)) + geom_bar() + scale_fill_continuous(na.value = "#123") - expect_warning( - b3 <- ggplot_build(p3), - "The following aesthetics were dropped during statistical transformation: .*colour.*" - ) + expect_snapshot_warning(b3 <- ggplot_build(p3)) # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA) expect_true(all(is.na(b3$data[[1]]$colour))) @@ -72,3 +69,22 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { c(TRUE, FALSE, FALSE) ) }) + +test_that("stats can modify persistent attributes", { + + StatTest <- ggproto( + "StatTest", Stat, + compute_layer = function(self, data, params, layout) { + attr(data, "foo") <- "bar" + data + } + ) + + p <- ggplot(mtcars, aes(disp, mpg)) + + geom_point(stat = StatTest) + + facet_wrap(~cyl) + + ld <- layer_data(p) + expect_equal(attr(ld, "foo"), "bar") + +}) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 3ba35f5109..10ef91cf95 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -49,7 +49,7 @@ test_that("modifying theme element properties with + operator works", { t <- theme_grey() + theme() expect_identical(t, theme_grey()) - expect_error(theme_grey() + "asdf") + expect_snapshot(theme_grey() + "asdf", error = TRUE) }) test_that("adding theme object to ggplot object with + operator works", { @@ -115,7 +115,7 @@ test_that("replacing theme elements with %+replace% operator works", { t <- theme_grey() %+replace% theme() expect_identical(t, theme_grey()) - expect_error(theme_grey() + "asdf") + expect_snapshot(theme_grey() + "asdf", error = TRUE) }) test_that("calculating theme element inheritance works", { @@ -240,19 +240,17 @@ test_that("complete and non-complete themes interact correctly with ggplot objec expect_identical(pt, tt) p <- ggplot_build(base + theme(text = element_text(colour = 'red', face = 'italic'))) - expect_false(attr(p$plot$theme, "complete")) 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'))) - expect_false(attr(p$plot$theme, "complete")) expect_equal(p$plot$theme$text$colour, "red") expect_equal(p$plot$theme$text$face, "italic") }) -test_that("theme(validate=FALSE) means do not validate_element", { +test_that("theme(validate=FALSE) means do not check_element", { p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() bw <- p + theme_bw() red.text <- theme(text = element_text(colour = "red")) @@ -287,7 +285,7 @@ test_that("incorrect theme specifications throw meaningful errors", { 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(theme_set("foo")) + expect_snapshot_error(set_theme("foo")) }) test_that("element tree can be modified", { @@ -314,6 +312,17 @@ test_that("element tree can be modified", { p1 <- ggplot() + theme(blablabla = element_line()) expect_snapshot_error(ggplotGrob(p1)) + # Expect errors for invalid element trees + expect_snapshot_error( + register_theme_elements(element_tree = list(el_def("rect"), el_def("line"))) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = "bar")) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = el_def(inherit = "foo"))) + ) + # inheritance and final calculation of novel element works final_theme <- ggplot2:::plot_theme(p, theme_gray()) e1 <- calc_element("blablabla", final_theme) @@ -370,10 +379,7 @@ test_that("elements can be merged", { merge_element(element_line(colour = "blue"), line_base), element_line(colour = "blue", linewidth = 10) ) - expect_error( - merge_element(text_base, rect_base), - "Only elements of the same class can be merged" - ) + expect_snapshot(merge_element(text_base, rect_base), error = TRUE) }) test_that("theme elements that don't inherit from element can be combined", { @@ -394,7 +400,7 @@ test_that("complete plot themes shouldn't inherit from default", { }) test_that("current theme can be updated with new elements", { - old <- theme_set(theme_grey()) + old <- set_theme(theme_grey()) b1 <- ggplot() + theme_grey() b2 <- ggplot() @@ -412,7 +418,7 @@ test_that("current theme can be updated with new elements", { ) # theme calculation for nonexisting element returns NULL - expect_identical(calc_element("abcde", plot_theme(b1)), NULL) + expect_null(calc_element("abcde", plot_theme(b1))) # element tree gets merged properly register_theme_elements( @@ -428,7 +434,7 @@ test_that("current theme can be updated with new elements", { expect_identical(e1, e2) reset_theme_settings() - theme_set(old) + set_theme(old) }) test_that("titleGrob() and margins() work correctly", { @@ -515,11 +521,37 @@ test_that("Theme elements are checked during build", { 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)) + + # Test rejection of unknown theme elements + expect_snapshot_warning( + expect_equal( + subtheme(list(foo = 1, bar = 2, axis.line = line)), + theme(axis.line = line) + ) + ) +}) + test_that("Theme validation behaves as expected", { tree <- get_element_tree() - expect_silent(validate_element(1, "aspect.ratio", tree)) - expect_silent(validate_element(1L, "aspect.ratio", tree)) - expect_snapshot_error(validate_element("A", "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", { @@ -583,8 +615,170 @@ test_that("Minor tick length supports biparental inheritance", { ) }) +test_that("header_family is passed on correctly", { + + td <- theme_dark(base_family = "x", header_family = "y") + + test <- calc_element("plot.title", td) + expect_equal(test$family, "y") + + test <- calc_element("plot.subtitle", td) + expect_equal(test$family, "x") +}) + +test_that("complete_theme completes a theme", { + # `NULL` should match default + gray <- theme_gray() + new <- complete_theme(NULL, default = gray) + expect_equal(new, gray, ignore_attr = "validate") + + # Elements are propagated + new <- complete_theme(theme(axis.line = element_line("red")), gray) + expect_equal(new$axis.line$colour, "red") + + # Missing elements are filled in if default theme is incomplete + new <- complete_theme(default = theme()) + expect_s3_class(new$axis.line, "element_blank") + + # Registered elements are included + register_theme_elements( + test = element_text(), + element_tree = list(test = el_def("element_text", "text")) + ) + new <- complete_theme(default = gray) + expect_s3_class(new$test, "element_text") + reset_theme_settings() +}) + +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") + + theme( + panel.widths = unit(11, "cm"), + panel.spacing.x = unit(1, "cm") + ) + ) + + idx <- range(panel_cols(p)$l) + expect_equal(as.numeric(p$widths[seq(idx[1], idx[2])]), c(2, 1, 3, 1, 4)) + + p <- ggplotGrob( + ggplot(df, aes(x, x)) + + geom_point() + + scale_y_continuous(expand = expansion(add = 1)) + + facet_grid(g ~ ., scales = "free_y", space = "free_y") + + theme( + panel.heights = unit(11, "cm"), + panel.spacing.y = unit(1, "cm") + ) + ) + + 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", { + p <- ggplot(mpg, aes(displ, hwy)) + + geom_point() + + theme(aspect.ratio = 1, panel.widths = unit(4, "cm")) + expect_warning(ggplotGrob(p), "Aspect ratios are overruled") +}) + +test_that("margin_part() mechanics work as expected", { + + t <- theme_gray() + + theme(plot.margin = margin_part(b = 11)) + + test <- calc_element("plot.margin", t) + expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) + + t <- theme_gray() + + theme(margins = margin_part(b = 11)) + + test <- calc_element("plot.margin", t) + expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) +}) + +test_that("theme() warns about conflicting palette options", { + expect_silent( + theme(palette.colour.discrete = c("dodgerblue", "orange")) + ) + local_options(ggplot2.discrete.colour = c("red", "purple")) + expect_snapshot_warning( + theme(palette.colour.discrete = c("dodgerblue", "orange")) + ) +}) + +test_that("geom elements are inherited correctly", { + + GeomFoo <- ggproto("GeomFoo", GeomPoint) + GeomBar <- ggproto("GeomBar", GeomFoo) + + p <- ggplot(data.frame(x = 1), aes(x, x)) + + stat_identity(geom = GeomBar) + + theme( + geom = element_geom(pointshape = 15), + geom.point = element_geom(borderwidth = 2, ink = "blue"), + geom.foo = element_geom(pointsize = 2), + geom.bar = element_geom(ink = "red") + ) + p <- layer_data(p) + expect_equal(p$shape, 15) + expect_equal(p$stroke, 2) + expect_equal(p$size, 2) + expect_equal(p$colour, "red") +}) + # 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), + id = c(1, 1, 1, 1, 2, 2, 2, 2), + colour = c("orange", "limegreen") + ) + + expect_s3_class(g, "pathgrob") + expect_equal(g$gp$fill, "orchid") + + expect_doppelganger( + "polygon elements", + 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( + e, + x = seq(0.1, 0.9, length.out = 5), + y = seq(0.9, 0.1, length.out = 5), + fill = c("orange", "limegreen", "orchid", "turquoise", "grey") + ) + + expect_s3_class(g, "points") + expect_equal(g$pch, 21) + + expect_doppelganger( + "point elements", + 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)) p <- ggplot(df, aes(x, y)) + @@ -649,6 +843,19 @@ test_that("themes look decent at larger base sizes", { 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) + + 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"))) + +}) + test_that("axes can be styled independently", { plot <- ggplot() + geom_point(aes(1:10, 1:10)) + @@ -682,12 +889,12 @@ test_that("axes ticks can have independent lengths", { scale_x_continuous(sec.axis = dup_axis()) + scale_y_continuous(sec.axis = dup_axis()) + theme( - axis.ticks.length.x.top = unit(-.5, "cm"), - axis.ticks.length.x.bottom = unit(-.25, "cm"), - axis.ticks.length.y.left = unit(.25, "cm"), - axis.ticks.length.y.right = unit(.5, "cm"), - axis.text.x.bottom = element_text(margin = margin(t = .25, unit = "cm")), - axis.text.x.top = element_text(margin = margin(b = .25, unit = "cm")) + axis.ticks.length.x.top = unit(-0.5, "cm"), + axis.ticks.length.x.bottom = unit(-0.25, "cm"), + axis.ticks.length.y.left = unit(0.25, "cm"), + axis.ticks.length.y.right = unit(0.5, "cm"), + axis.text.x.bottom = element_text(margin = margin(t = 0.25, unit = "cm")), + axis.text.x.top = element_text(margin = margin(b = 0.25, unit = "cm")) ) expect_doppelganger("ticks_length", plot) }) @@ -794,6 +1001,24 @@ test_that("Strips can render custom elements", { expect_doppelganger("custom strip elements can render", plot) }) +test_that("theme ink and paper settings work", { + + p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + + geom_point() + + facet_wrap(~"Strip title") + + labs( + title = "Main title", + subtitle = "Subtitle", + tag = "A", + caption = "Caption" + ) + + expect_doppelganger( + "Theme with inverted colours", + p + theme_gray(ink = "white", paper = "black") + ) +}) + test_that("legend margins are correct when using relative key sizes", { df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) diff --git a/tests/testthat/test-utilities-break.R b/tests/testthat/test-utilities-break.R new file mode 100644 index 0000000000..23bc143a45 --- /dev/null +++ b/tests/testthat/test-utilities-break.R @@ -0,0 +1,3 @@ +test_that("cut_interval throws the correct error message", { + expect_snapshot_error(cut_interval(x = 1:10, width = 10)) +}) diff --git a/tests/testthat/test-utilities-checks.R b/tests/testthat/test-utilities-checks.R index fa665c9fd6..b5207cdb90 100644 --- a/tests/testthat/test-utilities-checks.R +++ b/tests/testthat/test-utilities-checks.R @@ -8,14 +8,14 @@ test_that("check_device checks R versions correctly", { # R 4.0.0 doesn't support any new features with_mocked_bindings( getRversion = function() package_version("4.0.0"), - expect_warning(check_device("gradients"), "R 4.0.0 does not support"), + expect_snapshot_warning(check_device("gradients")), .package = "base" ) # R 4.1.0 doesn't support vectorised patterns with_mocked_bindings( getRversion = function() package_version("4.1.0"), - expect_warning(check_device("gradients"), "R 4.1.0 does not support"), + expect_snapshot_warning(check_device("gradients")), .package = "base" ) @@ -29,7 +29,7 @@ test_that("check_device checks R versions correctly", { # Glyphs are only supported in R 4.3.0 onwards with_mocked_bindings( getRversion = function() package_version("4.2.0"), - expect_warning(check_device("glyphs"), "R 4.2.0 does not support"), + expect_snapshot_warning(check_device("glyphs")), .package = "base" ) @@ -56,13 +56,13 @@ test_that("check_device finds device capabilities", { with_mocked_bindings( dev.capabilities = function() list(clippingPaths = FALSE), - expect_warning(check_device("clippingPaths"), "does not support"), + expect_snapshot_warning(check_device("clippingPaths")), .package = "grDevices" ) with_mocked_bindings( dev.cur = function() c(foobar = 1), - expect_warning(check_device(".test_feature"), "Unable to check"), + expect_snapshot_warning(check_device(".test_feature")), .package = "grDevices" ) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 4537b03210..107e22e063 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -2,14 +2,14 @@ test_that("finite_cases.data.frame", { finite_cases <- function(x) cases(x, is_finite) # All finite -------------------------------------------------------------- - expect_identical(finite_cases(data_frame(x = 4)), TRUE) # 1x1 - expect_identical(finite_cases(data_frame(x = 4, y = 11)), TRUE) # 1x2 + 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_identical(finite_cases(data_frame(x = NA)), FALSE) # 1x1 - expect_identical(finite_cases(data_frame(x = 4, y = NA)), FALSE) # 1x2 + 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 @@ -17,7 +17,7 @@ test_that("finite_cases.data.frame", { # 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 = Inf)), 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)) }) @@ -87,7 +87,7 @@ test_that("parse_safe works with multi expressions", { }) test_that("x and y aesthetics have the same length", { - expect_equal(length(ggplot_global$x_aes), length(ggplot_global$y_aes)) + expect_length(ggplot_global$x_aes, length(ggplot_global$y_aes)) }) test_that("check_required_aesthetics() errors on missing", { @@ -106,9 +106,7 @@ test_that("remove_missing checks input", { test_that("characters survive remove_missing", { data <- data_frame0(x = c("A", NA)) - expect_warning( - new <- remove_missing(data, finite = TRUE) - ) + expect_snapshot_warning(new <- remove_missing(data, finite = TRUE)) expect_equal(new, data_frame0(x = "A")) }) @@ -132,10 +130,6 @@ test_that("cut_*() checks its input and output", { expect_snapshot_error(cut_width(1:10, 1, center = 0, boundary = 0.5)) }) -test_that("interleave() checks the vector lengths", { - expect_snapshot_error(interleave(1:4, numeric())) -}) - test_that("vec_rbind0 can combined ordered factors", { withr::local_options(lifecycle_verbosity = "warning") @@ -144,20 +138,17 @@ test_that("vec_rbind0 can combined ordered factors", { # However, it was technically challenging to reduce the numbers of warnings # See #5139 for more details - expect_warning( - expect_warning( - expect_warning( + lifecycle::expect_deprecated( + lifecycle::expect_deprecated( + lifecycle::expect_deprecated( { test <- vec_rbind0( data_frame0(a = factor(c("A", "B"), ordered = TRUE)), data_frame0(a = factor(c("B", "C"), ordered = TRUE)) ) - }, - " and ", class = "lifecycle_warning_deprecated" - ), - " and ", class = "lifecycle_warning_deprecated" - ), - " and ", class = "lifecycle_warning_deprecated" + } + ) + ) ) # Should be not , hence the 'exact' @@ -189,10 +180,23 @@ test_that("expose/ignore_data() can round-trip a data.frame", { # data.frame with ignored columns df <- data_frame0(a = 1:3, b = I(4:6), c = LETTERS[1:3], d = I(LETTERS[4:6])) test <- .ignore_data(df)[[1]] - expect_equal(names(test), c("a", "c", ".ignored")) - expect_equal(names(test$.ignored), c("b", "d")) + expect_named(test, c("a", "c", ".ignored")) + expect_named(test$.ignored, c("b", "d")) test <- .expose_data(test)[[1]] expect_equal(test, df[, c("a", "c", "b", "d")]) }) + +test_that("summary method gives a nice summary", { + # This test isn't important enough to break anything on CRAN + skip_on_cran() + + p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + + geom_point() + + scale_x_continuous() + + scale_colour_brewer() + + facet_grid(year ~ cyl) + + expect_snapshot(summary(p)) +}) diff --git a/tests/testthat/test-viridis.R b/tests/testthat/test-viridis.R index 31dad3f3bb..7845063085 100644 --- a/tests/testthat/test-viridis.R +++ b/tests/testthat/test-viridis.R @@ -5,12 +5,12 @@ test_that("viridis scale changes point color", { geom_point() p2 <- p1 + scale_colour_viridis_d() - expect_false(layer_data(p1)$colour == layer_data(p2)$colour) - expect_equal(layer_data(p2)$colour, "#440154FF") + expect_false(get_layer_data(p1)$colour == get_layer_data(p2)$colour) + expect_equal(get_layer_data(p2)$colour, "#440154FF") }) test_that("viridis scale is used by default for ordered factors", { p <- ggplot(df, aes(x, y, colour = tier)) + geom_point() - expect_equal(layer_data(p)$colour, "#440154FF") + expect_equal(get_layer_data(p)$colour, "#440154FF") }) diff --git a/vignettes/articles/faq-annotation.Rmd b/vignettes/articles/faq-annotation.Rmd index a36ddfb670..ff382d40b3 100644 --- a/vignettes/articles/faq-annotation.Rmd +++ b/vignettes/articles/faq-annotation.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Annotation" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) library(dplyr) knitr::opts_chunk$set( @@ -39,7 +40,7 @@ You should use `annotate(geom = "text")` instead of `geom_text()` for annotation In the following visualisation we have annotated a histogram with a red line and red text to mark the mean. Note that both the line and the text appears pixellated/fuzzy. ```{r} -#| fig.alt = "Histogram of highway miles per gallon for 234 cars. A red line is +#| fig.alt: "Histogram of highway miles per gallon for 234 cars. A red line is #| placed at the position 23.44 and is adorned with the label 'mean 23.44'. #| Both the line and the text appear pixellated due to overplotting." mean_hwy <- round(mean(mpg$hwy), 2) @@ -62,7 +63,7 @@ This is because `geom_text()` draws the geom once per each row of the data frame ```{r} -#| fig.alt = "Histogram of highway miles per gallon for 234 cars. A red line is +#| fig.alt: "Histogram of highway miles per gallon for 234 cars. A red line is #| placed at the position 23.44 and is adorned with the label 'mean = 23.44'. #| Both the line and the text appear crisp." ggplot(mpg, aes(x = hwy)) + @@ -91,7 +92,7 @@ Set `vjust = "inward"` and `hjust = "inward"` in `geom_text()`. Suppose you have the following data frame and visualization. The labels at the edges of the plot are cut off slightly. ```{r} -#| fig.alt = "A plot showing the words 'two', 'three' and 'four' arranged +#| fig.alt: "A plot showing the words 'two', 'three' and 'four' arranged #| diagonally. The 'two' and 'four' labels have been clipped to the panel's #| edge and are not displayed completely." df <- tibble::tribble( @@ -108,7 +109,7 @@ ggplot(df, aes(x = x, y = y, label = name)) + You could manually extend axis limits to avoid this, but a more straightforward approach is to set `vjust = "inward"` and `hjust = "inward"` in `geom_text()`. ```{r} -#| fig.alt = "A plot showing the words 'two', 'three' and 'four' arranged +#| fig.alt: "A plot showing the words 'two', 'three' and 'four' arranged #| diagonally. The 'two' and 'four' labels are aligned to the top-right and #| bottom-left relative to their anchor points, and are displayed in their #| entirety." @@ -129,7 +130,7 @@ Either calculate the counts ahead of time and place them on bars using `geom_tex Suppose you have the following bar plot and you want to add the number of cars that fall into each `drv` level on their respective bars. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train." ggplot(mpg, aes(x = drv)) + geom_bar() @@ -139,7 +140,7 @@ One option is to calculate the counts with `dplyr::count()` and then pass them t Note that we expanded the y axis limit to get the numbers to fit on the plot. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The count values are displayed on top of the bars as text." mpg %>% dplyr::count(drv) %>% @@ -152,7 +153,7 @@ mpg %>% Another option is to let `ggplot()` do the counting for you, and access these counts with `after_stat(count)` that is mapped to the labels to be placed on the plot with `stat_count()`. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The count values are displayed on top of the bars as text." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -173,7 +174,7 @@ First calculate the counts for each segment (e.g. with `dplyr::count()`) and the Suppose you have the following stacked bar plot. ```{r} -#| fig.alt = "A stacked bar chart showing the number of cars for each of seven +#| fig.alt: "A stacked bar chart showing the number of cars for each of seven #| types of cars. The fill colour of the bars indicate the type of drive #| train." ggplot(mpg, aes(x = class, fill = drv)) + @@ -190,7 +191,7 @@ mpg %>% You can then pass this result directly to `ggplot()`, draw the segments with appropriate heights with `y = n` in the `aes`thetic mapping and `geom_col()` to draw the bars, and finally place the counts on the plot with `geom_text()`. ```{r} -#| fig.alt = "A stacked bar chart showing the number of cars for each of seven +#| fig.alt: "A stacked bar chart showing the number of cars for each of seven #| types of cars. The fill colour of the bars indicate the type of drive #| train. In the middle of each filled part, the count value is displayed as #| text." @@ -205,7 +206,7 @@ mpg %>% ### How can I display proportions (relative frequencies) instead of counts on a bar plot? -Either calculate the proportions ahead of time and place them on bars using `geom_text()` or let `ggplot()` calculate them for you and then add them to the plot using `stat_coun()` with `geom = "text"`. +Either calculate the proportions ahead of time and place them on bars using `geom_text()` or let `ggplot()` calculate them for you and then add them to the plot using `stat_count()` with `geom = "text"`.
@@ -214,7 +215,7 @@ Either calculate the proportions ahead of time and place them on bars using `geo Suppose you have the following bar plot but you want to display the proportion of cars that fall into each `drv` level, instead of the count. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train." ggplot(mpg, aes(x = drv)) + geom_bar() @@ -223,7 +224,7 @@ ggplot(mpg, aes(x = drv)) + One option is to calculate the proportions with `dplyr::count()` and then use `geom_col()` to draw the bars ```{r} -#| fig.alt = "A bar chart showing the proportion of cars for each of three types +#| fig.alt: "A bar chart showing the proportion of cars for each of three types #| of drive train." mpg %>% dplyr::count(drv) %>% @@ -236,7 +237,7 @@ Another option is to let `ggplot()` do the calculation of proportions for you, a Note that we also need to the `group = 1` mapping for this option. ```{r} -#| fig.alt = "A bar chart showing the proportion of cars for each of three types +#| fig.alt: "A bar chart showing the proportion of cars for each of three types #| of drive train." ggplot(mpg, aes(x = drv, y = ..prop.., group = 1)) + geom_bar() diff --git a/vignettes/articles/faq-axes.Rmd b/vignettes/articles/faq-axes.Rmd index 6a9ed45521..cf88240cfa 100644 --- a/vignettes/articles/faq-axes.Rmd +++ b/vignettes/articles/faq-axes.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Axes" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) knitr::opts_chunk$set( fig.dpi = 300, @@ -36,8 +37,9 @@ Set the angle of the text in the `axis.text.x` or `axis.text.y` components of th In the following plot the labels on the x-axis are overlapping. -```{r msleep-order-sleep-total} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +```{r} +#| label: msleep-order-sleep-total +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The horizontal labels on the #| x-axis for the orders overlap and are unreadable." ggplot(msleep, aes(x = order, y = sleep_total)) + @@ -46,8 +48,9 @@ ggplot(msleep, aes(x = order, y = sleep_total)) + - Rotate axis labels: We can do this by components of the `theme()`, specifically the `axis.text.x` component. Applying some vertical and horizontal justification to the labels centers them at the axis ticks. The `angle` can be set as desired within the 0 to 360 degree range, here we set it to 90 degrees. -```{r msleep-order-sleep-total-rotate} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +```{r} +#| label: msleep-order-sleep-total-rotate +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The x-axis labels are oriented #| vertically and are readable." ggplot(msleep, aes(x = order, y = sleep_total)) + @@ -57,18 +60,20 @@ ggplot(msleep, aes(x = order, y = sleep_total)) + - Flip the axes: Use the y-axis for long labels. -```{r msleep-order-sleep-total-flip} -#| fig.alt = "A boxplot showing the total amount of sleep on the x-axis for 19 +```{r} +#| label: msleep-order-sleep-total-flip +#| fig.alt: "A boxplot showing the total amount of sleep on the x-axis for 19 #| taxonomical orders of mammals on the y-axis. The y-axis labels are oriented #| horizontally and are readable." ggplot(msleep, aes(y = order, x = sleep_total)) + geom_boxplot() ``` -- Dodge axis labels: Add a `scale_*()` layer, e.g. `scale_x_continuous()`, `scale_y_discrete()`, etc., and customise the `guide` argument with the `guide_axis()` function. In this case we want to customise the x-axis, and the variable on the x-axis is discrete, so we'll use `scale_x_continuous()`. In the `guide` argument we use the `guide_axis()` and specify how many rows to dodge the labels into with `n.dodge`. This is likely a trial-and-error exercise, depending on the lengths of your labels and the width of your plot. In this case we've settled on 3 rows to render the labels. +- Dodge axis labels: Add a `scale_*()` layer, e.g. `scale_x_continuous()`, `scale_y_discrete()`, etc., and customise the `guide` argument with the `guide_axis()` function. In this case we want to customise the x-axis, and the variable on the x-axis is discrete, so we'll use `scale_x_discrete()`. In the `guide` argument we use the `guide_axis()` and specify how many rows to dodge the labels into with `n.dodge`. This is likely a trial-and-error exercise, depending on the lengths of your labels and the width of your plot. In this case we've settled on 3 rows to render the labels. -```{r msleep-order-sleep-total-dodge} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +```{r} +#| label: msleep-order-sleep-total-dodge +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The horizontal labels on the #| x-axis are dodged to three levels so that they remain readable." ggplot(msleep, aes(x = order, y = sleep_total)) + @@ -78,8 +83,9 @@ ggplot(msleep, aes(x = order, y = sleep_total)) + - Omit overlapping labels: Alternatively, you can set `guide_axis(check.overlap = TRUE)` to omit axis labels that overlap. ggplot2 will prioritize the first, last, and middle labels. Note that this option might be more preferable for axes representing variables that have an inherent ordering that is obvious to the audience of the plot, so that it's trivial to guess what the missing labels are. (This is not the case for the following plot.) -```{r msleep-order-sleep-total-check-overlap} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +```{r} +#| label: msleep-order-sleep-total-check-overlap +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. Several of the x-axis labels #| have been omitted, but the one that remain are readable and don't overlap." ggplot(msleep, aes(x = order, y = sleep_total)) + @@ -99,8 +105,9 @@ Add a `theme()` layer and set relevant arguments, e.g. `axis.title.x`, `axis.tex Suppose we want to remove the axis labels entirely. -```{r ref.label="msleep-order-sleep-total"} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +```{r} +#| ref-label: msleep-order-sleep-total +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The horizontal labels on the #| x-axis for the orders overlap and are unreadable." ``` @@ -108,9 +115,9 @@ Suppose we want to remove the axis labels entirely. - Remove x or y axis labels: If you want to modify just one of the axes, you can do so by modifying the components of the `theme()`, setting the elements you want to remove to `element_blank()`. You would replace `x` with `y` for applying the same update to the y-axis. Note the distinction between `axis.title` and `axis.ticks` -- `axis.title` is the name of the variable and `axis.text` is the text accompanying each of the ticks. ```{r} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The annotation on the x-axis -#| is abent." +#| is absent." ggplot(msleep, aes(x = order, y = sleep_total)) + geom_boxplot() + theme( @@ -123,7 +130,7 @@ ggplot(msleep, aes(x = order, y = sleep_total)) + - Remove all axis labels: You can use `theme_void()` to remove all theming elements. Note that this might remove more features than you like. For finer control over the theme, see below. ```{r} -#| fig.alt = "A boxplot showing the total amount of sleep on the y-axis for 19 +#| fig.alt: "A boxplot showing the total amount of sleep on the y-axis for 19 #| taxonomical orders of mammals on the x-axis. The plot has no axes, #| gridlines or background panel." ggplot(msleep, aes(x = order, y = sleep_total)) + @@ -162,7 +169,7 @@ sales <- tribble( You can create a line plot of these data and facet by `year` to group the quarters for each year together. ```{r} -#| fig.alt = "A line plot with two panels showing value on the y-axis and four +#| fig.alt: "A line plot with two panels showing value on the y-axis and four #| quarters on the x-axis. The left panel is labelled '2020' and the right #| panel is labelled '2021'." ggplot(sales, aes(x = quarter, y = value, group = 1)) + @@ -175,7 +182,7 @@ However it might be preferable to plot all points in a single plot and indicate To achieve this, map the `interaction()` of `quarter` and `year` to the `x` aesthetic. ```{r} -#| fig.alt = "A line plot with one panel showing value on the y-axis and eight +#| fig.alt: "A line plot with one panel showing value on the y-axis and eight #| quarters on the x-axis. The years are appended after each quarter label." ggplot(sales, aes(x = interaction(quarter, year), y = value, group = 1)) + geom_line() @@ -186,14 +193,14 @@ To clean this up (1) clip the plotting area with `coord_cartesian()`, (2) remove Note that the x-coordinates of the year labels are manually assigned here, but if you had many more years, you might write some logic to calculate their placement. ```{r} -#| fig.alt = "A line plot with one panel showing value on the y-axis and eight +#| fig.alt: "A line plot with one panel showing value on the y-axis and eight #| quarters on the x-axis. The years are shown in the middle of the first four #| and last four quarters. The line touches the panel on the left and right." ggplot(sales, aes(x = interaction(quarter, year), y = value, group = 1)) + geom_line() + coord_cartesian(ylim = c(9, 32), expand = FALSE, clip = "off") + theme( - plot.margin = unit(c(1, 1, 3, 1), "lines"), + plot.margin = margin(1, 1, 3, 1, "lines"), axis.title.x = element_blank(), axis.text.x = element_blank() ) + @@ -205,7 +212,7 @@ This approach works with other geoms as well. For example, you might can create a bar plot representing the same data using the following. ```{r} -#| fig.alt = "A bar chart with one panel showing value on the y-axis and eight +#| fig.alt: "A bar chart with one panel showing value on the y-axis and eight #| quarters on the x-axis. The years are shown in the middle of the first four #| and last four quarters. The outer bars touch the panel on the left and #| right." @@ -215,7 +222,7 @@ ggplot(sales, aes(x = interaction(quarter, year), y = value)) + annotate(geom = "text", x = seq_len(nrow(sales)), y = -1, label = sales$quarter, size = 3) + annotate(geom = "text", x = c(2.5, 6.5), y = -3, label = unique(sales$year), size = 4) + theme( - plot.margin = unit(c(1, 1, 3, 1), "lines"), + plot.margin = margin(1, 1, 3, 1, "lines"), axis.title.x = element_blank(), axis.text.x = element_blank() ) @@ -225,7 +232,7 @@ If it's undesirable to have the bars flush against the edges of the plot, a simi However note that the space between the bars for 2020 Q4 and 2021 Q1 is greater than the space between the other bars. ```{r} -#| fig.alt = "A bar chart showing value on the y-axis and eight +#| fig.alt: "A bar chart showing value on the y-axis and eight #| quarters on the x-axis. The chart appears as a single panel. The years are #| shown in the middle of the first four and last four quarters. The outer bars #| do not touch the panel on the left and right." @@ -255,7 +262,7 @@ Add a `scale_*()` layer, e.g. `scale_x_continuous()`, `scale_y_discrete()`, etc. Suppose you want to give more informative labels for the type of drive train. ```{r} -#| fig.alt = "A horizontal bar chart showing the number of cars on the x-axis +#| fig.alt: "A horizontal bar chart showing the number of cars on the x-axis #| for each of three types of drive trains on the y-axis. The three drive trains #| are labelled from top-to-bottom as 'r', 'f' and '4'." ggplot(mpg, aes(y = drv)) + @@ -265,7 +272,7 @@ ggplot(mpg, aes(y = drv)) + - Use the `labels` argument in the appropriate `scale_*()` function. You can find a list of these functions [here](https://ggplot2.tidyverse.org/reference/index.html#section-scales). Type of drive train (`drv`) is a discrete variable on the y-axis, so we'll adjust the labels in `scale_y_discrete()`. One option is to list the labels in the same order as the levels. Note that we start from the bottom and go up, just like we would if the variable was numeric/continuous. ```{r} -#| fig.alt = "A horizontal bar chart showing the number of cars on the x-axis +#| fig.alt: "A horizontal bar chart showing the number of cars on the x-axis #| for each of three types of drive trains on the y-axis. The three drive trains #| are labelled from top-to-bottom as 'Rear wheel drive', 'Front wheel drive' #| and 'Four wheel drive'." @@ -279,7 +286,7 @@ ggplot(mpg, aes(y = drv)) + - Another approach is to use a named list. This approach not only makes the relabelling more explicit, but it also means you don't need to worry about the order of the levels. ```{r} -#| fig.alt = "A horizontal bar chart showing the number of cars on the x-axis +#| fig.alt: "A horizontal bar chart showing the number of cars on the x-axis #| for each of three types of drive trains on the y-axis. The three drive trains #| are labelled from top-to-bottom as 'Rear wheel drive', 'Front wheel drive' #| and 'Four wheel drive'." @@ -308,7 +315,7 @@ You will first need to add a `scale_*()` layer (e.g. `scale_x_continuous()`, `sc By default, large numbers on the axis labels in the following plot are shown in scientific notation. ```{r} -#| fig.alt = "A scatter plot showing the median sale price of housing in Texas +#| fig.alt: "A scatter plot showing the median sale price of housing in Texas #| on the x-axis and the total volume of sales on the y-axis. The labels of #| both axes are in scientific notation, for example: '1e+09'." ggplot(txhousing, aes(x = median, y = volume)) + @@ -319,7 +326,7 @@ The [**scales**](https://scales.r-lib.org/) package offers a large number of fun Use `scales::label_number()` to force decimal display of numbers rather than using scientific notation or use `scales::label_comma()` to insert a comma every three digits. ```{r} -#| fig.alt = "A scatter plot showing the median sale price of housing in Texas +#| fig.alt: "A scatter plot showing the median sale price of housing in Texas #| on the x-axis and the total volume of sales on the y-axis. The labels of #| the y-axis are written out in full, with commas marking groups of three #| zeroes. The x-axis labels are written out in full, with spaces marking @@ -345,7 +352,7 @@ You will first need to add a `scale_*()` layer (e.g. `scale_x_continuous()`, `sc Suppose you want to increase/decrease the number of decimal spaces shown in the axis text in the following plot. ```{r} -#| fig.alt = "A scatter plot showing the difference in longitude on the x-axis +#| fig.alt: "A scatter plot showing the difference in longitude on the x-axis #| and difference in latitude on the y-axis for seal movements. The x-axis #| labels have one digit after the decimal place. The y-axis labels have two #| digits after the decimal place." @@ -357,7 +364,7 @@ The [**scales**](https://scales.r-lib.org/) package offers a large number of fun Use `scales::label_number()` where the `accuracy` argument indicates the number to round to, e.g. 0.1 to show 1 decimal place, 0.0001 to show 4 decimal places, etc. ```{r} -#| fig.alt = "A scatter plot showing the difference in longitude on the x-axis +#| fig.alt: "A scatter plot showing the difference in longitude on the x-axis #| and difference in latitude on the y-axis for seal movements. The x-axis #| labels have one digit after the decimal place. The y-axis labels have four #| digits after the decimal place." @@ -383,7 +390,7 @@ You will first need to add a `scale_*()` layer (e.g. `scale_x_continuous()`, `sc The variable on the y-axis of the following line plot (`psavert`) indicates the personal savings rate, which is in percentages. ```{r} -#| fig.alt = "A lineplot showing the personal savings rate over time from 1967 +#| fig.alt: "A lineplot showing the personal savings rate over time from 1967 #| to 2015." ggplot(economics, aes(x = date, y = psavert, group = 1)) + geom_line() @@ -392,7 +399,7 @@ ggplot(economics, aes(x = date, y = psavert, group = 1)) + With `scales::label_percent()` you can add `%`s after the numbers shown on the axis to make the units more clear. ```{r} -#| fig.alt = "A lineplot showing the personal savings rate over time from 1967 +#| fig.alt: "A lineplot showing the personal savings rate over time from 1967 #| to 2015. The y-axis labels are appended by percentage signs." ggplot(economics, aes(x = date, y = psavert, group = 1)) + geom_line() + @@ -414,7 +421,7 @@ You can either use `bquote()` to parse mathematical expressions or use the [**gg In the following plot `cty` is squared and `hwy` is log transformed. ```{r} -#| fig.alt = "A scatter plot showing the squared city miles per gallon on the +#| fig.alt: "A scatter plot showing the squared city miles per gallon on the #| x-axis versus the logarithm of highway miles per gallon on the y-axis for #| 234 cars." ggplot(mpg, aes(x = cty^2, y = log(hwy))) + @@ -424,7 +431,7 @@ ggplot(mpg, aes(x = cty^2, y = log(hwy))) + - Use `bquote()` function to parse mathematical expressions. ```{r} -#| fig.alt = "A scatter plot showing the squared city miles per gallon on the +#| fig.alt: "A scatter plot showing the squared city miles per gallon on the #| x-axis versus the base 10 logarithm of highway miles per gallon on the #| y-axis for 234 cars. In the axis titles, the base 10 is indicated in #| subscript on the y-axis and the power 2 is indicated in superscript on @@ -440,7 +447,7 @@ ggplot(mpg, aes(x = cty^2, y = log(hwy, base = 10))) + - If you're already familiar with Markdown and HTML, you might prefer using the [ggtext](https://wilkelab.org/ggtext/) package instead. In Markdown we can write the axis labels as `cty2` and `log10(hwy)` for x and y axes, respectively. Then, we tell ggplot2 to interpret the axis labels as Markdown and not as plain text by setting `axis.title.x` and `axis.title.y` to `ggtext::element_markdown()`. ```{r} -#| fig.alt = "A scatter plot showing the squared city miles per gallon on the +#| fig.alt: "A scatter plot showing the squared city miles per gallon on the #| x-axis versus the base 10 logarithm of highway miles per gallon on the #| y-axis for 234 cars. In the axis titles, the base 10 is indicated in #| subscript on the y-axis and the power 2 is indicated in superscript on @@ -472,7 +479,7 @@ Customise the `breaks` and `minor_breaks` in `scale_x_continuous()`, `scale_y_co Suppose you want to customise the major and minor grid lines on both the x and the y axes of the following plot. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis versus +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis versus #| the highway miles per gallon on the y-axis for 234 cars. The distance #| between axis ticks is constant within each axis." ggplot(mpg, aes(x = cty, y = hwy)) + @@ -483,7 +490,7 @@ You can set `breaks` and `minor_breaks` in `scale_x_continuous()` and `scale_y_c For example, on the x-axis we have major and minor grid breaks defined as a sequence and on the y-axis we have explicitly stated where major breaks should appear as a vector (the value stated are randomly selected for illustrative purposes only, they don't follow a best practice) and we have completely turned off minor grid lines by setting `minor_breaks` to `NULL`. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis versus +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis versus #| the highway miles per gallon on the y-axis for 234 cars. The distance #| between axis ticks varies within the y-axis. There are no minor horizontal #| grid lines, and there are three minor vertical gridlines between major @@ -528,7 +535,7 @@ Remove the padding around the data entirely using by setting `expand = c(0, 0)` - Remove all padding: Suppose you want to remove the padding around the heat map so it's flush against the axes. ```{r} -#| fig.alt = "A heatmap showing a 2D density estimate of the waiting and +#| fig.alt: "A heatmap showing a 2D density estimate of the waiting and #| eruption times of the Old Faithful geyser. The heatmap does not touch the #| panel edges." ggplot(faithfuld, aes(waiting, eruptions)) + @@ -538,7 +545,7 @@ ggplot(faithfuld, aes(waiting, eruptions)) + Since both x and y variables are continuous, we set `expand = c(0, 0)` in both `scale_x_continuous()` and `scale_y_continuous()`. ```{r} -#| fig.alt = "A heatmap showing a 2D density estimate of the waiting and +#| fig.alt: "A heatmap showing a 2D density estimate of the waiting and #| eruption times of the Old Faithful geyser. The heatmap touches the panel #| edges." ggplot(faithfuld, aes(waiting, eruptions)) + @@ -550,7 +557,7 @@ ggplot(faithfuld, aes(waiting, eruptions)) + - Remove some of the padding: Suppose you want to remove the padding below the bars and the x-axis only. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. No parts of the bars touch the panel edges." ggplot(mpg, aes(drv)) + geom_bar() @@ -559,7 +566,7 @@ ggplot(mpg, aes(drv)) + You would make this adjustment on `scale_y_continuous()` since that padding is in the vertical direction. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. All bars touch the bottom of the panel, and the highest bar #| touches the top of the panel." ggplot(mpg, aes(drv)) + @@ -574,7 +581,7 @@ The `mult` argument in `expansion()` takes a multiplicative range expansion fact Given a vector of length 2, the lower limit is expanded by `mult[1]` (in this case 0) and the upper limit is expanded by `mult[2]` (in this case 0.05). ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. All bars touch the bottom of the panel, and no bar touches #| the top of the panel." ggplot(mpg, aes(drv)) + diff --git a/vignettes/articles/faq-bars.Rmd b/vignettes/articles/faq-bars.Rmd index 345ff68c1b..daae53ef58 100644 --- a/vignettes/articles/faq-bars.Rmd +++ b/vignettes/articles/faq-bars.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Barplots" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) library(dplyr) library(tidyr) @@ -42,7 +43,7 @@ If assigning color based on another variable, map the variable to the `fill` `ae You can set all bars to be a given color with the `fill` argument of `geom_bar()`. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. All bars are blue." ggplot(mpg, aes(x = drv)) + geom_bar(fill = "blue") @@ -51,7 +52,7 @@ ggplot(mpg, aes(x = drv)) + Alternatively, if the colors should be based on a variable, this should be should happen in the `aes()` mapping. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. From left-to-right, the bars appear red, green and blue." ggplot(mpg, aes(x = drv, fill = drv)) + geom_bar() @@ -61,7 +62,7 @@ And if you want to then customize the colors, one option is `scale_fill_manual() See other `scale_fill_*()` functions for more options for color choices. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. From left-to-right, the bars are purple, orange and dark #| blue." ggplot(mpg, aes(x = drv, fill = drv)) + @@ -85,12 +86,11 @@ By default, the `width` of bars is `0.9` (90% of the resolution of the data). You can set this argument to a lower value to get bars that are narrower with more space between them. ```{r} -#| fig.alt = c( -#| "A bar chart showing the number of cars for each of three types -#| of drive train. The bars are somewhat narrower than the default.", -#| "A bar chart showing the number of cars for each of three types +#| fig.alt: +#| - "A bar chart showing the number of cars for each of three types +#| of drive train. The bars are somewhat narrower than the default." +#| - "A bar chart showing the number of cars for each of three types #| of drive train. The bars are very narrow." -#| ) ggplot(mpg, aes(x = drv)) + geom_bar(width = 0.5) @@ -111,7 +111,7 @@ Adjust the `expand` argument in `scale_y_continuous()`, e.g. add `scale_y_contin By default ggplot2 expands the axes so the geoms aren't flush against the edges of the plot. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. No parts of the bars touch the panel edges." ggplot(mpg, aes(x = drv)) + geom_bar() @@ -120,7 +120,7 @@ ggplot(mpg, aes(x = drv)) + To remove the spacing between the bars and the x-axis, but keep the spacing between the bars and the top of the plot, use the following. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The bottom of the bars touch the x-axis." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -131,7 +131,7 @@ To achieve the opposite, switch the values in `mult`. Note that the tallest bar is now flush against top of the plot. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The top of the highest bar touches the top of the panel." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -142,7 +142,7 @@ To adjust spacing around the x-axis, adjust the `expand` argument in `scale_x_di Note that this places the bars flush against the left side and leaves some space on the right side. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The left of the leftmost bar touches the y-axis." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -152,7 +152,7 @@ ggplot(mpg, aes(x = drv)) + The default look of a bar plot can be achieved with the following. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. No parts of the bars touch the panel edges." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -173,7 +173,7 @@ Set `position = position_dodge2(preserve = "single")` in `geom_bar()`. In the following plot the bars have differing widths within each level of `drv` as there are differing levels of `class` represented. ```{r} -#| fig.alt = "A grouped bar chart showing car counts dodged and filled by 7 +#| fig.alt: "A grouped bar chart showing car counts dodged and filled by 7 #| types of cars for each of three types of drive train. The left group has #| 5 narrower bars, the middle group has 4 bars and the right group has 3 wider #| bars." @@ -184,7 +184,7 @@ ggplot(mpg, aes(x = drv, fill = class)) + You can use `position_dodge2()` with `preserve = "single"` to address this. ```{r} -#| fig.alt = "A grouped bar chart showing car counts dodged and filled by 7 +#| fig.alt: "A grouped bar chart showing car counts dodged and filled by 7 #| types of cars for each of three types of drive train. From left-to-right, #| each groups has respectively 5, 4 and 3 equally wide bars." ggplot(mpg, aes(x = drv, fill = class)) + @@ -207,7 +207,7 @@ If you also want to show percentages on the axis, use `scales::label_percent()`. The following plot is useful for comparing counts but not as useful for comparing proportions, which is what you need if you want to be able to make statements like "in this sample, it's more likely to have a two-seater car that has rear-wheel drive than an SUV that has rear-wheel drive". ```{r} -#| fig.alt = "A horizontal stacked bar chart showing car counts for 7 types of +#| fig.alt: "A horizontal stacked bar chart showing car counts for 7 types of #| cars, stacked and filled by 3 types of drive train." ggplot(mpg, aes(y = class, fill = drv)) + geom_bar() @@ -216,7 +216,7 @@ ggplot(mpg, aes(y = class, fill = drv)) + `position = "fill"` will generate a bar plot with bars of equal length and the stacks in each bar will show the proportion of `drv` for that particular `class`. ```{r} -#| fig.alt = "A horizontal filled bar chart showing proportions of cars for 7 +#| fig.alt: "A horizontal filled bar chart showing proportions of cars for 7 #| types of cars. The fill colour represents 3 types of drive train. Every #| stacked bar spans the width of the panel." ggplot(mpg, aes(y = class, fill = drv)) + @@ -226,7 +226,7 @@ ggplot(mpg, aes(y = class, fill = drv)) + If you want to show percentages instead of proportions on the x-axis, you can define this in `scale_x_continuous()` with `scales::label_percent()`. ```{r} -#| fig.alt = "A horizontal filled bar chart showing percentages of cars for 7 +#| fig.alt: "A horizontal filled bar chart showing percentages of cars for 7 #| types of cars. The fill colour represents 3 types of drive train. Every #| stacked bar spans the width of the panel." ggplot(mpg, aes(y = class, fill = drv)) + @@ -271,7 +271,7 @@ poll_longer Then, you can pass this result to `ggplot()` and create a bar for each `party` on the `y` (or `x`, if you prefer vertical bars) axis and fill the bars in with number of responses for each `opinion`. ```{r} -#| fig.alt = "A horizontal stacked bar chart showing opinion counts for 3 +#| fig.alt: "A horizontal stacked bar chart showing opinion counts for 3 #| parties, stacked and filled by 3 types of opinions." ggplot(poll_longer, aes(y = party, fill = opinion, x = n)) + geom_col() @@ -280,7 +280,7 @@ ggplot(poll_longer, aes(y = party, fill = opinion, x = n)) + To plot proportions (relative frequencies) instead of counts, use `position = "fill"` in `geom_col()`. ```{r} -#| fig.alt = "A horizontal filled bar chart showing proportions of opinions for +#| fig.alt: "A horizontal filled bar chart showing proportions of opinions for #| 3 parties. The fill colour represents 3 types of opinion. Every #| stacked bar spans the width of the panel." ggplot(poll_longer, aes(y = party, fill = opinion, x = n)) + @@ -315,7 +315,7 @@ You can do this with `tidyr::pivot_longer()`. Then, pass the resulting longer data frame to `ggplot()` group responses for each question together. ```{r} -#| fig.alt = "A grouped bar chart showing the number of responses to three +#| fig.alt: "A grouped bar chart showing the number of responses to three #| questions. Within each question, two bars denote an 'Agree' or 'Disagree' #| response." survey %>% @@ -342,7 +342,7 @@ One option for calculating group means is using `dplyr::group_by()` followed by Then, you can pass the resulting data frame to `ggplot()` and plot bars using `geom_col()`. ```{r} -#| fig.alt = "A bar chart showing the average highway miles per gallon for +#| fig.alt: "A bar chart showing the average highway miles per gallon for #| three types of drive train." mpg %>% group_by(drv) %>% @@ -354,7 +354,7 @@ mpg %>% Alternatively, you can use `stat_summary()` to let ggplot2 calculate and plot the means. ```{r} -#| fig.alt = "A bar chart showing the average highway miles per gallon for +#| fig.alt: "A bar chart showing the average highway miles per gallon for #| three types of drive train." ggplot(mpg, aes(x = drv, y = hwy)) + stat_summary(fun = "mean", geom = "bar") @@ -379,7 +379,7 @@ Also note that this will result in a deceiving bar plot, which should be avoided In the following plot the y-axis is limited to 20 to 120, and hence the bars are not showing up. ```{r} -#| fig.alt = "A plot with axes and a panel, but no other geometry." +#| fig.alt: "A plot with axes and a panel, but no other geometry." ggplot(mpg, aes(x = drv)) + geom_bar() + ylim(c(20, 120)) @@ -388,7 +388,7 @@ ggplot(mpg, aes(x = drv)) + In order to obtain a bar plot with limited y-axis, you need to instead set the limits in `coord_cartesian()`. ```{r} -#| fig.alt = "A bar chart showing the number of cars for each of three types +#| fig.alt: "A bar chart showing the number of cars for each of three types #| of drive train. The y-axis starts at 20, and all bars touch the x-axis." ggplot(mpg, aes(x = drv)) + geom_bar() + @@ -400,7 +400,7 @@ If you're using a bar plot to display values that could not take the value of 0, For example, if you have the following data and plot. ```{r} -#| fig.alt = "A bar chart showing numbers for 3 arbitrary categories. The +#| fig.alt: "A bar chart showing numbers for 3 arbitrary categories. The #| numbers are far away from the x-axis and visually appear broadly similar #| in height." df <- tibble::tribble( @@ -417,14 +417,13 @@ ggplot(df, aes(x = x, y = y)) + Also suppose that you want to cut off the bars at `y = 1000` since you know that the variable you're plotting cannot take a value less than 1000, you might use `geom_point()` instead. ```{r} -#| fig.alt = c( -#| "A bar chart showing numbers for 3 arbitrary categories. The y-axis starts +#| fig.alt: +#| - "A bar chart showing numbers for 3 arbitrary categories. The y-axis starts #| at 1000 and the bars all look different in height. This is not a recommended -#| way of plotting this data.", -#| "A scatter plot with 3 points showing numbers for 3 arbitrary categories. +#| way of plotting this data." +#| - "A scatter plot with 3 points showing numbers for 3 arbitrary categories. #| The y-axis starts at 1000 and the points have visually different values. #| This is a better way of plotting this data." -#| ) # don't do this ggplot(df, aes(x = x, y = y)) + geom_col() + diff --git a/vignettes/articles/faq-customising.Rmd b/vignettes/articles/faq-customising.Rmd index 9268b8a0ff..9b008af042 100644 --- a/vignettes/articles/faq-customising.Rmd +++ b/vignettes/articles/faq-customising.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Customising" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) library(tibble) knitr::opts_chunk$set( @@ -40,7 +41,7 @@ By default your legend label will be the name of the variable that is mapped to You can change the title of your legend using `labs()`. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend with the title 'Drive #| train'." @@ -52,16 +53,16 @@ ggplot(mpg, aes(x = hwy, y = cty, color = drv)) + If a legend is drawn for multiple aesthetics, you'll want to update the title for all of them. ```{r} -#| fig.alt = c( -#| "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: +#| - "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The point shapes and colours #| indicate three types of drive train. The shapes and colours are displayed in -#| separate legends titled 'drv' and 'Drive train' respectively.", -#| "A scatter plot showing the highway miles per gallon on the x-axis +#| separate legends titled 'drv' and 'Drive train' respectively." +#| - "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The point shapes and colours #| indicate three types of drive train. The shapes and colours are displayed in #| a single legend titled 'Drive train'." -#| ) +#| # not this ggplot(mpg, aes(x = hwy, y = cty, color = drv, shape = drv)) + geom_point() + @@ -89,7 +90,7 @@ You can supply a unit object to this argument, e.g. `unit(1.0, "cm")` for 1 cm s See the documentation for `grid::unit()` for more options for units. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend at the bottom of the #| plot in a horizontal orientation. Legend elements are spaced widely apart." @@ -104,7 +105,7 @@ ggplot(mpg, aes(x = hwy, y = cty, color = drv)) + For vertical legends changing `legend.spacing.y` changes the space between the legend title and the keys, but not between the keys, e.g. see the large space between the legend title and keys. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend at the right of the #| plot. In the legend, there is a large space between the title and keys." @@ -116,7 +117,7 @@ ggplot(mpg, aes(x = hwy, y = cty, color = drv)) + In order to change the space between the legend keys, you can first make the key size bigger with `legend.key.size` and then remove the grey background color with `legend.key`. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend at the right of the #| plot. In the legend, elements are placed widely apart and the title is @@ -133,7 +134,7 @@ Note that the legend title is no longer aligned with the keys with this approach You can also shift it over with the `hjust` setting of `legend.title`. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend at the right of the #| plot. In the legend, elements are placed widely apart and the title is @@ -161,7 +162,7 @@ The `labels` argument of `scale_*` functions takes named vectors, which what we Using named lists allows you to declare explicitly which label is assigned to which level, without having to keep track of level order. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by three #| types of drive train, which is displayed in a legend at the right of the #| plot. The legend items are name '4-wheel drive', 'Front-wheel drive' and @@ -191,7 +192,7 @@ You can use the following for 14 pts text for legend key labels and 10 pts text (Note that this doesn't result in a visually pleasing legend, by default ggplot2 uses a larger font size for the legend title than the legend text.) ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by seven #| types of cars, which is displayed in the legend on the right of the plot. #| The labels in the legend have a larger font size than the title." @@ -206,7 +207,7 @@ ggplot(mpg, aes(x = hwy, y = cty, color = class)) + For further customization of legend text, see the documentation for `element_text()`, e.g. you can change font colors or font face as well. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by seven #| types of cars, which is displayed in the legend on the right of the plot. #| The labels in the legends have a large, red font. The title has a smaller, @@ -235,7 +236,7 @@ You can set the background colour of the plot with `panel.background` in `theme( In the following example the border is made thicker with `linewidth = 3` to ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The panel background of the plot #| is light blue and is outlined in red with a thick stroke." ggplot(mpg, aes(x = hwy, y = cty)) + @@ -246,7 +247,7 @@ ggplot(mpg, aes(x = hwy, y = cty)) + If you want to change the colour of the plotting area but not the panel where the panel, you can so the same thing with `plot.background`. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The plot background is light blue #| and is outlined in red with a thick stroke. The panel background remains #| grey." @@ -259,7 +260,7 @@ Note that ggplot2 has a variety of [complete themes](https://ggplot2.tidyverse.o For example, if you prefer a more minimal look to your plots, without the grey background, you might try `theme_minimal()`. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. There is no visible panel #| background and grid lines are in light grey." ggplot(mpg, aes(x = hwy, y = cty)) + @@ -270,7 +271,7 @@ ggplot(mpg, aes(x = hwy, y = cty)) + And you can continue customization based on one of these themes. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. There is no visible panel #| background and grid lines are in light grey. The plot as a whole is outlined #| by a thick red line." @@ -309,7 +310,7 @@ df <- tibble::tribble( By default, ggplot2 uses grey to represent `NA`s. ```{r} -#| fig.alt = "A stacked bar chart showing two groups on the x-axis and counts +#| fig.alt: "A stacked bar chart showing two groups on the x-axis and counts #| on the y-axis. Within a stacked bar, two different outcomes and 'NA's are #| distinguished by fill colour." ggplot(df, aes(x = group, fill = outcome)) + @@ -319,7 +320,7 @@ ggplot(df, aes(x = group, fill = outcome)) + You can change the color of `NA` with `scale_fill_discrete()` in this case, e.g. make it purple. ```{r} -#| fig.alt = "A stacked bar chart showing two groups on the x-axis and counts +#| fig.alt: "A stacked bar chart showing two groups on the x-axis and counts #| on the y-axis. Within a stacked bar, two different outcomes and 'NA's are #| distinguished by fill colour. The 'NA' fill colour is purple." ggplot(df, aes(x = group, fill = outcome)) + @@ -332,7 +333,7 @@ In the plot below this is shown with `theme_minimal()` to demonstrate how that l Note that while this is possible, setting the colour to transparent as such wouldn't be recommended in this particular case as it gives the appearance of a floating bar. ```{r} -#| fig.alt = "A stacked bar chart showing two groups on the x-axis and counts +#| fig.alt: "A stacked bar chart showing two groups on the x-axis and counts #| on the y-axis. Within a stacked bar, two different outcomes and 'NA's are #| distinguished by fill colour. The 'NA' fill colour is transparent, giving #| the appearance that one of the stacked bars is floating." @@ -359,7 +360,7 @@ You can change it with the `base_size` argument in the theme you're using. See the [complete theme documentation](https://ggplot2.tidyverse.org/reference/ggtheme.html) for more high level options you can set. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The points are coloured by seven #| types of car. All text sizes in the axes and legend are large." ggplot(mpg, aes(x = hwy, y = cty, color = class)) + @@ -367,11 +368,12 @@ ggplot(mpg, aes(x = hwy, y = cty, color = class)) + theme_gray(base_size = 18) ``` -If you would like all plots within a session/document to use a particular base size, you can set it with `theme_set()`. +If you would like all plots within a session/document to use a particular base size, you can set it with `set_theme()`. Run the following at the beginning of your session or include on top of your R Markdown document. -```{r eval = FALSE} -theme_set(theme_gray(base_size = 18)) +```{r} +#| eval: false +set_theme(theme_gray(base_size = 18)) ```
@@ -389,7 +391,7 @@ Font characteristics of plot titles and subtitles can be controlled with the `pl You can use the following for 20 pts text for the plot title and 15 pts text for the plot subtitle. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The plot has a large title #| displaying 'This is the plot title' and a less large subtitle displaying #| 'And this is the subtitle' at the top of the plot." @@ -408,7 +410,7 @@ ggplot(mpg, aes(x = hwy, y = cty)) + For further customization of plot title and subtitle, see the documentation for `element_text()`, e.g. you can change font colors or font face as well. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The plot has a large red title #| displaying 'This is the plot title' and a less large subtitle in bold and #| italic displaying 'And this is the subtitle' at the top of the plot." @@ -439,7 +441,7 @@ In both cases, set font size in the `size` argument of `element_text()`, e.g. `a Font characteristics of axis labels can be controlled with `axis.title.x` or `axis.title.y` (or `axis.title` if you the same settings for both axes). ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The x-axis title displays #| 'This is HUGE' in a large font size, and the y-axis title displays #| 'This is small' in a smaller font size." @@ -458,7 +460,7 @@ ggplot(mpg, aes(x = hwy, y = cty)) + For further customization of plot title and subtitle, see the documentation for `element_text()`, e.g. you can change font colors or font face as well. ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. The x-axis title displays #| 'This is HUGE' in a large, red font, and the y-axis title displays #| 'This is tiny' in a smaller, bold and italic font." @@ -477,7 +479,7 @@ ggplot(mpg, aes(x = hwy, y = cty)) + You can also change the size of the axis text (e.g. numbers at the axis ticks) using `axis.text` (or `axis.text.x` and `axis.text.y` if you want to set different sizes). ```{r} -#| fig.alt = "A scatter plot showing the highway miles per gallon on the x-axis +#| fig.alt: "A scatter plot showing the highway miles per gallon on the x-axis #| and city miles per gallon on the y-axis. Both the x and the y axis titles #| display 'The axis labels are the same size' in a large font. Both axis #| labels are displayed in a larger, blue font." @@ -497,10 +499,10 @@ ggplot(mpg, aes(x = hwy, y = cty)) + ### What is the default size of `geom_text()` and how can I change the font size of `geom_text()`? -The default font size of `geom_text()` is 3.88. +The default font size of `geom_text()` is about 3.87. ```{r} -GeomLabel$default_aes$size +get_geom_defaults(geom_text)$size ``` You can change the size using the `size` argument in `geom_text()` for a single plot. If you want to use the same updated size, you can set this with `update_geom_defaults()`, e.g. `update_geom_defaults("text", list(size = 6))`. @@ -518,7 +520,7 @@ Please refer to ["Font size" section of the aesthetic specifications](https://gg Suppose you have the following data frame and visualization. ```{r} -#| fig.alt = "A plot showing text at diagonal positions with the labels 'two', +#| fig.alt: "A plot showing text at diagonal positions with the labels 'two', #| 'three' and 'four'." df <- tibble::tribble( ~x, ~y, ~name, @@ -534,7 +536,7 @@ ggplot(df, aes(x = x, y = y, label = name)) + You can set the size of the text with the following. ```{r} -#| fig.alt = "A plot showing larger text at diagonal positions with the labels +#| fig.alt: "A plot showing larger text at diagonal positions with the labels #| 'two', 'three' and 'four'." ggplot(df, aes(x = x, y = y, label = name)) + geom_text(size = 6) @@ -543,7 +545,7 @@ ggplot(df, aes(x = x, y = y, label = name)) + Or you can map it to the `size` `aes`thetic. In the following size is determined by the `x` value with `scale_size_identity()`. ```{r} -#| fig.alt = "A plot showing text at diagonal positions with the labels 'two', +#| fig.alt: "A plot showing text at diagonal positions with the labels 'two', #| 'three' and 'four' that increase in size from left to right." ggplot(df, aes(x = x, y = y, label = name)) + geom_text(aes(size = x)) + diff --git a/vignettes/articles/faq-faceting.Rmd b/vignettes/articles/faq-faceting.Rmd index 93ec538a9e..d5a6926d83 100644 --- a/vignettes/articles/faq-faceting.Rmd +++ b/vignettes/articles/faq-faceting.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Faceting" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) knitr::opts_chunk$set( fig.dpi = 300, @@ -37,7 +38,7 @@ The simplest answer is that you should use `facet_wrap()` when faceting by a sin `facet_wrap()` is most commonly used to facet by a plot by a single categorical variable. ```{r} -#| fig.alt = "A histogram showing the city miles per gallon distribution for +#| fig.alt: "A histogram showing the city miles per gallon distribution for #| three types of drive train, each in their own panel in a 1-row, 3-column #| layout." ggplot(mpg, aes(x = cty)) + @@ -48,7 +49,7 @@ ggplot(mpg, aes(x = cty)) + And `facet_grid()` is commonly used to facet by a plot by two categorical variables. ```{r} -#| fig.alt = "A histogram showing the city miles per gallon distribution. The +#| fig.alt: "A histogram showing the city miles per gallon distribution. The #| plot has twelve panels in a 4-row, 3-column layout, showing three types of #| drive train in the horizontal direction, and four numbers of cylinders #| in the vertical direction. Several panels have no data." @@ -63,7 +64,7 @@ You can also use `facet_wrap()` with to facet by two categorical variables. This will only create facets for combinations of the levels of variables for which data exists. ```{r} -#| fig.alt = "A histogram showing the city miles per gallon distribution. The +#| fig.alt: "A histogram showing the city miles per gallon distribution. The #| plot has nine panels in a 3-row, 3-column layout, showing all existing #| combinations of three types of drive train, and four numbers of cylinders." ggplot(mpg, aes(x = cty)) + @@ -77,13 +78,13 @@ In `facet_grid()` these values are determined by the number of levels of the var Similarly, you can also use `facet_grid()` to facet by a single categorical variable as well. In the formula notation, you use a `.` to indicate that no faceting should be done along that axis, i.e. `cyl ~ .` facets across the y-axis (within a column) while `. ~ cyl` facets across the x-axis (within a row). -```{r out.width = "50%"} -#| fig.alt = c( -#| "A histogram showing the city miles per gallon distribution. The plot has -#| four panels in a 4-row, 1-column layout, showing four numbers of cylinders.", -#| "A histogram showing the city miles per gallon distribution. The plot has +```{r} +#| out-width: 50% +#| fig.alt: +#| - "A histogram showing the city miles per gallon distribution. The plot has +#| four panels in a 4-row, 1-column layout, showing four numbers of cylinders." +#| - "A histogram showing the city miles per gallon distribution. The plot has #| four panels in a 1-row, 4-column layout, showing four numbers of cylinders." -#| ) ggplot(mpg, aes(x = cty)) + geom_histogram() + facet_grid(cyl ~ .) @@ -107,7 +108,7 @@ Then, add a `geom_vline()` layer to your plot that uses the summarized data. Suppose you have the following plot, and you want to add a vertical line at the mean value of `hwy` (highway mileage) for each pane. ```{r} -#| fig.alt = "A histogram showing the highway miles per gallon distribution for +#| fig.alt: "A histogram showing the highway miles per gallon distribution for #| three types of drive train, each in their own panel in a 1-row, 3-column #| layout." ggplot(mpg, aes(x = hwy)) + @@ -130,7 +131,7 @@ mpg_summary Then, add a `geom_vline()` layer to your plot that uses the summary data. ```{r} -#| fig.alt = "A histogram showing the highway miles per gallon distribution for +#| fig.alt: "A histogram showing the highway miles per gallon distribution for #| three types of drive train, each in their own panel in a 1-row, 3-column #| layout. Each panel has a vertical black line indicating the mean of the #| distribution." @@ -156,7 +157,7 @@ Suppose you have the following faceted plot. By default, both x and y scales are shared across the facets. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis and +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis and #| highway miles per gallon on the y-axis. The plot has twelve panels in a #| 4-row, 3-column layout, showing three types of drive train in the #| horizontal direction and four numbers of cylinders in the vertical @@ -170,7 +171,7 @@ ggplot(mpg, aes(x = cty, y = hwy)) + You can control this behaviour with the `scales` argument of faceting functions: varying scales across rows (`"free_x"`), columns (`"free_y"`), or both rows and columns (`"free"`), e.g. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis and +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis and #| highway miles per gallon on the y-axis. The plot has twelve panels in a #| 4-row, 3-column layout, showing three types of drive train in the #| horizontal direction and four numbers of cylinders in the vertical @@ -185,7 +186,7 @@ ggplot(mpg, aes(x = cty, y = hwy)) + If you also want to make sure that a particular value or range is included in each of the facets, you can set this with `expand_limits()`, e.g. ensure that 10 is included in the x-axis and values between 20 to 25 are included in the y-axis: ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis and +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis and #| highway miles per gallon on the y-axis. The plot has twelve panels in a #| 4-row, 3-column layout, showing three types of drive train in the #| horizontal direction and four numbers of cylinders in the vertical @@ -213,7 +214,7 @@ Set the `strip.text` element in `theme()` to `element_blank()`. Setting `strip.text` to `element_blank()` will remove all facet labels. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis and +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis and #| highway miles per gallon on the y-axis. The plot has twelve panels in a #| 4-row, 3-column layout. The strips, or panel layout titles and #| their backgrounds, are missing." @@ -226,7 +227,7 @@ ggplot(mpg, aes(x = cty, y = hwy)) + You can also remove the labels across rows only with `strip.x.text` or across columns only with `strip.y.text`. ```{r} -#| fig.alt = "A scatter plot showing city miles per gallon on the x-axis and +#| fig.alt: "A scatter plot showing city miles per gallon on the x-axis and #| highway miles per gallon on the y-axis. The plot has twelve panels in a #| 4-row, 3-column layout. In the vertical direction, the panels indicate four #| numbers of cylinders. The strips of the horizontal direction are missing." @@ -250,7 +251,7 @@ In the data frame below we have 100 observations, 50 of them come from one group These groups have very long names, and so when you facet the ploy by group, the facet labels (strips) get cut off. ```{r} -#| fig.alt = "A histogram with two panels in a 1-row, 2-column layout of random +#| fig.alt: "A histogram with two panels in a 1-row, 2-column layout of random #| data. The first panel has as title 'A long group name for the first group'. #| The second panel has a title 'A muuuuuuuuuuuuuch longer group name for the #| second group'. However, the second title is clipped to the panel width and @@ -269,7 +270,7 @@ ggplot(df, aes(x = x)) + You can control the maximum width of the facet label by setting the `width` in the `label_wrap_gen()` function, which is then passed to the `labeller` argument of your faceting function. ```{r} -#| fig.alt = "A histogram with two panels in a 1-row, 2-column layout of random +#| fig.alt: "A histogram with two panels in a 1-row, 2-column layout of random #| data. The first panel has as title 'A long group name for the first group' #| in two lines of text. The second panel has a title 'A muuuuuuuuuuuuuch #| longer group name for the second group' in three lines of text. The width @@ -304,8 +305,9 @@ df You can plot `price` versus `time` and facet by `country`, but the resulting plot can be a bit difficult to read due to the shared y-axis label. -```{r warning = FALSE} -#| fig.alt = "A timeseries plot showing price over time for two countries, Japan +```{r} +#| warning: false +#| fig.alt: "A timeseries plot showing price over time for two countries, Japan #| and the US, in two panels in a 2-row, 1-column layout. The countries are #| indicated at the top of each panel. The two y-axes have different ranges." ggplot(df, aes(x = year, y = price)) + @@ -317,7 +319,7 @@ ggplot(df, aes(x = year, y = price)) + With the following you can customize the facet labels first with `as_labeller()`, turn off the default y-axis label, and then place the facet labels where the y-axis label goes (`"outside"` and on the `"left"`). ```{r} -#| fig.alt = "A timeseries plot showing price over time for two countries and +#| fig.alt: "A timeseries plot showing price over time for two countries and #| their currencies, the Japanese Yen and the US Dollar, in two panels in a #| 2-row, 1-column layout. The countries and currency units are indicated at #| the left of each panel. The two y-axes have different ranges." diff --git a/vignettes/articles/faq-reordering.Rmd b/vignettes/articles/faq-reordering.Rmd index 39584e225d..964dd6ba08 100644 --- a/vignettes/articles/faq-reordering.Rmd +++ b/vignettes/articles/faq-reordering.Rmd @@ -13,7 +13,8 @@ title: "FAQ: Reordering" } ``` -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) library(dplyr) library(tibble) @@ -44,7 +45,7 @@ Classes are ordered alphabetically. You might prefer them to be ordered by the number of cars in each class. ```{r} -#| fig.alt = "A horizontal bar plot showing counts on the x-axis and seven +#| fig.alt: "A horizontal bar plot showing counts on the x-axis and seven #| types of cars on the y-axis. From bottom to top, the car types are in #| alphabetical order." ggplot(mpg, aes(y = class)) + @@ -54,7 +55,7 @@ ggplot(mpg, aes(y = class)) + To do this, you can use `forcats::fct_infreq()`. ```{r} -#| fig.alt = "A horizontal bar plot showing counts on the x-axis and seven +#| fig.alt: "A horizontal bar plot showing counts on the x-axis and seven #| types of cars on the y-axis. From top to bottom, the car types are ordered #| by increasing number of cars." ggplot(mpg, aes(y = forcats::fct_infreq(class))) + @@ -64,7 +65,7 @@ ggplot(mpg, aes(y = forcats::fct_infreq(class))) + If you'd like to plot the highest value first, you can also reverse the order with `forcats::fct_rev()`. You might also want to simplify the axis label. ```{r} -#| fig.alt = "A horizontal bar plot showing counts on the x-axis and seven +#| fig.alt: "A horizontal bar plot showing counts on the x-axis and seven #| types of cars on the y-axis. From top to bottom, the car types are ordered #| in decreasing number of cars." ggplot(mpg, aes(y = forcats::fct_rev(forcats::fct_infreq(class)))) + @@ -86,7 +87,7 @@ The forcats package offers a variety of options for doing this, such as `forcats Suppose you have the following stacked bar plot of `clarity` of `diamonds` by their `cut`. ```{r} -#| fig.alt = "A stacked bar plot showing counts on the y-axis and five cut +#| fig.alt: "A stacked bar plot showing counts on the y-axis and five cut #| qualities of diamonds on the x-axis. Within every stacked bar, the fill #| colour indicates an ordinal clarity of the diamond. The worst clarity has #| the darkest colour and the best quality has the lightest colour. The best @@ -99,7 +100,7 @@ You can reverse the order `clarity` levels are displayed in the bars with `forca This will also change the order they're presented in the legend so the two orders match. ```{r} -#| fig.alt = "A stacked bar plot showing counts on the y-axis and five cut +#| fig.alt: "A stacked bar plot showing counts on the y-axis and five cut #| qualities of diamonds on the x-axis. Within every stacked bar, the fill #| colour indicates an ordinal clarity of the diamond. The worst clarity has #| the lightest colour and the best quality has the darkest colour. The worst @@ -126,7 +127,7 @@ The order of the boxes is determined by the order of the levels of the variable If the faceting variable is character, this order is alphabetical by default. ```{r} -#| fig.alt = "A boxplot showing the highway miles per gallon on the y-axis for +#| fig.alt: "A boxplot showing the highway miles per gallon on the y-axis for #| seven types of car on the x-axis. The car types on the x-axis are in #| alphabetical order." ggplot(mpg, aes(x = class, y = hwy)) + @@ -138,7 +139,7 @@ You can do this in a data transformation step prior to plotting (e.g. with `dply You might then want to customize the x-axis label as well. ```{r} -#| fig.alt = "A boxplot showing the highway miles per gallon on the y-axis for +#| fig.alt: "A boxplot showing the highway miles per gallon on the y-axis for #| seven types of car on the x-axis. The car types on the x-axis sorted from #| left to right by increasing medians." ggplot(mpg, aes(x = forcats::fct_reorder(class, hwy, .fun = median), y = hwy)) + @@ -163,7 +164,7 @@ The order of the panes is determined by the order of the levels of the variable If the faceting variable is character, this order is alphabetical by default. ```{r} -#| fig.alt = "A scatter plot showing the engine displacement on the x-axis and +#| fig.alt: "A scatter plot showing the engine displacement on the x-axis and #| highway miles per gallon on the y-axis of 234 cars. The plot has three #| panels in a 1-row, 3-column layout for three types of drive train. The drive #| trains are ordered alphabetically in the horizontal direction." @@ -177,7 +178,7 @@ You can use `forcats::fct_relevel()` to reorder the levels of `drv`. You can do this in a data transformation step prior to plotting (e.g. with `dplyr::mutate()`) or you can do it directly in the plotting code as shown below. ```{r} -#| fig.alt = "A scatter plot showing the engine displacement on the x-axis and +#| fig.alt: "A scatter plot showing the engine displacement on the x-axis and #| highway miles per gallon on the y-axis of 234 cars. The plot has three #| panels in a 1-row, 3-column layout for three types of drive train. The drive #| trains are in the order 'r', 'f' and '4' from left to right." @@ -210,12 +211,12 @@ df <- tibble::tribble( ) ``` -By default, this is how a scatterplot of these looks. +By default, this is how a scatter plot of these looks. Note that the blue circle is partially covered by the yellow triangle since that observation comes later in the dataset. Similarly the black asterisk appears on top of the red square. ```{r} -#| fig.alt = "A scatter plot showing four points at the same y-positions but at +#| fig.alt: "A scatter plot showing four points at the same y-positions but at #| four x-positions, of which two are very distinct. Every point has a distinct #| shape and colour. A yellow triangle is plotted on top of a blue circle. #| A black asterisk is plotted on top of a red square." @@ -229,7 +230,7 @@ Suppose you arranged your data in ascending order of the x-coordinates and plott Now the blue circle is over the yellow triangle since 0.01 comes after 0 and similarly the red square is over the black asterisk since 1 comes after 0.99. ```{r} -#| fig.alt = "A scatter plot showing four points at the same y-positions but at +#| fig.alt: "A scatter plot showing four points at the same y-positions but at #| four x-positions, of which two are very distinct. Every point has a distinct #| shape and colour. A blue circle is plotted on top of a yellow triangle. A #| red square is plotted on top of a black asterisk." @@ -245,16 +246,15 @@ df_arranged %>% If you wanted to make sure that the observation identified with an asterisk is always plotted on top, regardless of how the data are arranged in the data frame, you can create an additional layer for that observation. ```{r} -#| fig.alt = c( -#| "A scatter plot showing four points at the same y-positions but at four +#| fig.alt: +#| - "A scatter plot showing four points at the same y-positions but at four #| x-positions, of which two are very distinct. Every point has a distinct shape #| and colour. A yellow triangle is plotted on top of a blue circle. A black -#| asterisk is plotted on top of a red square.", -#| "A scatter plot showing four points at the same y-positions but at four +#| asterisk is plotted on top of a red square." +#| - "A scatter plot showing four points at the same y-positions but at four #| x-positions, of which two are very distinct. Every point has a distinct shape #| and colour. A blue circle is plotted on top of a yellow triangle. A black #| asterisk is plotted on top of a red square." -#| ) ggplot(mapping = aes(x = x, y = y, fill = fill, shape = shape)) + geom_point(data = df %>% filter(shape != "asterisk"), size = 8) + diff --git a/vignettes/extending-ggplot2.Rmd b/vignettes/extending-ggplot2.Rmd index f5815ac3a2..6204321605 100644 --- a/vignettes/extending-ggplot2.Rmd +++ b/vignettes/extending-ggplot2.Rmd @@ -9,7 +9,8 @@ vignette: > %\VignetteEncoding{UTF-8} --- -```{r, include = FALSE} +```{r} +#| include: false knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, fig.height = 7, fig.align = "center") library(ggplot2) ``` @@ -28,7 +29,8 @@ It's strange to say, but this is a case where inventing a new OO system was actu Here's a quick demo of ggproto in action: -```{r ggproto-intro} +```{r} +#| label: ggproto-intro A <- ggproto("A", NULL, x = 1, inc = function(self) { @@ -53,7 +55,8 @@ To create a new geom or stat, you will just create a new ggproto that inherits f We'll start by creating a very simple stat: one that gives the convex hull (the _c_ hull) of a set of points. First we create a new ggproto object that inherits from `Stat`: -```{r chull} +```{r} +#| label: chull StatChull <- ggproto("StatChull", Stat, compute_group = function(data, scales) { data[chull(data$x, data$y), , drop = FALSE] @@ -86,7 +89,7 @@ stat_chull <- function(mapping = NULL, data = NULL, geom = "polygon", Once we have a layer function we can try our new stat: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The convex hull of all the points is marked by a #| polygon with no fill." ggplot(mpg, aes(displ, hwy)) + @@ -99,7 +102,7 @@ ggplot(mpg, aes(displ, hwy)) + Once we've written this basic object, ggplot2 gives a lot for free. For example, ggplot2 automatically preserves aesthetics that are constant within each group: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The convex hulls of points, grouped and coloured by #| three types of drive train, are marked by polygons with no fill but the #| outline matches the colours of the points." @@ -111,7 +114,7 @@ ggplot(mpg, aes(displ, hwy, colour = drv)) + We can also override the default geom to display the convex hull in a different way: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The points that are part of the convex hull of all #| points are marked with a red outline." ggplot(mpg, aes(displ, hwy)) + @@ -124,7 +127,7 @@ ggplot(mpg, aes(displ, hwy)) + A more complex stat will do some computation. Let's implement a simple version of `geom_smooth()` that adds a line of best fit to a plot. We create a `StatLm` that inherits from `Stat` and a layer function, `stat_lm()`: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. A straight line with a negative slope passes through #| the cloud of points." StatLm <- ggproto("StatLm", Stat, @@ -159,7 +162,7 @@ ggplot(mpg, aes(displ, hwy)) + `StatLm` is inflexible because it has no parameters. We might want to allow the user to control the model formula and the number of points used to generate the grid. To do so, we add arguments to the `compute_group()` method and our wrapper function: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. A wobbly line follows the point cloud over the #| horizontal direction. 20 points are placed on top of the line with constant #| horizontal intervals." @@ -224,13 +227,12 @@ Sometimes you have calculations that should be performed once for the complete d To do this we override the `setup_params()` method. It's passed the data and a list of params, and returns an updated list. ```{r} -#| fig.alt = c( -#| "A line plot showing three kernel density estimates of engine displacement, +#| fig.alt: +#| - "A line plot showing three kernel density estimates of engine displacement, #| coloured for three types of drive trains. The lines are a little bit -#| wobbly.", -#| "A line plot showing three kernel density estimates of engine displacement, +#| wobbly." +#| - "A line plot showing three kernel density estimates of engine displacement, #| coloured for three types of drive trains. The lines are fairly smooth." -#| ) StatDensityCommon <- ggproto("StatDensityCommon", Stat, required_aes = "x", @@ -278,7 +280,7 @@ I recommend using `NULL` as a default value. If you pick important parameters au This stat illustrates another important point. If we want to make this stat usable with other geoms, we should return a variable called `density` instead of `y`. Then we can set up the `default_aes` to automatically map `density` to `y`, which allows the user to override it to use with different geoms: ```{r} -#| fig.alt = "A plot showing the engine displacement versus three types of drive +#| fig.alt: "A plot showing the engine displacement versus three types of drive #| trains. Every drive train is represented by a series of densely packed #| points that imitate a horizontal line, and their colour intensity indicates #| the kernel density estimate of the displacement." @@ -299,7 +301,7 @@ ggplot(mpg, aes(displ, drv, colour = after_stat(density))) + However, using this stat with the area geom doesn't work quite right. The areas don't stack on top of each other: ```{r} -#| fig.alt = "An area plot showing the kernel density estimates of +#| fig.alt: "An area plot showing the kernel density estimates of #| engine displacement. Three areas are shown that indicate the estimates for #| three types of drive trains separately. All areas are floored to the x-axis #| and overlap one another." @@ -310,16 +312,15 @@ ggplot(mpg, aes(displ, fill = drv)) + This is because each density is computed independently, and the estimated `x`s don't line up. We can resolve that issue by computing the range of the data once in `setup_params()`. ```{r} -#| fig.alt = c( -#| "A stacked area plot showing kernel density estimates of engine displacement. +#| fig.alt: +#| - "A stacked area plot showing kernel density estimates of engine displacement. #| Three areas are shown that indicate the estimates for three types of drive #| trains separately. The areas are stacked on top of one another and show -#| no overlap.", -#| "A heatmap showing the density of engine displacement for three types of +#| no overlap." +#| - "A heatmap showing the density of engine displacement for three types of #| drive trains. The heatmap has three rows for the drive trains, but are #| continuous in the horizontal direction. The fill intensity of the heatmap #| shows the kernel density estimates." -#| ) StatDensityCommon <- ggproto("StatDensityCommon", Stat, required_aes = "x", default_aes = aes(y = after_stat(density)), @@ -376,8 +377,9 @@ It's harder to create a new geom than a new stat because you also need to know s It's easiest to start with a simple example. The code below is a simplified version of `geom_point()`: -```{r GeomSimplePoint} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +```{r} +#| label: GeomSimplePoint +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The points are larger than the default." GeomSimplePoint <- ggproto("GeomSimplePoint", Geom, required_aes = c("x", "y"), @@ -441,7 +443,7 @@ Overriding `draw_panel()` is most appropriate if there is one graphic element pe The following code makes a simplified version of `GeomPolygon`: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The convex hulls of points, grouped by 7 types of #| cars, are displayed as multiple polygons with no fill, but the outer line is #| coloured by the type." @@ -512,7 +514,7 @@ You might want to compare this to the real `GeomPolygon`. You'll see it override Sometimes you just want to make a small modification to an existing geom. In this case, rather than inheriting from `Geom` you can inherit from an existing subclass. For example, we might want to change the defaults for `GeomPolygon` to work better with `StatChull`: ```{r} -#| fig.alt = "Scatterplot of engine displacement versus highway miles per +#| fig.alt: "Scatterplot of engine displacement versus highway miles per #| gallon, for 234 cars. The convex hull of all the points is marked by a #| polygon with no fill." GeomPolygonHollow <- ggproto("GeomPolygonHollow", GeomPolygon, @@ -627,13 +629,13 @@ title | `element_text()` | all text in title elements (plot, axes & lege These set default properties that are inherited by more specific settings. These are most useful for setting an overall "background" colour and overall font settings (e.g. family and size). -```{r axis-line-ex} -#| fig.alt = c( -#| "Scatterplot of three observations arranged diagonally. The axis titles 'x' -#| and 'y' are coloured in black", -#| "Scatterplot of three observations arranged diagonally. The axis titles 'x' +```{r} +#| label: axis-line-ex +#| fig.alt: +#| - "Scatterplot of three observations arranged diagonally. The axis titles 'x' +#| and 'y' are coloured in black" +#| - "Scatterplot of three observations arranged diagonally. The axis titles 'x' #| and 'y' are coloured in red" -#| ) df <- data.frame(x = 1:3, y = 1:3) base <- ggplot(df, aes(x, y)) + geom_point() + @@ -724,11 +726,7 @@ render <- function(panels, layout, x_scales, y_scales, ranges, coord, data, panel_table <- gtable::gtable_matrix("layout", panels, widths = unit(c(1, 1), "null"), heights = unit(1, "null"), clip = "on") # Add spacing according to theme - panel_spacing <- if (is.null(theme$panel.spacing.x)) { - theme$panel.spacing - } else { - theme$panel.spacing.x - } + panel_spacing <- calc_element("panel.spacing.x", theme) panel_table <- gtable::gtable_add_col_space(panel_table, panel_spacing) } else { panels <- matrix(panels, ncol = 1) @@ -813,11 +811,10 @@ FacetDuplicate <- ggproto("FacetDuplicate", Facet, Now with everything assembled, lets test it out: ```{r} -#| fig.alt = c( -#| "Scatterplot showing horsepower against miles per gallon for 32 cars.", -#| "Scatterplot with two panels showing horsepower against miles per gallon for +#| fig.alt: +#| - "Scatterplot showing horsepower against miles per gallon for 32 cars." +#| - "Scatterplot with two panels showing horsepower against miles per gallon for #| 32 cars. The left and right panels are identical." -#| ) p <- ggplot(mtcars, aes(x = hp, y = mpg)) + geom_point() p p + facet_duplicate() @@ -909,21 +906,13 @@ FacetTrans <- ggproto("FacetTrans", Facet, panel_table <- gtable::gtable_matrix("layout", panels, widths = unit(c(1, 1), "null"), heights = unit(1, "null"), clip = "on") # Add spacing according to theme - panel_spacing <- if (is.null(theme$panel.spacing.x)) { - theme$panel.spacing - } else { - theme$panel.spacing.x - } + panel_spacing <- calc_element("panel.spacing.x", theme) panel_table <- gtable::gtable_add_col_space(panel_table, panel_spacing) } else { panels <- matrix(panels, ncol = 1) panel_table <- gtable::gtable_matrix("layout", panels, widths = unit(1, "null"), heights = unit(c(1, 1), "null"), clip = "on") - panel_spacing <- if (is.null(theme$panel.spacing.y)) { - theme$panel.spacing - } else { - theme$panel.spacing.y - } + panel_spacing <- calc_element("panel.spacing.y", theme) panel_table <- gtable::gtable_add_row_space(panel_table, panel_spacing) } # Name panel grobs so they can be found later @@ -1017,7 +1006,7 @@ As is very apparent, the `draw_panel` method can become very unwieldy once it be Enough talk - lets see if our new and powerful faceting extension works: ```{r} -#| fig.alt = "Scatterplot with two panels showing horsepower against miles per +#| fig.alt: "Scatterplot with two panels showing horsepower against miles per #| gallon for 32 cars. Both panels show the same datapoints. The left panel is #| titled 'original' and the right panel is titled 'transformed (sqrt)'. On the #| right panel, the miles per gallon are displayed on a square root @@ -1030,7 +1019,7 @@ ggplot(mtcars, aes(x = hp, y = mpg)) + geom_point() + facet_trans('sqrt') As the rendering part of a facet class is often the difficult development step, it is possible to piggyback on the existing faceting classes to achieve a range of new facetings. Below we will subclass `facet_wrap()` to make a `facet_bootstrap()` class that splits the input data into a number of panels at random. ```{r} -#| fig.alt = "Scatterplot with three-by-three panels showing the weight versus +#| fig.alt: "Scatterplot with three-by-three panels showing the weight versus #| the price of about 10.000 diamonds in every panel. The panels are titled 1 #| to 9 and show different points, but are visually similar." @@ -1054,11 +1043,7 @@ FacetBootstrap <- ggproto("FacetBootstrap", FacetWrap, dims <- wrap_dims(params$n, params$nrow, params$ncol) layout <- data.frame(PANEL = factor(id)) - if (params$as.table) { - layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L) - } else { - layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2]) - } + layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L) layout$COL <- as.integer((id - 1L) %% dims[2] + 1L) layout <- layout[order(layout$PANEL), , drop = FALSE] @@ -1170,7 +1155,8 @@ guide_key <- function( Our new guide can now be used inside the `guides()` function or as the `guide` argument in a position scale. -```{r key_example} +```{r} +#| label: key_example #| fig.alt: > #| Scatterplot of engine displacement versus highway miles per #| gallon. The x-axis axis ticks are at 2.5, 3.5, 4.5, 5.5 and 6.5. @@ -1194,7 +1180,8 @@ We'll edit the method so that the labels are drawn with a `colour` set in the ke In addition to the `key` and `params` variable we've seen before, we now also have an `elements` variable, which is a list of precomputed theme elements. We can use the `elements$text` element to draw a graphical object (grob) in the style of axis text. Perhaps the most finicky thing about drawing guides is that a lot of settings depend on the guide's `position` parameter. -```{r key_ggproto_edit} +```{r} +#| label: key_ggproto_edit # Same as before GuideKey <- ggproto( "Guide", GuideAxis, @@ -1225,7 +1212,8 @@ GuideKey <- ggproto( Because we are incorporating the `...` argument to `guide_key()` in the key, adding a `colour` column to the key is straightforward. We can check that are guide looks correct in the different positions around the panel. -```{r key_example_2} +```{r} +#| label: key_example_2 #| fig.alt: > #| Scatterplot of engine displacement versus highway miles per #| gallon. There are two x-axes at the bottom and top of the plot. The bottom diff --git a/vignettes/ggplot2-in-packages.Rmd b/vignettes/ggplot2-in-packages.Rmd index 27196b1dea..fb40d8ba44 100644 --- a/vignettes/ggplot2-in-packages.Rmd +++ b/vignettes/ggplot2-in-packages.Rmd @@ -9,7 +9,8 @@ vignette: > %\VignetteEncoding{UTF-8} --- -```{r, include = FALSE} +```{r} +#| include: false knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.show = "hide") library(ggplot2) ``` @@ -28,7 +29,8 @@ mpg_drv_summary <- function() { } ``` -```{r, include=FALSE} +```{r} +#| include: false # make sure this function runs! mpg_drv_summary() ``` @@ -44,7 +46,8 @@ mpg_drv_summary <- function() { } ``` -```{r, include=FALSE} +```{r} +#| include: false # make sure this function runs! mpg_drv_summary() ``` @@ -100,7 +103,8 @@ col_summary(mpg, "drv", "year") If the column name or expression is supplied by the user, you can also pass it to `aes()` or `vars()` using `{{ col }}`. This tidy eval operator captures the expression supplied by the user and forwards it to another tidy eval-enabled function such as `aes()` or `vars()`. -```{r, eval = (packageVersion("rlang") >= "0.3.4.9003")} +```{r} +#| eval: !expr (packageVersion("rlang") >= "0.3.4.9003") col_summary <- function(df, col, by) { ggplot(df) + geom_bar(aes(y = {{ col }})) + @@ -190,21 +194,17 @@ theme_custom <- function(...) { mpg_drv_summary() + theme_custom() ``` -It is important that the theme be calculated after the package is loaded. If not, the theme object is stored in the compiled bytecode of the built package, which may or may not align with the installed version of ggplot2! If your package has a default theme for its visualizations, the correct way to load it is to have a function that returns the default theme: +It is important that the theme be calculated after the package is loaded. If not, a theme object —stored as a variable in the built package— may or may not align with the installed version of ggplot2! If your package has a default theme for its visualizations, the correct way to apply this theme is by calling the constructor: ```{r} -default_theme <- function() { - theme_custom() -} - mpg_drv_summary2 <- function() { - mpg_drv_summary() + default_theme() + mpg_drv_summary() + theme_custom() } ``` ### Testing ggplot2 output -We suggest testing the output of ggplot2 in using the [vdiffr](https://cran.r-project.org/package=vdiffr) package, which is a tool to manage visual test cases (this is one of the ways we test ggplot2). If changes in ggplot2 or your code introduce a change in the visual output of a ggplot, tests will fail when you run them locally or as part of a Continuous Integration setup. To use vdiffr, make sure you are using [testthat](https://testthat.r-lib.org/) (you can use `usethis::use_testthat()` to get started) and add vdiffr to `Suggests` in your `DESCRIPTION`. Then, use `vdiffr::expect_doppleganger(, )` to make a test that fails if there are visual changes in ``. However, you should consider whether visual testing is the best strategy because it adds a dependency on how ggplot2 performs its rendering which may change between versions. If extracting the layer data using `layer_data()` and testing the values directly is possible it is far better as it more directly test the behaviour of your own code. +We suggest testing the output of ggplot2 in using the [vdiffr](https://cran.r-project.org/package=vdiffr) package, which is a tool to manage visual test cases (this is one of the ways we test ggplot2). If changes in ggplot2 or your code introduce a change in the visual output of a ggplot, tests will fail when you run them locally or as part of a Continuous Integration setup. To use vdiffr, make sure you are using [testthat](https://testthat.r-lib.org/) (you can use `usethis::use_testthat()` to get started) and add vdiffr to `Suggests` in your `DESCRIPTION`. Then, use `vdiffr::expect_doppleganger(, )` to make a test that fails if there are visual changes in ``. However, you should consider whether visual testing is the best strategy because it adds a dependency on how ggplot2 performs its rendering which may change between versions. If extracting the layer data using `get_layer_data()` and testing the values directly is possible it is far better as it more directly test the behaviour of your own code. ```r test_that("output of ggplot() is stable", { @@ -225,14 +225,16 @@ theme_custom <- function(...) { } ``` -```{r, include=FALSE} +```{r} +#| include: false # make sure this function runs! mpg_drv_summary() + theme_custom() ``` Generally, if you add a method for a ggplot2 generic like `autoplot()`, ggplot2 should be in `Imports`. If for some reason you would like to keep ggplot2 in `Suggests`, it is possible to register your generics only if ggplot2 is installed using `vctrs::s3_register()`. If you do this, you should copy and paste the source of `vctrs::s3_register()` into your own package to avoid adding a [vctrs](https://vctrs.r-lib.org/) dependency. -```{r, eval=FALSE} +```{r} +#| eval: false .onLoad <- function(...) { if (requireNamespace("ggplot2", quietly = TRUE)) { vctrs::s3_register("ggplot2::autoplot", "discrete_distr") diff --git a/vignettes/ggplot2-specs.Rmd b/vignettes/ggplot2-specs.Rmd index bc7761763c..21d90e12af 100644 --- a/vignettes/ggplot2-specs.Rmd +++ b/vignettes/ggplot2-specs.Rmd @@ -9,7 +9,8 @@ vignette: > %\VignetteEncoding{UTF-8} --- -```{r, include = FALSE} +```{r} +#| include: false library(ggplot2) knitr::opts_chunk$set(fig.dpi = 96, collapse = TRUE, comment = "#>") ``` @@ -53,7 +54,7 @@ Line types can be specified with: 4 = dotdash, 5 = longdash, 6 = twodash, as shown below: ```{r} - #| fig.alt = "A series of 6 horizontal lines with different line types. + #| fig.alt: "A series of 6 horizontal lines with different line types. #| From top-to-bottom they are titled 'solid', 'dashed', 'dotted', #| 'dotdash', 'longdash', 'twodash'." lty <- c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash") @@ -76,7 +77,7 @@ Line types can be specified with: three off followed by one on and finally three off. ```{r} - #| fig.alt = "A series of 9 horizontal lines with different line types. + #| fig.alt: "A series of 9 horizontal lines with different line types. #| Each line is titled by two hexadecimal digits that determined the #| lengths of dashes and gaps." lty <- c("11", "18", "1f", "81", "88", "8f", "f1", "f8", "ff") @@ -106,17 +107,18 @@ with this mistake. * The appearance of the line end is controlled by the `lineend` paramter, and can be one of "round", "butt" (the default), or "square". - ```{r, out.width = "30%", fig.show = "hold"} - #| fig.alt = c( - #| "A plot showing a line with an angle. A thinner red line is placed over - #| a thicker black line. The black line ends where the red line ends.", - #| "A plot showing a line with an angle. A thinner red line is placed over + ```{r} + #| out-width: 30% + #| fig-show: hold + #| fig.alt: + #| - "A plot showing a line with an angle. A thinner red line is placed over + #| a thicker black line. The black line ends where the red line ends." + #| - "A plot showing a line with an angle. A thinner red line is placed over #| a thicker black line. The black line ends past where the red line ends, - #| and ends in a semicircle.", - #| "A plot showing a line with an angle. A thinner red line is placed over + #| and ends in a semicircle." + #| - "A plot showing a line with an angle. A thinner red line is placed over #| a thicker black line. The black line ends past where the red line ends, #| and ends in a square shape." - #| ) df <- data.frame(x = 1:3, y = c(4, 1, 9)) base <- ggplot(df, aes(x, y)) + xlim(0.5, 3.5) + ylim(0, 10) base + @@ -135,16 +137,17 @@ with this mistake. * The appearance of line joins is controlled by `linejoin` and can be one of "round" (the default), "mitre", or "bevel". - ```{r, out.width = "30%", fig.show = "hold"} - #| fig.alt = c( - #| "A plot showing a thin red line on top of a thick black line shaped like - #| the letter 'V'. The corner in the black V-shape is rounded.", - #| "A plot showing a thin red line on top of a thick black line shaped like - #| the letter 'V'. The corner in the black V-shape is sharp.", - #| "A plot showing a thin red line on top of a thick black line shaped like + ```{r} + #| out-width: 30% + #| fig-show: hold + #| fig.alt: + #| - "A plot showing a thin red line on top of a thick black line shaped like + #| the letter 'V'. The corner in the black V-shape is rounded." + #| - "A plot showing a thin red line on top of a thick black line shaped like + #| the letter 'V'. The corner in the black V-shape is sharp." + #| - "A plot showing a thin red line on top of a thick black line shaped like #| the letter 'V'. A piece of the corner is cut off so that the two #| straight parts are connected by a horizontal part." - #| ) df <- data.frame(x = 1:3, y = c(9, 1, 9)) base <- ggplot(df, aes(x, y)) + ylim(0, 10) base + @@ -175,7 +178,7 @@ Shapes take five types of values: * An __integer__ in $[0, 25]$: ```{r} - #| fig.alt = "A 5-by-5 grid of point symbols annotated by the numbers + #| fig.alt: "A 5-by-5 grid of point symbols annotated by the numbers #| that can be used to represent the symbols. From left to right, the #| first 15 symbols are lines or open shapes, the next 5 symbols are solid #| shapes and the last 5 symbols are filled shaped." @@ -194,8 +197,11 @@ Shapes take five types of values: * The __name__ of the shape: - ```{r out.width = "90%", fig.asp = 0.4, fig.width = 8} - #| fig.alt = "An irregular 6-by-7 grid of point symbols annotated by the + ```{r} + #| out-width: 90% + #| fig-asp: 0.4 + #| fig-width: 8 + #| fig.alt: "An irregular 6-by-7 grid of point symbols annotated by the #| names that can be used to represent the symbols. Broadly, from top to #| bottom, the symbols are circles, squares, diamonds, triangles and #| others. Broadly from left to right, the symbols are solid shapes, @@ -230,10 +236,10 @@ Shapes take five types of values: ### Colour and fill -Note that shapes 21-24 have both stroke `colour` and a `fill`. The size of the filled part is controlled by `size`, the size of the stroke is controlled by `stroke`. Each is measured in mm, and the total size of the point is the sum of the two. Note that the size is constant along the diagonal in the following figure. +While `colour` applies to all shapes, `fill` only applies to shapes 21-25, as can be seen above. The size of the filled part is controlled by `size`, the size of the stroke is controlled by `stroke`. Each is measured in mm, and the total size of the point is the sum of the two. Note that the size is constant along the diagonal in the following figure. ```{r} -#| fig.alt = "A plot showing a 4-by-4 grid of red points, the top 12 points with +#| fig.alt: "A plot showing a 4-by-4 grid of red points, the top 12 points with #| black outlines. The size of the points increases horizontally. The stroke of #| the outlines of the points increases vertically. A white diagonal line with #| a negative slope marks that the 'stroke' versus 'size' trade-off has @@ -245,6 +251,8 @@ ggplot(sizes, aes(size, stroke, size = size, stroke = stroke)) + scale_size_identity() ``` +Because points are not typically filled, you may need to change some default settings when using these shapes and mapping `fill`. In particular, discrete `fill` guides will be drawn with an unfilled shape unless overridden (refer to `geom_point()` for an example of this). + ## Text ### Font family @@ -252,7 +260,7 @@ ggplot(sizes, aes(size, stroke, size = size, stroke = stroke)) + There are only three fonts that are guaranteed to work everywhere: "sans" (the default), "serif", or "mono": ```{r} -#| fig.alt = "A plot showing three text labels arranged vertically. The top +#| fig.alt: "A plot showing three text labels arranged vertically. The top #| label is 'sans' and is displayed in a sans-serif font. The middle label is #| 'serif' and is displayed in a serif font. The bottom label is 'mono' and #| is displayed in a monospaced font." @@ -272,7 +280,7 @@ Both approaches have pros and cons, so you will to need to try both of them and ### Font face ```{r} -#| fig.alt = "A plot showing four text labels arranged vertically. The top +#| fig.alt: "A plot showing four text labels arranged vertically. The top #| label is 'bold.italic' and is displayed in bold and italic. The next three #| labels are 'italic', 'bold' and 'plain' and are displayed in their #| respective styles." @@ -294,7 +302,7 @@ Horizontal and vertical justification have the same parameterisation, either a s * left = 0, center = 0.5, right = 1 ```{r} -#| fig.alt = "A 3-by-3 grid of text on top of points, with horizontal text +#| fig.alt: "A 3-by-3 grid of text on top of points, with horizontal text #| justification increasing from 0 to 1 on the x-axis and vertical #| justification increasing from 0 to 1 on the y-axis. The points make it #| easier to see the relative placement of text." diff --git a/vignettes/ggplot2.Rmd b/vignettes/ggplot2.Rmd index f82f092df8..988bbd8310 100644 --- a/vignettes/ggplot2.Rmd +++ b/vignettes/ggplot2.Rmd @@ -9,7 +9,8 @@ vignette: > %\VignetteEncoding{UTF-8} --- -```{r, include = FALSE} +```{r} +#| include: false knitr::opts_chunk$set( collapse = TRUE, comment = "#>" @@ -22,8 +23,10 @@ This allows you to 'speak' a graph from composable elements, instead of being li More complete information about how to use ggplot2 can be found in the [book](https://ggplot2-book.org/), but here you'll find a brief overview of the plot components and some terse examples to build a plot like this: -```{r cake, echo = FALSE} -#| fig.alt = "Scatterplot of city versus highway miles per gallon, for many cars +```{r} +#| label: cake +#| echo: false +#| fig.alt: "Scatterplot of city versus highway miles per gallon, for many cars #| coloured by engine displacement. The plot has six panels in a 2-row, #| 3-column layout, showing the combinations of three types of drive train and #| year of manifacture. Every panel has an individual trendline." @@ -40,8 +43,10 @@ ggplot(mpg, aes(cty, hwy)) + For structure, we go over the 7 composable parts that come together as a set of instructions on how to draw a chart. -```{r overview_graphic, echo=FALSE} -#| fig.alt = "A schematic displaying seven overlaying rhombuses indicating the +```{r} +#| label: overview_graphic +#| echo: false +#| fig.alt: "A schematic displaying seven overlaying rhombuses indicating the #| different composable parts. From bottom to top, the labels read 'Data', #| 'Mapping', 'Layers', 'Scales', 'Facets', 'Coordinates' and 'Theme'." n <- 7 @@ -81,7 +86,9 @@ The system works best if the data is provided in a [tidy](https://tidyr.tidyvers As the first step in many plots, you would pass the data to the `ggplot()` function, which stores the data to be used later by other parts of the plotting system. For example, if we intend to make a graphic about the `mpg` dataset, we would start as follows: -```{r example_data, fig.show='hide'} +```{r} +#| label: example_data +#| fig-show: hide ggplot(data = mpg) ``` @@ -92,7 +99,9 @@ The [mapping](https://ggplot2-book.org/getting-started.html#aesthetics) of a plo A mapping can be made by using the `aes()` function to make pairs of graphical attributes and parts of the data. If we want the `cty` and `hwy` columns to map to the x- and y-coordinates in the plot, we can do that as follows: -```{r example_mapping, fig.show='hide'} +```{r} +#| label: example_mapping +#| fig-show: hide ggplot(mpg, mapping = aes(x = cty, y = hwy)) ``` @@ -107,8 +116,10 @@ Every layer consists of three important parts: A layer can be constructed using the `geom_*()` and `stat_*()` functions. These functions often determine one of the three parts of a layer, while the other two can still be specified. Here is how we can use two layers to display the `cty` and `hwy` columns of the `mpg` dataset as points and stack a trend line on top. -```{r example_layer, fig.show='hold'} -#| fig.alt = "A scatterplot showing city versus highway miles per gallon for +```{r} +#| label: example_layer +#| fig-show: hold +#| fig.alt: "A scatterplot showing city versus highway miles per gallon for #| many cars. The plot has a blue trendline with a positive slope." ggplot(mpg, aes(cty, hwy)) + # to create a scatterplot @@ -124,8 +135,9 @@ Scales are responsible for updating the limits of a plot, setting the breaks, fo To use scales, one can use one of the scale functions that are patterned as `scale_{aesthetic}_{type}()` functions, where `{aesthetic}` is one of the pairings made in the mapping part of a plot. To map the `class` column in the `mpg` dataset to the viridis colour palette, we can write the following: -```{r example_scales} -#| fig.alt = "A scatterplot showing city versus highway miles per gallon for +```{r} +#| label: example_scales +#| fig.alt: "A scatterplot showing city versus highway miles per gallon for #| many cars. The points are coloured according to seven classes of cars." ggplot(mpg, aes(cty, hwy, colour = class)) + geom_point() + @@ -140,8 +152,9 @@ It is a powerful tool to quickly split up the data into smaller panels, based on The facets have their own mapping that can be given as a formula. To plot subsets of the `mpg` dataset based on levels of the `drv` and `year` variables, we can use `facet_grid()` as follows: -```{r example_facets} -#| fig.alt = "Scatterplot of city versus highway miles per gallon, for many cars. +```{r} +#| label: example_facets +#| fig.alt: "Scatterplot of city versus highway miles per gallon, for many cars. #| The plot has six panels in a 2-row, 3-column layout, showing the #| combinations of three types of drive train and year of manifacture." ggplot(mpg, aes(cty, hwy)) + @@ -156,8 +169,9 @@ While typically Cartesian coordinates are used, the coordinate system powers the We can also use coordinates to display a plot with a fixed aspect ratio so that one unit has the same length in both the x and y directions. The `coord_fixed()` function sets this ratio automatically. -```{r example_coords} -#| fig.alt = "A scatterplot showing city versus highway miles per gallon for +```{r} +#| label: example_coords +#| fig.alt: "A scatterplot showing city versus highway miles per gallon for #| many cars. The aspect ratio of the plot is such that units on the x-axis #| have the same length as units on the y-axis." ggplot(mpg, aes(cty, hwy)) + @@ -171,8 +185,9 @@ The [theme](https://ggplot2-book.org/themes) system controls almost any visuals To tweak the look of the plot, one can use many of the built-in `theme_*()` functions and/or detail specific aspects with the `theme()` function. The `element_*()` functions control the graphical attributes of theme components. -```{r example_theme} -#| fig.alt = "A scatterplot showing city versus highway miles per gallon for +```{r} +#| label: example_theme +#| fig.alt: "A scatterplot showing city versus highway miles per gallon for #| many cars. The points are coloured according to seven classes of cars. The #| legend of the colour is displayed on top of the plot. The plot has thick #| axis lines and the bottom axis line is blue." @@ -190,8 +205,9 @@ ggplot(mpg, aes(cty, hwy, colour = class)) + As mentioned at the start, you can layer all of the pieces to build a customized plot of your data, like the one shown at the beginning of this vignette: -```{r outro} -#| fig.alt = "Scatterplot of city versus highway miles per gallon, for many cars +```{r} +#| label: outro +#| fig.alt: "Scatterplot of city versus highway miles per gallon, for many cars #| coloured by engine displacement. The plot has six panels in a 2-row, #| 3-column layout, showing the combinations of three types of drive train and #| year of manifacture. Every panel has an individual trendline." diff --git a/vignettes/profiling.Rmd b/vignettes/profiling.Rmd index a0a77340df..d08f8e5a26 100644 --- a/vignettes/profiling.Rmd +++ b/vignettes/profiling.Rmd @@ -10,7 +10,9 @@ vignette: > %\VignetteEncoding{UTF-8} --- -```{r setup, include = FALSE} +```{r} +#| label: setup +#| include: false knitr::opts_chunk$set( collapse = TRUE, comment = "#>" @@ -33,7 +35,9 @@ profile <- profvis(for (i in seq_len(100)) ggplotGrob(p)) profile ``` -```{r, eval=FALSE, include=FALSE} +```{r} +#| eval: false +#| include: false saveRDS(profile, file.path('profilings', paste0(packageVersion('ggplot2'), '.rds'))) ```