├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ ├── R-CMD-check.yaml │ └── test-coverage.yaml ├── tests ├── testthat │ ├── .gitignore │ ├── _snaps │ │ ├── scale_colour_multi.md │ │ ├── scale_fill_multi.md │ │ ├── geom_outline_point.md │ │ ├── facet_manual.md │ │ ├── strips.md │ │ ├── facetted_pos_scales.md │ │ ├── facet_grid2.md │ │ └── scale_listed.md │ ├── test-themes.R │ ├── test-deprecated.R │ ├── test-stat_rle.R │ ├── test-strip_tag.R │ ├── test-conveniences.R │ ├── test-geom_text_aimed.R │ ├── test-save.R │ ├── test-utils.R │ ├── test-stat_rollingkernel.R │ ├── test-stat_difference.R │ ├── test-geom_outline_point.R │ ├── test-element_part_rect.R │ ├── test-geom_pointpath.R │ ├── test-coord_axes_inside.R │ ├── test-guide_stringlegend.R │ ├── test-help_secondary.R │ ├── test-geom_box.R │ ├── test-geom_polygonraster.R │ ├── test-scale_facet.R │ ├── test-stat_funxy.R │ ├── test-facet_manual.R │ ├── test-facet_nested_wrap.R │ ├── test-facet_grid2.R │ ├── test-facet_wrap2.R │ ├── test-geom_rectmargin.R │ ├── test-position_lineartrans.R │ ├── test-position_disjoint_ranges.R │ └── test-strips.R └── testthat.R ├── vignettes ├── .gitignore └── ggh4x.Rmd ├── LICENSE ├── man ├── figures │ ├── logo.png │ ├── logo_300px.png │ ├── README-facets-1.png │ ├── README-multicolour-1.png │ ├── lifecycle-defunct.svg │ ├── lifecycle-archived.svg │ ├── lifecycle-maturing.svg │ ├── lifecycle-questioning.svg │ ├── lifecycle-deprecated.svg │ ├── lifecycle-superseded.svg │ ├── lifecycle-experimental.svg │ └── lifecycle-stable.svg ├── center_limits.Rd ├── sep_discrete.Rd ├── ggh4x-package.Rd ├── deprecated.Rd ├── strip_vanilla.Rd ├── ggh4x_extensions.Rd ├── weave_factors.Rd ├── element_part_rect.Rd ├── theme_extensions.Rd ├── at_panel.Rd ├── guide_stringlegend.Rd ├── scale_listed.Rd ├── position_disjoint_ranges.Rd ├── strip_tag.Rd ├── scale_fill_multi.Rd ├── force_panelsizes.Rd ├── distribute_args.Rd ├── save_plot.Rd ├── coord_axes_inside.Rd ├── strip_nested.Rd ├── strip_themed.Rd ├── scale_facet.Rd ├── strip_split.Rd ├── facetted_pos_scales.Rd └── help_secondary.Rd ├── pkgdown └── favicon │ ├── favicon.ico │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ ├── apple-touch-icon.png │ ├── apple-touch-icon-60x60.png │ ├── apple-touch-icon-76x76.png │ ├── apple-touch-icon-120x120.png │ ├── apple-touch-icon-152x152.png │ └── apple-touch-icon-180x180.png ├── .gitignore ├── cran-comments.md ├── codecov.yml ├── .Rbuildignore ├── ggh4x.Rproj ├── R ├── ggh4x_extensions.R ├── ggh4x-package.R ├── utils_grid.R ├── themes.R ├── utils.R ├── save.R ├── guide_stringlegend.R ├── at_panel.R ├── deprecated.R ├── facet_nested_wrap.R ├── geom_polygonraster.R ├── utils_gtable.R ├── geom_outline_point.R ├── stat_difference.R ├── stat_funxy.R ├── position_disjoint_ranges.R └── stat_rle.R ├── LICENSE.md ├── CODE_OF_CONDUCT.md ├── _pkgdown.yml ├── DESCRIPTION └── NAMESPACE /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /tests/testthat/.gitignore: -------------------------------------------------------------------------------- 1 | Rplots.pdf 2 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2021 2 | COPYRIGHT HOLDER: Teun van den Brand 3 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(ggh4x) 3 | 4 | test_check("ggh4x") 5 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /man/figures/logo_300px.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/man/figures/logo_300px.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/favicon.ico -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | tests/testthat/*.pdf 6 | inst/doc 7 | docs 8 | -------------------------------------------------------------------------------- /man/figures/README-facets-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/man/figures/README-facets-1.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /man/figures/README-multicolour-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/man/figures/README-multicolour-1.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-60x60.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon-60x60.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-76x76.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon-76x76.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-120x120.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon-120x120.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-152x152.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon-152x152.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-180x180.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/teunbrand/ggh4x/HEAD/pkgdown/favicon/apple-touch-icon-180x180.png -------------------------------------------------------------------------------- /tests/testthat/_snaps/scale_colour_multi.md: -------------------------------------------------------------------------------- 1 | # scale_colour_multi throws error when guide inappropriate 2 | 3 | ggh4x's author hasn't programmed this path yet. 4 | i Choose a legend or colourbar guide. 5 | 6 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/scale_fill_multi.md: -------------------------------------------------------------------------------- 1 | # scale_fill_multi throws error when guide inappropriate 2 | 3 | ggh4x's author hasn't programmed this path yet. 4 | i Choose a legend or colourbar guide. 5 | 6 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | No problems were detected in a reverse dependency tests across a total of 27 packages (23 from CRAN, 4 from Bioconductor). 2 | Functionality has been stripped from functions that were deprecated in the previous release. 3 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | patch: 10 | default: 11 | target: auto 12 | threshold: 1% 13 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^ggh4x\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^LICENSE\.md$ 4 | ^README\.Rmd$ 5 | ^CODE_OF_CONDUCT\.md$ 6 | ^codecov\.yml$ 7 | ^_pkgdown\.yml$ 8 | ^docs$ 9 | ^pkgdown$ 10 | ^\.github$ 11 | ^cran-comments\.md$ 12 | ^CRAN-RELEASE$ 13 | ^CRAN-SUBMISSION$ 14 | ^revdep$ 15 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/geom_outline_point.md: -------------------------------------------------------------------------------- 1 | # geom_outline_point draws outlines 2 | 3 | Code 4 | pnl[[1]]$col 5 | Output 6 | [1] "#CB4D42" "#00989D" 7 | 8 | --- 9 | 10 | Code 11 | pnl[[2]]$col 12 | Output 13 | [1] "#F8766D" "#00BFC4" 14 | 15 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/facet_manual.md: -------------------------------------------------------------------------------- 1 | # facet_manual rejects some designs 2 | 3 | The `design` argument should be interpretable as a . 4 | 5 | --- 6 | 7 | The `design` argument must be rectangular. 8 | 9 | --- 10 | 11 | The `design` argument cannot be NULL. 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/strips.md: -------------------------------------------------------------------------------- 1 | # strip_vanilla rejects faulty arguments 2 | 3 | `clip` must be one of "on", "off", or "inherit", not "nonsense". 4 | 5 | --- 6 | 7 | `size` must be one of "constant" or "variable", not "nonsense". 8 | 9 | # strip_themed rejects faulty theme elements 10 | 11 | The `background_x` argument should be a list of objects. 12 | 13 | --- 14 | 15 | The `text_y` argument should be a list of objects. 16 | 17 | -------------------------------------------------------------------------------- /ggh4x.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: No 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --as-cran 22 | PackageRoxygenize: rd,collate,namespace,vignette 23 | -------------------------------------------------------------------------------- /R/ggh4x_extensions.R: -------------------------------------------------------------------------------- 1 | #' @name ggh4x_extensions 2 | #' 3 | #' @title ggh4x extensions to ggplot2 4 | #' 5 | #' @description ggh4x relies on the extension mechanism of ggplot2 through 6 | #' ggproto class objects, which allows cross-package inheritance of objects 7 | #' such as geoms, stats, facets, scales and coordinate systems. These objects 8 | #' can be ignored by users for the purpose of making plots, since interacting 9 | #' with these objects is preferred through various geom_, stat_, facet_, 10 | #' coord_ and scale_ functions. 11 | #' 12 | #' @seealso [ggproto][ggplot2::ggproto] 13 | NULL 14 | -------------------------------------------------------------------------------- /R/ggh4x-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | #' @importFrom stats setNames rt dcauchy dnorm dunif ccf coef lm 5 | #' @importFrom utils head tail getFromNamespace 6 | #' @import rlang 7 | #' @import vctrs 8 | #' @import ggplot2 9 | #' @import scales 10 | #' @import grid 11 | #' @import gtable 12 | NULL 13 | 14 | # The following block is used by usethis to automatically manage 15 | # roxygen namespace tags. Modify with care! 16 | ## usethis namespace: start 17 | #' @importFrom cli cli_abort 18 | #' @importFrom lifecycle deprecated 19 | #' @importFrom stats median 20 | ## usethis namespace: end 21 | NULL 22 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/facetted_pos_scales.md: -------------------------------------------------------------------------------- 1 | # facetted_pos_scales warns about invalid scales 2 | 3 | The `x` argument should be "NULL", or a list of formulas and/or position scales with the x aesthetic. 4 | 5 | --- 6 | 7 | The `y` argument should be "NULL", or a list of formulas and/or position scales with the y aesthetic. 8 | 9 | # facetted_pos_scales warns about invalid scales in formulas 10 | 11 | The right-hand side of formula does not result in an appropriate scale. 12 | 13 | # facetted_pos_scales warns about unusual facets 14 | 15 | Unknown facet: a object. 16 | i Overriding facetted scales may be unstable. 17 | 18 | -------------------------------------------------------------------------------- /tests/testthat/test-themes.R: -------------------------------------------------------------------------------- 1 | test_that("theme elements are loaded by default", { 2 | tree <- get_element_tree() 3 | expect_true(sum(grepl("ggh4x.facet", names(tree))) > 0) 4 | }) 5 | 6 | 7 | test_that("theme elements can be removed", { 8 | reset_theme_settings() 9 | tree <- get_element_tree() 10 | expect_equal(sum(grepl("ggh4x.facet", names(tree))), 0) 11 | }) 12 | 13 | test_that("theme elements can be set again", { 14 | reset_theme_settings() 15 | tree <- get_element_tree() 16 | expect_equal(sum(grepl("ggh4x.facet", names(tree))), 0) 17 | ggh4x_theme_elements() 18 | tree <- get_element_tree() 19 | expect_true(sum(grepl("ggh4x.facet", names(tree))) > 0) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test-deprecated.R: -------------------------------------------------------------------------------- 1 | test_that("defunct functions throw deprecation messages", { 2 | lifecycle::expect_deprecated(guide_axis_manual()) 3 | lifecycle::expect_deprecated(guide_axis_truncated()) 4 | lifecycle::expect_deprecated(guide_axis_color()) 5 | lifecycle::expect_deprecated(guide_axis_colour()) 6 | lifecycle::expect_deprecated(guide_axis_minor()) 7 | lifecycle::expect_deprecated(guide_axis_nested()) 8 | lifecycle::expect_deprecated(guide_axis_scalebar()) 9 | lifecycle::expect_deprecated(guide_dendro()) 10 | lifecycle::expect_deprecated(scale_x_dendrogram()) 11 | lifecycle::expect_deprecated(scale_y_dendrogram()) 12 | lifecycle::expect_defunct(ggsubset()) 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/facet_grid2.md: -------------------------------------------------------------------------------- 1 | # facet_grid2 warns about inappropriate arguments 2 | 3 | x cannot be independent if scales are not free. 4 | 5 | --- 6 | 7 | y cannot be independent if scales are not free. 8 | 9 | --- 10 | 11 | x cannot have free space if axes are independent. 12 | i Overriding `space` for x to "FALSE". 13 | 14 | --- 15 | 16 | y cannot have free space if axes are independent. 17 | i Overriding `space` for y to "FALSE". 18 | 19 | --- 20 | 21 | x-axes must be labelled if they are independent. 22 | i Overriding `remove_labels` for x to "FALSE". 23 | 24 | --- 25 | 26 | y-axes must be labelled if they are independent. 27 | i Overriding `remove_labels` for y to "FALSE". 28 | 29 | -------------------------------------------------------------------------------- /R/utils_grid.R: -------------------------------------------------------------------------------- 1 | # Splits a list of grobs and reports max height in cm per level 2 | split_heights_cm <- function(grobs, split) { 3 | vals <- lapply(grobs, grobHeight) 4 | vals <- vapply(vals, convertHeight, numeric(1), 5 | unitTo = "cm", valueOnly = TRUE) 6 | vals <- unname(vapply(split(vals, split, drop = TRUE), max, numeric(1))) 7 | unit(vals, "cm") 8 | } 9 | 10 | # Splits a list of grobs and reports max width in cm per level 11 | split_widths_cm <- function(grobs, split) { 12 | vals <- lapply(grobs, grobWidth) 13 | vals <- vapply(vals, convertWidth, numeric(1), 14 | unitTo = "cm", valueOnly = TRUE) 15 | vals <- unname(vapply(split(vals, split, drop = TRUE), max, numeric(1))) 16 | unit(vals, "cm") 17 | } 18 | -------------------------------------------------------------------------------- /tests/testthat/test-stat_rle.R: -------------------------------------------------------------------------------- 1 | test_that("stat_rle constructor gives correct object", { 2 | x <- stat_rle() 3 | expect_s3_class(x, "LayerInstance") 4 | expect_s3_class(x$geom, "GeomRect") 5 | expect_s3_class(x$stat, "StatRle") 6 | expect_named(x$stat_params, c("na.rm", "orientation", "align")) 7 | }) 8 | 9 | test_that("stat_rle calculates runlengths correctly", { 10 | df <- data.frame( 11 | x = 1:30, 12 | y = c(rep(LETTERS[1:5], 5:1), rep(LETTERS[6:10], 1:5)), 13 | grp = rep(LETTERS[1:2], each = 15), 14 | stringsAsFactors = FALSE 15 | ) 16 | 17 | g <- ggplot(df) + 18 | stat_rle(aes(x = x, label = y, group = grp)) 19 | 20 | ld <- layer_data(g) 21 | expect_identical(ld$runlength, c(5:1, 1:5)) 22 | expect_identical(ld$runvalue, LETTERS[1:10]) 23 | }) 24 | -------------------------------------------------------------------------------- /tests/testthat/test-strip_tag.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | test_that("strip_tag works as intended", { 4 | 5 | p <- ggplot(mpg, aes(displ, hwy)) + 6 | geom_point() 7 | 8 | gt <- ggplotGrob( 9 | p + facet_wrap2(~ year + drv, strip = strip_tag(just = c(0.5, 1))) 10 | ) 11 | grob <- gt$grobs[[which(gt$layout$name == "strip-1")]] 12 | expect_equal(as.character(grob$widths), "1npc") 13 | expect_equal(as.character(grob$heights), c("0.5npc", "0.5npc")) 14 | 15 | expect_equal(as.numeric(grob$vp$width), 1.015, tolerance = 1e-3) 16 | expect_equal(as.numeric(grob$vp$height), 1.214, tolerance = 1e-3) 17 | 18 | grob <- grob$grobs[[1]] 19 | expect_s3_class(grob$children[[1]], "rect") 20 | expect_s3_class(grob$children[[2]], "titleGrob") 21 | expect_equal(grob$children[[2]]$children[[1]]$label, "1999") 22 | 23 | }) 24 | 25 | -------------------------------------------------------------------------------- /tests/testthat/test-conveniences.R: -------------------------------------------------------------------------------- 1 | test_that("elem_list_rect constructs a list of rect elements", { 2 | x <- elem_list_rect(colour = list(c("green", "blue"), "red"), 3 | nonense_argument = "Hell, no") 4 | 5 | expect_equal( 6 | x, 7 | list( 8 | element_rect(colour = c("green", "blue")), 9 | element_rect(colour = "red") 10 | ) 11 | ) 12 | 13 | }) 14 | 15 | test_that("elem_list_text constructs a list of text elements", { 16 | x <- elem_list_text(colour = c("green", "blue"), 17 | margin = list(NULL, margin(t = 5)), 18 | nonense_argument = "Hell, no") 19 | 20 | expect_equal( 21 | x, 22 | list( 23 | element_text(colour = "green"), 24 | element_text(colour = "blue", margin = margin(t = 5)) 25 | ) 26 | ) 27 | 28 | }) 29 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/scale_listed.md: -------------------------------------------------------------------------------- 1 | # scale_listed throws error if scalelist and replaces unequal length 2 | 3 | The `replaces` argument must be parallel to and of the same length as the `scalelist` argument. 4 | 5 | # scale_listed throws error when replaces has invalid aes 6 | 7 | The aesthetics in the `replaces` argument must be valid aesthetics. 8 | 9 | # scale_listed throws error when non-scales are supplied as scalelist 10 | 11 | The `scalelist` argument must have valid objects as list-elements. 12 | 13 | # scale_listed throws error when multiple aesthetics are supplied in a scale 14 | 15 | `scale_listed()` can only accept 1 aesthetic per scale. 16 | 17 | # scale_lsited throws error when empty aesthetics are supplied in a scale 18 | 19 | Every scale in the `scalelist` argument must have set valid aesthetics. 20 | 21 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_text_aimed.R: -------------------------------------------------------------------------------- 1 | test_that("geom_text_aimed aims text", { 2 | tmpfile <- tempfile() 3 | png(tmpfile) # Angles are off otherwise 4 | 5 | df <- data.frame( 6 | x = c(1, 1, -1, -1), 7 | y = c(1, -1, -1, 1), 8 | xend = 0, yend = 0, 9 | label = LETTERS[1:4] 10 | ) 11 | 12 | p <- ggplot(df, aes(x, y, xend = xend, yend = yend, label = label)) + 13 | theme(aspect.ratio = 1) 14 | 15 | grob <- layer_grob(p + geom_text_aimed())[[1]] 16 | 17 | expect_s3_class(grob, "aimed_text") 18 | expect_equal(grob$rot, c(0, 0, 0, 0)) 19 | 20 | rotgrob <- makeContent(grob) 21 | expect_equal(rotgrob$rot, c(315, 45, 315, 45)) 22 | 23 | grob <- layer_grob(p + geom_text_aimed(flip_upsidedown = FALSE))[[1]] 24 | rotgrob <- makeContent(grob) 25 | expect_equal(rotgrob$rot, c(315, 45, 135, 225)) 26 | dev.off() 27 | unlink(tmpfile) 28 | }) 29 | -------------------------------------------------------------------------------- /tests/testthat/test-save.R: -------------------------------------------------------------------------------- 1 | test_that("save_plot computes correct size", { 2 | 3 | p <- ggplot(mpg, aes(displ, hwy)) + 4 | geom_point() + 5 | guides(x = guide_none(NULL), y = guide_none(NULL)) + 6 | theme(plot.margin = margin(1, 1, 1, 1, unit = "in")) 7 | 8 | tmp <- tempfile(fileext = ".png") 9 | 10 | f <- suppressMessages(save_plot(tmp, plot = p)) 11 | expect_equal(attr(f, "width"), NA_real_) 12 | expect_equal(attr(f, "height"), NA_real_) 13 | 14 | unlink(tmp) 15 | 16 | f <- save_plot(tmp, plot = p, width = 10, height = 5) 17 | expect_equal(attr(f, "width"), 10) 18 | expect_equal(attr(f, "height"), 5) 19 | 20 | unlink(tmp) 21 | 22 | f <- save_plot( 23 | tmp, plot = p + force_panelsizes(rows = unit(8, "in"), cols = unit(3, "in")) 24 | ) 25 | # We add +2 because of margins 26 | expect_equal(attr(f, "width"), 5) 27 | expect_equal(attr(f, "height"), 10) 28 | 29 | unlink(tmp) 30 | }) 31 | -------------------------------------------------------------------------------- /man/figures/lifecycle-defunct.svg: -------------------------------------------------------------------------------- 1 | lifecyclelifecycledefunctdefunct -------------------------------------------------------------------------------- /man/figures/lifecycle-archived.svg: -------------------------------------------------------------------------------- 1 | lifecyclelifecyclearchivedarchived -------------------------------------------------------------------------------- /man/figures/lifecycle-maturing.svg: -------------------------------------------------------------------------------- 1 | lifecyclelifecyclematuringmaturing -------------------------------------------------------------------------------- /man/figures/lifecycle-questioning.svg: -------------------------------------------------------------------------------- 1 | lifecyclelifecyclequestioningquestioning -------------------------------------------------------------------------------- /man/center_limits.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conveniences.R 3 | \name{center_limits} 4 | \alias{center_limits} 5 | \title{Center limits} 6 | \usage{ 7 | center_limits(around = 0) 8 | } 9 | \arguments{ 10 | \item{around}{A \code{numeric} of length 1 indicating around which value to 11 | center the limits.} 12 | } 13 | \value{ 14 | A \code{function} that takes limits and returns expanded limits 15 | centered at the \code{around} argument. 16 | } 17 | \description{ 18 | This a function factory that allows the centering of scales around a certain 19 | value while still including all values. Convenient for centering log2 fold 20 | change limits around zero. 21 | } 22 | \examples{ 23 | center_limits(5)(c(3,8)) 24 | 25 | g <- ggplot(iris, 26 | aes(Sepal.Width, Sepal.Length, 27 | colour = log2(Petal.Width / Petal.Length))) + 28 | geom_point() + 29 | scale_colour_gradient2(limits = center_limits()) 30 | } 31 | -------------------------------------------------------------------------------- /man/sep_discrete.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scale_manual.R 3 | \name{sep_discrete} 4 | \alias{sep_discrete} 5 | \title{Separator for discrete grouped labels} 6 | \usage{ 7 | sep_discrete(sep = ".", inv = FALSE) 8 | } 9 | \arguments{ 10 | \item{sep}{A \code{character(1)} separator to use for splitting. May not contain 11 | regular expressions.} 12 | 13 | \item{inv}{A \code{logical(1)} whether to invert the layering of groups.} 14 | } 15 | \value{ 16 | A \code{function} that accepts \code{character} input and returns 17 | \code{numeric} output. 18 | } 19 | \description{ 20 | This is a function factory that provides a function to split grouped discrete 21 | labels into numerical positions. 22 | } 23 | \examples{ 24 | # Here, 'bar.qux' belongs to the second group, so has +1 value 25 | sep_discrete()(c("foo.bar", "bar.bar", "bar.qux")) 26 | 27 | # Now, the values are grouped by the groups before the separator 28 | sep_discrete(inv = TRUE)(c("foo.bar", "bar.bar", "bar.qux")) 29 | } 30 | -------------------------------------------------------------------------------- /man/ggh4x-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ggh4x-package.R 3 | \docType{package} 4 | \name{ggh4x-package} 5 | \alias{ggh4x} 6 | \alias{ggh4x-package} 7 | \title{ggh4x: Hacks for 'ggplot2'} 8 | \description{ 9 | \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} 10 | 11 | A 'ggplot2' extension that does a variety of little helpful things. The package extends 'ggplot2' facets through customisation, by setting individual scales per panel, resizing panels and providing nested facets. Also allows multiple colour and fill scales per plot. Also hosts a smaller collection of stats, geoms and axis guides. 12 | } 13 | \seealso{ 14 | Useful links: 15 | \itemize{ 16 | \item \url{https://github.com/teunbrand/ggh4x} 17 | \item \url{https://teunbrand.github.io/ggh4x/} 18 | \item Report bugs at \url{https://github.com/teunbrand/ggh4x/issues} 19 | } 20 | 21 | } 22 | \author{ 23 | \strong{Maintainer}: Teun van den Brand \email{tahvdbrand@gmail.com} (\href{https://orcid.org/0000-0002-9335-7468}{ORCID}) 24 | 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | test_that("center_limits centers limits", { 2 | f <- center_limits() 3 | expect_equal(f(c(-1, 3)), c(-3, 3)) 4 | f <- center_limits(1) 5 | expect_equal(f(c(-1, 3)), c(-1, 3)) 6 | }) 7 | 8 | test_that("weave_factors combines factors", { 9 | f1 <- c("banana", "apple", "apple", "kiwi", NA) 10 | f2 <- factor(c(1, NA, 1:3), labels = c("house", "cat", "dog")) 11 | 12 | a <- levels(weave_factors(f1, f2)) 13 | expect_identical(a, c("banana.house", "apple.house", "apple.", "kiwi.cat", ".dog")) 14 | 15 | a <- levels(weave_factors(as.factor(f1), f2)) 16 | expect_identical(a, c("apple.house", "apple.", "banana.house", "kiwi.cat", ".dog")) 17 | 18 | a <- weave_factors(f1, f2, dopr = TRUE) 19 | b <- weave_factors(f1, f2, drop = FALSE) 20 | 21 | expect_length(levels(a), 5) 22 | expect_length(levels(b), 4*4) # f2 NA becomes empty string level 23 | 24 | a <- levels(weave_factors(f1, f2, replaceNA = FALSE)) 25 | expect_identical(a, c("banana.house", "apple.house", "kiwi.cat", "NA.dog")) 26 | 27 | a <- substitute(weave_factors(f1, f2[1:3])) 28 | expect_error(eval(a), "same length") 29 | 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test-stat_rollingkernel.R: -------------------------------------------------------------------------------- 1 | test_that("kernels give correct weights", { 2 | x <- c(-1, 0, 1) 3 | 4 | gaus <- .kernel_norm(x, 2) 5 | cauc <- .kernel_cauchy(x, 2) 6 | unif <- .kernel_unif(x, 2) 7 | 8 | expect_identical(gaus, dnorm(x, sd = 2)) 9 | expect_identical(cauc, dcauchy(x, scale = 2)) 10 | expect_identical(unif, dunif(x, -1, 1)) 11 | expect_equal(length(unique(unif)), 1) 12 | }) 13 | 14 | test_that("stat_rollingkernel constructor gives correct object", { 15 | x <- stat_rollingkernel() 16 | expect_s3_class(x, "LayerInstance") 17 | expect_s3_class(x$geom, "GeomLine") 18 | expect_s3_class(x$stat, "StatRollingkernel") 19 | expect_named(x$stat_params, c("bw", "kernel", "n", "expand", "na.rm", 20 | "orientation")) 21 | }) 22 | 23 | test_that("stat_rollingkernel can build a plot", { 24 | g <- ggplot(mpg, aes(displ, hwy, colour = class)) + 25 | geom_point() + 26 | stat_rollingkernel() 27 | ld <- layer_data(g, 2) 28 | expect_true(all(c("x", "y", "weight", "scaled") %in% names(ld))) 29 | expect_length(ld$x, length(unique(mpg$class)) * g$layers[[2]]$stat_params$n) 30 | }) 31 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2021 Teun van den Brand 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /man/deprecated.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deprecated.R 3 | \name{deprecated} 4 | \alias{deprecated} 5 | \alias{guide_axis_logticks} 6 | \alias{guide_axis_manual} 7 | \alias{guide_axis_minor} 8 | \alias{guide_axis_nested} 9 | \alias{guide_axis_scalebar} 10 | \alias{guide_axis_truncated} 11 | \alias{guide_axis_colour} 12 | \alias{guide_axis_color} 13 | \alias{guide_dendro} 14 | \alias{ggsubset} 15 | \alias{scale_x_dendrogram} 16 | \alias{scale_y_dendrogram} 17 | \title{Deprecated functions} 18 | \usage{ 19 | guide_axis_logticks(...) 20 | 21 | guide_axis_manual(...) 22 | 23 | guide_axis_minor(...) 24 | 25 | guide_axis_nested(...) 26 | 27 | guide_axis_scalebar(...) 28 | 29 | guide_axis_truncated(...) 30 | 31 | guide_axis_colour(...) 32 | 33 | guide_axis_color(...) 34 | 35 | guide_dendro(...) 36 | 37 | ggsubset(...) 38 | 39 | scale_x_dendrogram(...) 40 | 41 | scale_y_dendrogram(...) 42 | } 43 | \arguments{ 44 | \item{...}{Not used.} 45 | } 46 | \value{ 47 | None, raises deprecation signal 48 | } 49 | \description{ 50 | The functions listed here are deprecated and no longer work. 51 | } 52 | \examples{ 53 | # None 54 | } 55 | -------------------------------------------------------------------------------- /tests/testthat/test-stat_difference.R: -------------------------------------------------------------------------------- 1 | test_that("stat_difference calculates the difference appropriately", { 2 | df <- data.frame(x = 1:2, 3 | min = 1:2, max = 2:1) 4 | g <- ggplot(df, aes(x, ymin = min, ymax = max)) + 5 | stat_difference() 6 | 7 | ld <- layer_data(g) 8 | expect_equal(ld$x, c(1, 1.5, 1.5, 2)) 9 | expect_equal(ld$ymin, c(1, 1.5, 1.5, 2)) 10 | expect_equal(ld$ymax, c(2, 1.5, 1.5, 1)) 11 | }) 12 | 13 | test_that("stat_difference can be flipped", { 14 | df <- data.frame(y = 1:2, 15 | min = 1:2, max = 2:1) 16 | g <- ggplot(df, aes(y = y, xmin = min, xmax = max)) + 17 | stat_difference() 18 | ld <- layer_data(g) 19 | expect_equal(ld$y, c(1, 1.5, 1.5, 2)) 20 | expect_equal(ld$xmin, c(1, 1.5, 1.5, 2)) 21 | expect_equal(ld$xmax, c(2, 1.5, 1.5, 1)) 22 | }) 23 | 24 | test_that("stat_difference can handle multiple groups", { 25 | df <- data.frame( 26 | x = c(1,2,3,4), 27 | min = c(1,2,1,2), 28 | max = c(2,1,2,1), 29 | group = c(1,1,2,2) 30 | ) 31 | 32 | g <- ggplot(df, aes(x = x, ymin = min, ymax = max, group = group)) + 33 | stat_difference() 34 | ld <- layer_data(g) 35 | expect_equal(ld$group, c(1,1,2,2,3,3,4,4)) 36 | }) 37 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_outline_point.R: -------------------------------------------------------------------------------- 1 | test_that("geom_outline_point draws outlines", { 2 | 3 | df <- data.frame(x = 1:2) 4 | 5 | p <- ggplot(df, aes(x, x, colour = factor(x), stroke_colour = factor(x))) + 6 | geom_outline_point() + 7 | scale_colour_hue(aesthetics = "stroke_colour", l = 50) + 8 | theme_test() 9 | 10 | gt <- ggplotGrob(p) 11 | 12 | pnl <- gt$grobs[gt$layout$name == "panel"][[1]]$children 13 | pnl <- pnl[[which(startsWith(names(pnl), "outline"))]]$children 14 | pnl <- lapply(pnl, `[[`, "gp") 15 | expect_length(pnl, 2) 16 | 17 | expect_snapshot(pnl[[1]]$col) 18 | expect_snapshot(pnl[[2]]$col) 19 | }) 20 | 21 | test_that("geom_outline_point draws keys", { 22 | 23 | data <- data.frame(colour = "#F8766D", 24 | stroke_colour = "#CB4D42", 25 | shape = 16, 26 | size = 1.5, 27 | fill = NA, alpha = NA, stroke = 0.5) 28 | 29 | key <- draw_key_outline_point(data, list(na.rm = FALSE), size = c(6, 6)) 30 | key <- key$children 31 | 32 | expect_length(key, 2) 33 | expect_s3_class(key[[1]], "points") 34 | expect_s3_class(key[[2]], "points") 35 | expect_equal(key[[2]]$gp$col, '#F8766DFF') 36 | expect_equal(key[[1]]$gp$col, "#CB4D42FF") 37 | }) 38 | -------------------------------------------------------------------------------- /man/figures/lifecycle-deprecated.svg: -------------------------------------------------------------------------------- 1 | 2 | lifecycle: deprecated 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | lifecycle 18 | 19 | deprecated 20 | 21 | 22 | -------------------------------------------------------------------------------- /man/figures/lifecycle-superseded.svg: -------------------------------------------------------------------------------- 1 | 2 | lifecycle: superseded 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | lifecycle 18 | 19 | superseded 20 | 21 | 22 | -------------------------------------------------------------------------------- /man/figures/lifecycle-experimental.svg: -------------------------------------------------------------------------------- 1 | 2 | lifecycle: experimental 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | lifecycle 18 | 19 | experimental 20 | 21 | 22 | -------------------------------------------------------------------------------- /tests/testthat/test-element_part_rect.R: -------------------------------------------------------------------------------- 1 | test_that("element_part_rect returns correct class", { 2 | case1 <- element_part_rect(side = "tlbr") 3 | case2 <- element_part_rect(side ="nonsense") 4 | case3 <- element_part_rect(side = "tl") 5 | 6 | expect_false(inherits(case1, "element_part_rect")) 7 | expect_false(inherits(case2, "element_part_rect")) 8 | expect_true(inherits(case3, "element_part_rect")) 9 | }) 10 | 11 | test_that("element_part_rect draws grobs correctly", { 12 | cases <- list( 13 | l = element_part_rect(side = "l"), 14 | r = element_part_rect(side = "r"), 15 | b = element_part_rect(side = "b"), 16 | t = element_part_rect(side = "t") 17 | ) 18 | 19 | grobs <- lapply(cases, element_grob) 20 | grobs <- lapply(grobs, function(grob) { 21 | expect_length(grob$children, 2) 22 | grob$children[[2]] 23 | }) 24 | }) 25 | 26 | test_that("element_part_rect can be used in a ggplot", { 27 | g <- ggplot(iris, aes(Sepal.Width, Sepal.Length)) + 28 | geom_point() + 29 | facet_wrap(~ "Irises!") + 30 | theme( 31 | strip.background = element_part_rect(side = "lrb", colour = "black") 32 | ) 33 | gt <- ggplotGrob(g) 34 | 35 | strip <- gt$grobs[gt$layout$name == "strip-t-1-1"][[1]] 36 | strip <- strip$grobs[[1]]$children 37 | strip <- strip[grepl("background", names(strip))][[1]] 38 | expect_identical(names(strip$children), c("fillgrob", "sidegrob")) 39 | }) 40 | -------------------------------------------------------------------------------- /man/figures/lifecycle-stable.svg: -------------------------------------------------------------------------------- 1 | 2 | lifecycle: stable 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 19 | 20 | lifecycle 21 | 22 | 25 | 26 | stable 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, we pledge to respect all people who 4 | contribute through reporting issues, posting feature requests, updating documentation, 5 | submitting pull requests or patches, and other activities. 6 | 7 | We are committed to making participation in this project a harassment-free experience for 8 | everyone, regardless of level of experience, gender, gender identity and expression, 9 | sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 10 | 11 | Examples of unacceptable behavior by participants include the use of sexual language or 12 | imagery, derogatory comments or personal attacks, trolling, public or private harassment, 13 | insults, or other unprofessional conduct. 14 | 15 | Project maintainers have the right and responsibility to remove, edit, or reject comments, 16 | commits, code, wiki edits, issues, and other contributions that are not aligned to this 17 | Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed 18 | from the project team. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by 21 | opening an issue or contacting one or more of the project maintainers. 22 | 23 | This Code of Conduct is adapted from the Contributor Covenant 24 | (https://www.contributor-covenant.org), version 1.0.0, available at 25 | https://contributor-covenant.org/version/1/0/0/. 26 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | release: 8 | types: [published] 9 | workflow_dispatch: 10 | 11 | name: pkgdown.yaml 12 | 13 | permissions: read-all 14 | 15 | jobs: 16 | pkgdown: 17 | runs-on: ubuntu-latest 18 | # Only restrict concurrency for non-PR jobs 19 | concurrency: 20 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 21 | env: 22 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 23 | permissions: 24 | contents: write 25 | steps: 26 | - uses: actions/checkout@v4 27 | 28 | - uses: r-lib/actions/setup-pandoc@v2 29 | 30 | - uses: r-lib/actions/setup-r@v2 31 | with: 32 | use-public-rspm: true 33 | 34 | - uses: r-lib/actions/setup-r-dependencies@v2 35 | with: 36 | extra-packages: any::pkgdown, local::. 37 | needs: website 38 | 39 | - name: Build site 40 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 41 | shell: Rscript {0} 42 | 43 | - name: Deploy to GitHub pages 🚀 44 | if: github.event_name != 'pull_request' 45 | uses: JamesIves/github-pages-deploy-action@v4.5.0 46 | with: 47 | clean: false 48 | branch: gh-pages 49 | folder: docs 50 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_pointpath.R: -------------------------------------------------------------------------------- 1 | base <- ggplot(pressure, aes(temperature, pressure)) 2 | 3 | test_that("geom_pointpath adds geom to plot", { 4 | g <- base + geom_pointpath() 5 | expect_s3_class(g$layers[[1]]$geom, "GeomPointPath") 6 | # Check inherits GeomPoint 7 | expect_s3_class(g$layers[[1]]$geom, "GeomPoint") 8 | }) 9 | 10 | test_that("geom_pointpath plots can be build", { 11 | g <- base + geom_pointpath() 12 | gt <- ggplotGrob(g) 13 | expect_s3_class(gt, "gtable") 14 | grob <- layer_grob(g)[[1]]$children 15 | expect_s3_class(grob[[2]], "points") 16 | expect_s3_class(grob[[1]], "gapsegments") 17 | }) 18 | 19 | test_that("geom_pointpath makeContext works", { 20 | g <- base + geom_pointpath() 21 | grob <- layer_grob(g)[[1]]$children[[1]] 22 | expect_s3_class(grob, "gapsegments") 23 | out <- grid::makeContext(grob) 24 | expect_s3_class(out, "segments") 25 | }) 26 | 27 | test_that("geom_pointpath plots can be build in polar coordinates", { 28 | g <- base + geom_pointpath() + coord_polar() 29 | gt <- ggplotGrob(g) 30 | expect_s3_class(gt, "gtable") 31 | grob <- layer_grob(g)[[1]]$children 32 | expect_s3_class(grob[[2]], "points") 33 | expect_s3_class(grob[[1]], "gapsegmentschain") 34 | }) 35 | 36 | test_that("geom_pointpath makeContext works with polar coordinates", { 37 | g <- base + geom_pointpath() + coord_polar() 38 | grob <- layer_grob(g)[[1]]$children[[1]] 39 | expect_s3_class(grob, "gapsegmentschain") 40 | out <- grid::makeContext(grob) 41 | expect_s3_class(out, "polyline") 42 | }) 43 | -------------------------------------------------------------------------------- /tests/testthat/test-coord_axes_inside.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("coord_axis_inside can place axes inside", { 3 | 4 | p <- ggplot(mtcars, aes(scale(mpg), scale(disp))) + 5 | geom_point() + 6 | theme_test() + 7 | theme(panel.border = element_blank(), 8 | axis.line = element_line()) 9 | 10 | test <- p + coord_axes_inside(labels_inside = FALSE) 11 | test <- ggplotGrob(test) 12 | 13 | axis <- test$grobs[test$layout$name == "axis-b"][[1]]$children 14 | axis <- axis[names(axis) == "axis"][[1]] 15 | 16 | expect_s3_class(axis$grobs[[1]], "zeroGrob") 17 | expect_s3_class(axis$grobs[[2]], "titleGrob") 18 | 19 | axis <- test$grobs[test$layout$name == "axis-l"][[1]]$children 20 | axis <- axis[names(axis) == "axis"][[1]] 21 | 22 | if (new_guide_system) { 23 | expect_s3_class(axis$grobs[[1]], "zeroGrob") 24 | expect_s3_class(axis$grobs[[2]], "titleGrob") 25 | } else { 26 | expect_s3_class(axis$grobs[[2]], "zeroGrob") 27 | expect_s3_class(axis$grobs[[1]], "titleGrob") 28 | } 29 | 30 | test <- p + coord_axes_inside(labels_inside = TRUE) 31 | test <- ggplotGrob(test) 32 | 33 | axis <- test$grobs[test$layout$name == "axis-b"][[1]]$children 34 | axis <- axis[names(axis) == "axis"][[1]] 35 | 36 | expect_s3_class(axis$grobs[[1]], "zeroGrob") 37 | expect_s3_class(axis$grobs[[2]], "zeroGrob") 38 | 39 | axis <- test$grobs[test$layout$name == "axis-l"][[1]]$children 40 | axis <- axis[names(axis) == "axis"][[1]] 41 | 42 | expect_s3_class(axis$grobs[[2]], "zeroGrob") 43 | expect_s3_class(axis$grobs[[1]], "zeroGrob") 44 | }) 45 | -------------------------------------------------------------------------------- /tests/testthat/test-guide_stringlegend.R: -------------------------------------------------------------------------------- 1 | test_that("guide_stringlegend returns correct object", { 2 | xx <- guide_stringlegend() 3 | expect_s3_class(xx, "GuideStringlegend") 4 | }) 5 | 6 | test_that("guide_stringlegend can be placed in different spots", { 7 | 8 | p <- ggplot(iris, aes(Sepal.Width, Sepal.Length, colour = Species)) + 9 | geom_point() 10 | 11 | test <- p + guides(colour = guide_stringlegend(ncol = 2)) + 12 | theme(legend.position = "right") 13 | gt <- ggplotGrob(test) 14 | box_name <- if (new_guide_system) "guide-box-right" else "guide-box" 15 | extra <- if (new_guide_system) 2 else 0 16 | i <- which(gt$layout$name == box_name) 17 | expect_equal(gt$layout$l[i], 9 + extra) 18 | 19 | test <- p + guides(colour = guide_stringlegend(ncol = 2)) + 20 | theme(legend.position = "bottom") 21 | box_name <- if (new_guide_system) "guide-box-bottom" else "guide-box" 22 | gt <- ggplotGrob(test) 23 | i <- which(gt$layout$name == box_name) 24 | expect_equal(gt$layout$t[i], 11 + extra) 25 | 26 | test <- p + guides(colour = guide_stringlegend()) + 27 | theme(legend.position = "left") 28 | box_name <- if (new_guide_system) "guide-box-left" else "guide-box" 29 | gt <- ggplotGrob(test) 30 | i <- which(gt$layout$name == box_name) 31 | expect_equal(gt$layout$l[i], 3) 32 | 33 | test <- p + guides(colour = guide_stringlegend()) + 34 | theme(legend.position = "top") 35 | box_name <- if (new_guide_system) "guide-box-top" else "guide-box" 36 | gt <- ggplotGrob(test) 37 | i <- which(gt$layout$name == box_name) 38 | expect_equal(gt$layout$t[i], 5) 39 | }) 40 | 41 | -------------------------------------------------------------------------------- /man/strip_vanilla.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/strip_vanilla.R 3 | \name{strip_vanilla} 4 | \alias{strip_vanilla} 5 | \title{Default strips} 6 | \usage{ 7 | strip_vanilla(clip = "inherit", size = "constant") 8 | } 9 | \arguments{ 10 | \item{clip}{A \code{character(1)} that controls whether text labels are clipped to 11 | the background boxes. Can be either \code{"inherit"} (default), \code{"on"} or 12 | \code{"off"}.} 13 | 14 | \item{size}{A \code{character(1)} stating that the strip margins in different 15 | layers remain \code{"constant"} or are \code{"variable"}.} 16 | } 17 | \value{ 18 | A \code{Strip} ggproto object that can be used ggh4x facets. 19 | } 20 | \description{ 21 | Strips with the style of vanilla ggplot2. 22 | } 23 | \examples{ 24 | # Some dummy data with a long string 25 | df <- data.frame( 26 | short = "X", 27 | long = "A very long string that takes up a lot of space", 28 | value = 1 29 | ) 30 | # Simple plot 31 | p <- ggplot(df, aes(value, value)) + 32 | geom_point() + 33 | theme(strip.text.y.right = element_text(angle = 0)) 34 | 35 | # Short titles take up as much space as long titles 36 | p + facet_grid2( 37 | vars(short, long), 38 | strip = strip_vanilla(size = "constant") 39 | ) 40 | 41 | # Short titles take up less space 42 | p + facet_grid2( 43 | vars(short, long), 44 | strip = strip_vanilla(size = "variable") 45 | ) 46 | } 47 | \seealso{ 48 | Other strips: 49 | \code{\link{strip_nested}()}, 50 | \code{\link{strip_split}()}, 51 | \code{\link{strip_tag}()}, 52 | \code{\link{strip_themed}()} 53 | } 54 | \concept{strips} 55 | -------------------------------------------------------------------------------- /tests/testthat/test-help_secondary.R: -------------------------------------------------------------------------------- 1 | test_that("help_secondary does what it is supposed to", { 2 | 3 | sec <- help_secondary() 4 | 5 | expect_s3_class(sec, "AxisSecondary") 6 | 7 | formals <- formals(environment(sec$proj)$f) 8 | expect_identical(names(formals), "x") 9 | }) 10 | 11 | test_that("help_sec range transforms correctly", { 12 | x <- -5:5 13 | y <- -10:10 14 | sec <- help_sec_range(x, y) 15 | 16 | expect_identical(sec$forward(range(y)), c(-5, 5)) 17 | expect_identical(sec$reverse(range(x)), c(-10, 10)) 18 | }) 19 | 20 | test_that("help_sec max transforms correctly", { 21 | x <- 5:10 22 | y <- 15:20 23 | sec <- help_sec_max(x, y) 24 | 25 | expect_identical(sec$forward(range(y)), c(7.5, 10)) 26 | expect_identical(sec$reverse(range(x)), c(10, 20)) 27 | }) 28 | 29 | test_that("help_sec sortfit transforms correctly", { 30 | x <- rnorm(20) 31 | y <- 2 + sample(x) * 5 32 | sec <- help_sec_sortfit(x, y) 33 | fit <- environment(sec$forward)$fit 34 | 35 | expect_equal(unname(fit), c(-0.4, 0.2)) 36 | 37 | expect_equal(sort(x), sec$forward(sort(y))) 38 | expect_equal(sort(y), sec$reverse(sort(x))) 39 | }) 40 | 41 | test_that("help_sec ccf transforms correctly", { 42 | z <- seq(0, 4*pi, pi/50) 43 | x <- sin(z) 44 | y <- 2 + sin(z + pi/2) * 5 45 | sec <- help_sec_ccf(x, y) 46 | fit <- environment(sec$forward)$fit 47 | expect_equal(unname(fit), c(-0.4, 0.2), tolerance = 0.05) 48 | 49 | # Test reverse for negative lag 50 | sec <- help_sec_ccf(y, x) 51 | fit <- environment(sec$forward)$fit 52 | expect_equal(unname(fit), c(2, 5), tolerance = 0.05) 53 | }) 54 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | 8 | name: R-CMD-check.yaml 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | R-CMD-check: 14 | runs-on: ${{ matrix.config.os }} 15 | 16 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 17 | 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | config: 22 | - {os: macos-latest, r: 'release'} 23 | - {os: windows-latest, r: 'release'} 24 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 25 | - {os: ubuntu-latest, r: 'release'} 26 | - {os: ubuntu-latest, r: 'oldrel-1'} 27 | 28 | env: 29 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 30 | R_KEEP_PKG_SOURCE: yes 31 | 32 | steps: 33 | - uses: actions/checkout@v4 34 | 35 | - uses: r-lib/actions/setup-pandoc@v2 36 | 37 | - uses: r-lib/actions/setup-r@v2 38 | with: 39 | r-version: ${{ matrix.config.r }} 40 | http-user-agent: ${{ matrix.config.http-user-agent }} 41 | use-public-rspm: true 42 | 43 | - uses: r-lib/actions/setup-r-dependencies@v2 44 | with: 45 | extra-packages: any::rcmdcheck 46 | needs: check 47 | 48 | - uses: r-lib/actions/check-r-package@v2 49 | with: 50 | upload-snapshots: true 51 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 52 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_box.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("boxes can be resolved with partial missing information", { 3 | 4 | ans <- list( 5 | resolve_box(min = 1, max = 3), 6 | resolve_box(min = 1, center = 2), 7 | resolve_box(min = 1, dim = 2), 8 | resolve_box(max = 3, center = 2), 9 | resolve_box(max = 3, dim = 2), 10 | resolve_box(dim = 2, center = 2) 11 | ) 12 | ans <- matrix(unlist(ans), 6, 2, byrow = TRUE) 13 | 14 | expect_equal(ans[, 1], rep(1, nrow(ans))) 15 | expect_equal(ans[, 2], rep(3, nrow(ans))) 16 | }) 17 | 18 | test_that("boxes can be resolved with partial missing information", { 19 | test <- expand.grid( 20 | xmin = c(1, NA), 21 | xmax = c(3, NA), 22 | x = c(2, NA), 23 | width = c(2, NA) 24 | ) 25 | ans <- with(test, resolve_box(xmin, xmax, x, width)) 26 | nas <- rowSums(is.na(test)) 27 | 28 | expect_equal( 29 | ans$min, 30 | ifelse(nas > 2, NA_real_, 1) 31 | ) 32 | expect_equal( 33 | ans$max, 34 | ifelse(nas > 2, NA_real_, 3) 35 | ) 36 | expect_equal(sum(is.na(ans$min)), 5) 37 | expect_equal(sum(is.na(ans$max)), 5) 38 | }) 39 | 40 | test_that("geom_box() builds expected grob", { 41 | 42 | df <- data.frame(xmin = c(NA, 1), x = c(1, 2), xmax = c(2, NA), 43 | ymin = c(1, 2), height = 1) 44 | p <- ggplot(df) + 45 | geom_box(aes(xmin = xmin, xmax = xmax, x = x, 46 | ymin = ymin, height = height), radius = unit(1, "cm"), 47 | fill = c("blue", "green")) 48 | 49 | lg <- layer_grob(p)[[1]] 50 | expect_s3_class(lg, "gTree") 51 | expect_s3_class(lg$children[[1]], "roundrect") 52 | expect_s3_class(lg$children[[2]], "roundrect") 53 | }) 54 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_polygonraster.R: -------------------------------------------------------------------------------- 1 | base <- ggplot(faithfuld, aes(eruptions, waiting, fill = density)) 2 | 3 | test_that("geom_polygonraster has correct class and inheritance", { 4 | g <- base + geom_polygonraster() 5 | g <- g$layers[[1]]$geom 6 | 7 | expect_s3_class(g, "GeomPolygonRaster") 8 | expect_s3_class(g, "GeomRaster") 9 | }) 10 | 11 | test_that("geom_polygonraster outputs correct grob type", { 12 | g <- base + geom_polygonraster() 13 | g <- layer_grob(g)[[1]] 14 | 15 | expect_s3_class(g, "polygon") 16 | expect_s3_class(g, "grob") 17 | }) 18 | 19 | test_that("geom_polygonraster reparameterises raster", { 20 | ctrl <- base + geom_raster() 21 | test <- base + geom_polygonraster() 22 | 23 | ctrl <- layer_data(ctrl) 24 | test <- layer_data(test) 25 | 26 | expect_equal(nrow(ctrl) * 4, nrow(test)) 27 | }) 28 | 29 | # Re-base 30 | 31 | df <- data.frame(x = row(volcano)[T], 32 | y = col(volcano)[T], 33 | z = volcano[T]) 34 | base <- ggplot(df, aes(x, y, fill = z)) 35 | 36 | test_that("geom_polygonraster hjust works", { 37 | test1 <- base + geom_polygonraster(hjust = 0) 38 | test2 <- base + geom_polygonraster(hjust = 1) 39 | 40 | test1 <- layer_data(test1) 41 | test2 <- layer_data(test2) 42 | 43 | expect_identical(test1$y, test2$y) 44 | expect_identical(test1$x + 1, test2$x) 45 | }) 46 | 47 | test_that("geom_polygonraster vjust works", { 48 | test1 <- base + geom_polygonraster(vjust = 0) 49 | test2 <- base + geom_polygonraster(vjust = 1) 50 | 51 | test1 <- layer_data(test1) 52 | test2 <- layer_data(test2) 53 | 54 | expect_identical(test1$y + 1, test2$y) 55 | expect_identical(test1$x, test2$x) 56 | }) 57 | -------------------------------------------------------------------------------- /man/ggh4x_extensions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ggh4x_extensions.R, R/coord_axes_inside.R, 3 | % R/facet_grid2.R, R/facet_wrap2.R, R/facet_manual.R, R/facet_nested.R, 4 | % R/facet_nested_wrap.R, R/geom_box.R, R/geom_pointpath.R, 5 | % R/geom_polygonraster.R, R/geom_rectrug.R, R/geom_text_aimed.R, 6 | % R/guide_stringlegend.R, R/position_disjoint_ranges.R, 7 | % R/position_lineartrans.R, R/stat_difference.R, R/stat_funxy.R, R/stat_rle.R, 8 | % R/stat_roll.R, R/stat_theodensity.R, R/strip_vanilla.R, R/strip_themed.R, 9 | % R/strip_nested.R, R/strip_split.R 10 | \docType{data} 11 | \name{ggh4x_extensions} 12 | \alias{ggh4x_extensions} 13 | \alias{CoordAxesInside} 14 | \alias{FacetGrid2} 15 | \alias{FacetWrap2} 16 | \alias{FacetManual} 17 | \alias{FacetNested} 18 | \alias{FacetNestedWrap} 19 | \alias{GeomBox} 20 | \alias{GeomPointPath} 21 | \alias{GeomPointpath} 22 | \alias{GeomPolygonRaster} 23 | \alias{GeomRectMargin} 24 | \alias{GeomTileMargin} 25 | \alias{GeomTextAimed} 26 | \alias{GuideStringlegend} 27 | \alias{PositionDisjointRanges} 28 | \alias{PositionLinearTrans} 29 | \alias{StatDifference} 30 | \alias{StatFunxy} 31 | \alias{StatRle} 32 | \alias{StatRollingkernel} 33 | \alias{StatTheoDensity} 34 | \alias{Strip} 35 | \alias{StripThemed} 36 | \alias{StripNested} 37 | \alias{StripSplit} 38 | \title{ggh4x extensions to ggplot2} 39 | \description{ 40 | ggh4x relies on the extension mechanism of ggplot2 through 41 | ggproto class objects, which allows cross-package inheritance of objects 42 | such as geoms, stats, facets, scales and coordinate systems. These objects 43 | can be ignored by users for the purpose of making plots, since interacting 44 | with these objects is preferred through various geom_, stat_, facet_, 45 | coord_ and scale_ functions. 46 | } 47 | \seealso{ 48 | \link[ggplot2:ggproto]{ggproto} 49 | } 50 | \keyword{datasets} 51 | -------------------------------------------------------------------------------- /tests/testthat/test-scale_facet.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("scale_(x/y)_facet Error messages are thrown appropriately", { 3 | 4 | expect_error( 5 | scale_x_facet(type = "facet"), 6 | "Cannot circularly define" 7 | ) 8 | 9 | expect_error( 10 | scale_y_facet(type = "nonsense"), 11 | "Cannot find a" 12 | ) 13 | 14 | expect_error( 15 | scale_x_facet(), 16 | "must be a valid" 17 | ) 18 | }) 19 | 20 | test_that("scale_(x/y)_facet can be added to a plot", { 21 | 22 | p <- ggplot(mtcars, aes(disp, mpg)) + 23 | geom_point() 24 | 25 | expect_error( 26 | p + scale_x_facet(COL == 2), 27 | "Try adding facets" 28 | ) 29 | 30 | expect_warning( 31 | p + facet_wrap(~ cyl) + scale_x_facet(COL == 2), 32 | "Attempting to add facetted x scales, while x scales are not free." 33 | ) 34 | 35 | p <- p + facet_wrap(~ cyl, scales = "free") 36 | 37 | expect_s3_class(p$facet, "FacetWrap") 38 | 39 | p <- p + scale_y_facet(COL == 2, limits = c(0, 40)) 40 | 41 | expect_s3_class(p$facet, "FreeScaledFacetWrap") 42 | 43 | expect_s3_class(p$facet$new_y_scales[[1]], "ScaleContinuousPosition") 44 | expect_length(p$facet$new_y_scales, 1L) 45 | expect_identical( 46 | attr(p$facet$new_y_scales, "lhs")[[1]], 47 | rlang::quo(COL == 2) 48 | ) 49 | 50 | p <- p + scale_y_facet(COL == 1, breaks = 1:40) 51 | 52 | expect_s3_class(p$facet$new_y_scales[[2]], "ScaleContinuousPosition") 53 | expect_length(p$facet$new_y_scales, 2L) 54 | expect_length(attr(p$facet$new_y_scales, "lhs"), 2L) 55 | expect_identical( 56 | attr(p$facet$new_y_scales, "lhs")[[2]], 57 | rlang::quo(COL == 1) 58 | ) 59 | 60 | p <- p + scale_x_facet(PANEL == 3, limits = c(0, 500)) 61 | 62 | expect_s3_class(p$facet$new_x_scales[[1]], "ScaleContinuousPosition") 63 | expect_length(p$facet$new_x_scales, 1L) 64 | expect_length(attr(p$facet$new_x_scales, "lhs"), 1L) 65 | 66 | }) 67 | -------------------------------------------------------------------------------- /tests/testthat/test-stat_funxy.R: -------------------------------------------------------------------------------- 1 | test_that("stat_funxy et al. constructors give correct objects", { 2 | x <- stat_funxy() 3 | expect_s3_class(x, "LayerInstance") 4 | expect_s3_class(x$geom, "GeomPoint") 5 | expect_s3_class(x$stat, "StatFunxy") 6 | 7 | x <- stat_centroid() 8 | expect_s3_class(x$stat, "StatFunxy") 9 | x <- x$stat_params 10 | expect_equal(x$funx, mean) 11 | expect_equal(x$funy, mean) 12 | expect_equal(x$argx, list(na.rm = TRUE)) 13 | expect_equal(x$argy, list(na.rm = TRUE)) 14 | 15 | x <- stat_midpoint() 16 | expect_s3_class(x$stat, "StatFunxy") 17 | }) 18 | 19 | test_that("stat_centroid calculates centroids", { 20 | g <- ggplot(iris, aes(Sepal.Width, Sepal.Length, group = Species)) + 21 | stat_centroid() 22 | g <- layer_data(g) 23 | 24 | ctrl <- aggregate(iris[,1:4], iris["Species"], mean) 25 | expect_equal(g$x, ctrl$Sepal.Width) 26 | expect_equal(g$y, ctrl$Sepal.Length) 27 | }) 28 | 29 | test_that("stat_midpoint calculates midpoints", { 30 | g <- ggplot(iris, aes(Sepal.Width, Sepal.Length, group = Species)) + 31 | stat_midpoint() 32 | g <- layer_data(g) 33 | 34 | ctrl <- aggregate(iris[,1:4], iris["Species"], function(x){mean(range(x))}) 35 | expect_equal(g$x, ctrl$Sepal.Width) 36 | expect_equal(g$y, ctrl$Sepal.Length) 37 | }) 38 | 39 | test_that("stat_funxy throws appropriate errors", { 40 | xpr <- substitute(stat_funxy(funx = 10)) 41 | expect_error(eval(xpr), "must be a function") 42 | xpr <- substitute(stat_funxy(funy = 10)) 43 | expect_error(eval(xpr), "must be a function") 44 | xpr <- substitute(stat_funxy(argx = c(na.rm = TRUE))) 45 | expect_error(eval(xpr), "must be lists") 46 | xpr <- substitute(stat_funxy(argx = list(10))) 47 | expect_error(eval(xpr), "must have named elements") 48 | xpr <- substitute(stat_funxy(argy = list(10))) 49 | expect_error(eval(xpr), "must have named elements") 50 | }) 51 | -------------------------------------------------------------------------------- /man/weave_factors.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conveniences.R 3 | \name{weave_factors} 4 | \alias{weave_factors} 5 | \title{Bind together factors} 6 | \usage{ 7 | weave_factors(..., drop = TRUE, sep = ".", replaceNA = TRUE) 8 | } 9 | \arguments{ 10 | \item{...}{The vectors} 11 | 12 | \item{drop}{A \code{logical} of length 1 which when \code{TRUE} will remove 13 | combinations of factors not occurring in the input data.} 14 | 15 | \item{sep}{A \code{character} of length 1 with a string to delimit the new 16 | level labels.} 17 | 18 | \item{replaceNA}{A \code{logical} of length 1: replace \code{NA} values with 19 | empty strings?} 20 | } 21 | \value{ 22 | A \code{factor} representing combinations of input factors. 23 | } 24 | \description{ 25 | Computes a new factor out of combinations of input factors. 26 | } 27 | \details{ 28 | \code{weave_factors()} broadly resembles \code{interaction(..., lex.order = TRUE)}, with a slightly altered approach to non-factor inputs. 29 | In other words, this function orders the new levels such that the levels of 30 | the first input variable in \code{...} is given priority over the second 31 | input, the second input has priority over the third, etc. 32 | 33 | This function treats non-factor inputs as if their levels were 34 | \code{unique(as.character(x))}, wherein \code{x} represents an input. 35 | } 36 | \examples{ 37 | f1 <- c("banana", "apple", "apple", "kiwi") 38 | f2 <- factor(c(1, 1:3), labels = c("house", "cat", "dog")) 39 | 40 | # Notice the difference in level ordering between the following: 41 | interaction(f1, f2, drop = TRUE, lex.order = TRUE) 42 | interaction(f1, f2, drop = TRUE, lex.order = FALSE) 43 | weave_factors(f1, f2) 44 | 45 | # The difference is in how characters are interpreted 46 | # The following are equivalent 47 | interaction(f1, f2, drop = TRUE, lex.order = TRUE) 48 | weave_factors(as.factor(f1), f2) 49 | } 50 | \seealso{ 51 | \code{\link[=interaction]{interaction()}} 52 | } 53 | -------------------------------------------------------------------------------- /R/themes.R: -------------------------------------------------------------------------------- 1 | #' @title Theme extensions 2 | #' @name theme_extensions 3 | #' 4 | #' @description Some functions in \pkg{ggh4x} are using extensions to the theme 5 | #' system. These extended theme argument are listed below, along with what 6 | #' elements they are expected to be, and in what function(s) they are used. 7 | #' 8 | #' @usage NULL 9 | #' 10 | #' @param ggh4x.facet.nestline An [`element_line()`][ggplot2::element_line] 11 | #' used as the parent for the `nest_line` argument in [`facet_nested()`] and 12 | #' [`facet_nested_wrap()`]. Inherits directly from the '`line`' theme element. 13 | #' @param ggh4x.axis.nestline,ggh4x.axis.nestline.x,ggh4x.axis.nestline.y An 14 | #' [`element_line()`][ggplot2::element_line] used as the line to separate 15 | #' different layers of labels in [`guide_axis_nested()`]. Inherits from the 16 | #' '`axis.ticks`' theme element. 17 | #' @param ggh4x.axis.nesttext.x,ggh4x.axis.nesttext.y An 18 | #' [`element_text()`][ggplot2::element_text] used to differentiate text higher 19 | #' in the hierarchy from the axis labels directly next to the axis line in 20 | #' [`guide_axis_nested()`]. Inherits from the '`axis.text.x`' and 21 | #' '`axis.text.y`' theme elements respectively. 22 | #' @param ggh4x.axis.ticks.length.minor A [`rel()`][ggplot2::rel] object used to 23 | #' set the size of minor tick marks relative to the regular tick marks. This 24 | #' is used in the [`guide_axis_minor()`] and [`guide_axis_logticks()`] 25 | #' functions. Defaults to `rel(2/3)`. 26 | #' @param ggh4x.axis.ticks.length.mini A [`rel()`][ggplot2::rel] object used to 27 | #' set the size of the smallest tick marks relative to regular tick marks. 28 | #' This is only used in the [`guide_axis_logticks()`] function. 29 | #' Defaults to `rel(1/3)`. 30 | ggh4x_theme_elements <- function() { 31 | register_theme_elements( 32 | ggh4x.facet.nestline = element_blank(), 33 | element_tree = list( 34 | ggh4x.facet.nestline = el_def("element_line", "line") 35 | ) 36 | ) 37 | } 38 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | 8 | name: test-coverage.yaml 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | test-coverage: 14 | runs-on: ubuntu-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | 18 | steps: 19 | - uses: actions/checkout@v4 20 | 21 | - uses: r-lib/actions/setup-r@v2 22 | with: 23 | use-public-rspm: true 24 | 25 | - uses: r-lib/actions/setup-r-dependencies@v2 26 | with: 27 | extra-packages: any::covr, any::xml2 28 | needs: coverage 29 | 30 | - name: Test coverage 31 | run: | 32 | cov <- covr::package_coverage( 33 | quiet = FALSE, 34 | clean = FALSE, 35 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 36 | ) 37 | print(cov) 38 | covr::to_cobertura(cov) 39 | shell: Rscript {0} 40 | 41 | - uses: codecov/codecov-action@v5 42 | with: 43 | # Fail if error if not on PR, or if on PR and token is given 44 | fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} 45 | files: ./cobertura.xml 46 | plugins: noop 47 | disable_search: true 48 | token: ${{ secrets.CODECOV_TOKEN }} 49 | 50 | - name: Show testthat output 51 | if: always() 52 | run: | 53 | ## -------------------------------------------------------------------- 54 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 55 | shell: bash 56 | 57 | - name: Upload test results 58 | if: failure() 59 | uses: actions/upload-artifact@v4 60 | with: 61 | name: coverage-test-failures 62 | path: ${{ runner.temp }}/package 63 | -------------------------------------------------------------------------------- /man/element_part_rect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/element_part_rect.R 3 | \name{element_part_rect} 4 | \alias{element_part_rect} 5 | \title{Partial rectangle theme element} 6 | \usage{ 7 | element_part_rect( 8 | side = "tlbr", 9 | fill = NULL, 10 | colour = NULL, 11 | linewidth = NULL, 12 | linetype = NULL, 13 | color = NULL, 14 | inherit.blank = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{side}{A \code{character} of length one containing any of \code{"t"}, 19 | \code{"l"}, \code{"b"}, \code{"r"}. If these letters are present it will 20 | draw an edge at the top (t), left (l), bottom (b) or right (r) 21 | respectively. Including all or none of these letters will default to normal 22 | \code{element_rect()}.} 23 | 24 | \item{fill}{Fill colour.} 25 | 26 | \item{colour, color}{Line/border colour. Color is an alias for colour.} 27 | 28 | \item{linewidth}{Line/border size in mm.} 29 | 30 | \item{linetype}{Line type. An integer (0:8), a name (blank, solid, 31 | dashed, dotted, dotdash, longdash, twodash), or a string with 32 | an even number (up to eight) of hexadecimal digits which give the 33 | lengths in consecutive positions in the string.} 34 | 35 | \item{inherit.blank}{Should this element inherit the existence of an 36 | \code{element_blank} among its parents? If \code{TRUE} the existence of 37 | a blank element among its parents will cause this element to be blank as 38 | well. If \code{FALSE} any blank parent element will be ignored when 39 | calculating final element state.} 40 | } 41 | \value{ 42 | An S3 object of class \code{element_part_rect}. 43 | } 44 | \description{ 45 | The \code{element_part_rect()} function draws sides of a rectangle as theme 46 | elements. It can substitute \code{element_rect()} theme elements. 47 | } 48 | \examples{ 49 | ggplot(iris, aes(Sepal.Width, Sepal.Length)) + 50 | geom_point() + 51 | facet_grid(Species ~.) + 52 | theme( 53 | strip.background = element_part_rect(side = "tb", colour = "black"), 54 | panel.background = element_part_rect(side = "l", colour = "black") 55 | ) 56 | } 57 | -------------------------------------------------------------------------------- /man/theme_extensions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/themes.R 3 | \name{theme_extensions} 4 | \alias{theme_extensions} 5 | \alias{ggh4x_theme_elements} 6 | \title{Theme extensions} 7 | \arguments{ 8 | \item{ggh4x.facet.nestline}{An \code{\link[ggplot2:element]{element_line()}} 9 | used as the parent for the \code{nest_line} argument in \code{\link[=facet_nested]{facet_nested()}} and 10 | \code{\link[=facet_nested_wrap]{facet_nested_wrap()}}. Inherits directly from the '\code{line}' theme element.} 11 | 12 | \item{ggh4x.axis.nestline, ggh4x.axis.nestline.x, ggh4x.axis.nestline.y}{An 13 | \code{\link[ggplot2:element]{element_line()}} used as the line to separate 14 | different layers of labels in \code{\link[=guide_axis_nested]{guide_axis_nested()}}. Inherits from the 15 | '\code{axis.ticks}' theme element.} 16 | 17 | \item{ggh4x.axis.nesttext.x, ggh4x.axis.nesttext.y}{An 18 | \code{\link[ggplot2:element]{element_text()}} used to differentiate text higher 19 | in the hierarchy from the axis labels directly next to the axis line in 20 | \code{\link[=guide_axis_nested]{guide_axis_nested()}}. Inherits from the '\code{axis.text.x}' and 21 | '\code{axis.text.y}' theme elements respectively.} 22 | 23 | \item{ggh4x.axis.ticks.length.minor}{A \code{\link[ggplot2:element]{rel()}} object used to 24 | set the size of minor tick marks relative to the regular tick marks. This 25 | is used in the \code{\link[=guide_axis_minor]{guide_axis_minor()}} and \code{\link[=guide_axis_logticks]{guide_axis_logticks()}} 26 | functions. Defaults to \code{rel(2/3)}.} 27 | 28 | \item{ggh4x.axis.ticks.length.mini}{A \code{\link[ggplot2:element]{rel()}} object used to 29 | set the size of the smallest tick marks relative to regular tick marks. 30 | This is only used in the \code{\link[=guide_axis_logticks]{guide_axis_logticks()}} function. 31 | Defaults to \code{rel(1/3)}.} 32 | } 33 | \description{ 34 | Some functions in \pkg{ggh4x} are using extensions to the theme 35 | system. These extended theme argument are listed below, along with what 36 | elements they are expected to be, and in what function(s) they are used. 37 | } 38 | -------------------------------------------------------------------------------- /man/at_panel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/at_panel.R 3 | \name{at_panel} 4 | \alias{at_panel} 5 | \title{Constrain layer to panels} 6 | \usage{ 7 | at_panel(layer, expr) 8 | } 9 | \arguments{ 10 | \item{layer}{A \code{layer} as returned by \code{\link[ggplot2:layer]{layer()}}. 11 | Alternatively, a bare list of layers.} 12 | 13 | \item{expr}{An \code{expression} that, when evaluated in the facet's layout 14 | data.frame, yields a \code{logical} vector parallel to the rows.} 15 | } 16 | \value{ 17 | A modified \code{layer} which will only show in some panels. 18 | } 19 | \description{ 20 | This function limits the panels in which a layer is displayed. It can be 21 | used to make panel-specific annotations. 22 | } 23 | \details{ 24 | The \code{expr} argument's expression will be evaluated in the context of the 25 | plot's layout. This is an internal \code{data.frame} structure that isn't 26 | ordinarily exposed to users, so it will require some extra knowledge. For 27 | most facets, the layout describes the panels with one panel per row. It 28 | typically has \code{COL}, \code{ROW} and \code{PANEL} columns that keep track of where a 29 | panel goes in a grid-layout of cells. In addition, the layout contains the 30 | facetting variables provided to the \code{facets} or \code{rows} and \code{cols} arguments 31 | of the facets. For example, if we have a plot facetted on the \code{var} variable 32 | with the levels \code{A}, \code{B} and \code{C}, as 1 row and 3 columns, we might target 33 | the second \code{B} panel iwth any of these expressions: \code{var == "B"}, 34 | \code{PANEL == 2} or \code{COL == 2}. We can inspect the layout structure by using 35 | \code{ggplot_build(p)$layout$layout}, wherein \code{p} is a plot. 36 | } 37 | \examples{ 38 | p <- ggplot(mpg, aes(displ, hwy)) + 39 | geom_point() + 40 | facet_grid(year ~ drv) 41 | 42 | anno <- annotate("text", x = 3, y = 40, label = "My text") 43 | 44 | # Target specific panels 45 | p + at_panel(anno, PANEL \%in\% c(2, 4)) 46 | 47 | # Target a variable 48 | p + at_panel(anno, drv == "f") 49 | 50 | # Or combine variable with position 51 | p + at_panel(anno, drv == "f" & ROW == 2) 52 | } 53 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | # Utilities --------------------------------------------------------------- 2 | 3 | seq_range <- function(dat, ...) { 4 | seq.int(min(dat, na.rm = TRUE), max(dat, na.rm = TRUE), ...) 5 | } 6 | 7 | seq_nrow <- function(dat) { 8 | seq_len(NROW(dat)) 9 | } 10 | 11 | seq_ncol <- function(dat) { 12 | seq_len(NCOL(dat)) 13 | } 14 | 15 | width_cm <- function(x) { 16 | if (is.grob(x)) { 17 | convertWidth(grobWidth(x), "cm", TRUE) 18 | } else if (is.unit(x)) { 19 | convertWidth(x, "cm", TRUE) 20 | } else if (is.list(x)) { 21 | vapply(x, width_cm, numeric(1)) 22 | } else { 23 | cli::cli_abort("Unknown input: {.obj_type_friendly {x}}.") 24 | } 25 | } 26 | 27 | height_cm <- function(x) { 28 | if (is.grob(x)) { 29 | convertHeight(grobHeight(x), "cm", TRUE) 30 | } else if (is.unit(x)) { 31 | convertHeight(x, "cm", TRUE) 32 | } else if (is.list(x)) { 33 | vapply(x, height_cm, numeric(1)) 34 | } else { 35 | cli::cli_abort("Unknown input: {.obj_type_friendly {x}}.") 36 | } 37 | } 38 | 39 | fixup_docs <- function(x) { 40 | x <- gsub("\\[=aes", "\\[ggplot2:aes", x) 41 | x <- gsub("\\[=ggplot2::", "\\[ggplot2:", x) 42 | x 43 | } 44 | 45 | # ggplot internals -------------------------------------------------------- 46 | 47 | data_frame0 <- function(...) {data_frame(..., .name_repair = "minimal")} 48 | 49 | unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...) 50 | 51 | find_global <- function(name, env, mode = "any") { 52 | if (exists(name, envir = env, mode = mode)) { 53 | return(get(name, envir = env, mode = mode)) 54 | } 55 | nsenv <- asNamespace("ggplot2") 56 | if (exists(name, envir = nsenv, mode = mode)) { 57 | return(get(name, envir = nsenv, mode = mode)) 58 | } 59 | NULL 60 | } 61 | 62 | get_transformation <- function(scale) { 63 | if (is_ggproto(scale$scale)) { 64 | scale <- scale$scale 65 | } 66 | if (is.function(scale$get_transformation)) { 67 | scale$get_transformation() 68 | } else { 69 | scale$trans %||% scale$transform 70 | } 71 | } 72 | 73 | new_guide_system <- NA 74 | on_load(new_guide_system <- inherits(guide_none(), "Guide")) 75 | 76 | .onLoad <- function(...) { 77 | ggh4x_theme_elements() 78 | run_on_load() 79 | } 80 | -------------------------------------------------------------------------------- /man/guide_stringlegend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/guide_stringlegend.R 3 | \name{guide_stringlegend} 4 | \alias{guide_stringlegend} 5 | \title{String legend} 6 | \usage{ 7 | guide_stringlegend( 8 | title = waiver(), 9 | theme = NULL, 10 | position = NULL, 11 | direction = NULL, 12 | nrow = NULL, 13 | ncol = NULL, 14 | reverse = FALSE, 15 | order = 0 16 | ) 17 | } 18 | \arguments{ 19 | \item{title}{A character string or expression indicating a title of guide. 20 | If \code{NULL}, the title is not shown. By default 21 | (\code{\link[ggplot2:waiver]{waiver()}}), the name of the scale object or the name 22 | specified in \code{\link[ggplot2:labs]{labs()}} is used for the title.} 23 | 24 | \item{theme}{A \code{\link[ggplot2:theme]{theme}} object to style the guide individually or 25 | differently from the plot's theme settings. The \code{theme} argument in the 26 | guide overrides, and is combined with, the plot's theme.} 27 | 28 | \item{position}{A character string indicating where the legend should be 29 | placed relative to the plot panels.} 30 | 31 | \item{direction}{A character string indicating the direction of the guide. 32 | One of "horizontal" or "vertical."} 33 | 34 | \item{nrow, ncol}{The desired number of rows and column of legends 35 | respectively.} 36 | 37 | \item{reverse}{logical. If \code{TRUE} the order of legends is reversed.} 38 | 39 | \item{order}{positive integer less than 99 that specifies the order of 40 | this guide among multiple guides. This controls the order in which 41 | multiple guides are displayed, not the contents of the guide itself. 42 | If 0 (default), the order is determined by a secret algorithm.} 43 | } 44 | \value{ 45 | A \code{GuideStringlegend} object. 46 | } 47 | \description{ 48 | This type of legend shows colour and fill mappings as coloured text. It does 49 | not draw keys as \code{guide_legend()} does. 50 | } 51 | \examples{ 52 | p <- ggplot(mpg, aes(displ, hwy)) + 53 | geom_point(aes(colour = manufacturer)) 54 | 55 | # String legend can be set in the `guides()` function 56 | p + guides(colour = guide_stringlegend(ncol = 2)) 57 | 58 | # The string legend can also be set as argument to the scale 59 | p + scale_colour_viridis_d(guide = "stringlegend") 60 | } 61 | -------------------------------------------------------------------------------- /man/scale_listed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scale_listed.R 3 | \name{scale_listed} 4 | \alias{scale_listed} 5 | \title{Add a list of scales for non-standard aesthetics} 6 | \usage{ 7 | scale_listed(scalelist, replaces = NULL) 8 | } 9 | \arguments{ 10 | \item{scalelist}{A \code{list} wherein elements are the results of calls to a 11 | scale function with a non-standard aesthetic set as the \code{aesthetic} 12 | argument.} 13 | 14 | \item{replaces}{A \code{character} vector of the same length as- and parallel 15 | to- \code{scalelist}, indicating what standard aesthetic to replace with 16 | the non-standard aesthetic. Typically \code{"colour"} or \code{"fill"}.} 17 | } 18 | \value{ 19 | A \code{list} of which the elements are of the class 20 | \code{MultiScale}. 21 | } 22 | \description{ 23 | This function should only be called after all layers that the 24 | non-standard aesthetic scales affects have been added to the plot. 25 | 26 | Inside a layer, the non-standard aesthetic should be part of the call to 27 | \code{aes} mapping. 28 | 29 | May return a warning that the plot is ignoring unknown aesthetics. 30 | } 31 | \details{ 32 | Distributes a list of non-standard aesthetics scales to the plot, 33 | substituting geom and scale settings as necessary to display the non-standard 34 | aesthetics. Useful for mapping different geoms to different scales for 35 | example. 36 | } 37 | \examples{ 38 | # Annotation of heatmap 39 | iriscor <- cor(t(iris[, 1:4])) 40 | 41 | df <- data.frame( 42 | x = as.vector(row(iriscor)), 43 | y = as.vector(col(iriscor)), 44 | value = as.vector(iriscor) 45 | ) 46 | 47 | annotation <- data.frame( 48 | z = seq_len(nrow(iris)), 49 | Species = iris$Species, 50 | Leaves = ifelse(iris$Species == "setosa", "Short", "Long") 51 | ) 52 | 53 | ggplot(df, aes(x, y)) + 54 | geom_raster(aes(fill = value)) + 55 | geom_tile(data = annotation, 56 | aes(x = z, y = -5, spec = Species), height = 5) + 57 | geom_tile(data = annotation, 58 | aes(y = z, x = -5, leav = Leaves), width = 5) + 59 | scale_listed( 60 | list(scale_fill_brewer(palette = "Set1", aesthetics = "spec"), 61 | scale_fill_brewer(palette = "Dark2", aesthetics = "leav")), 62 | replaces = c("fill", "fill") 63 | ) 64 | } 65 | -------------------------------------------------------------------------------- /R/save.R: -------------------------------------------------------------------------------- 1 | #' Save a ggplot 2 | #' 3 | #' This is a wrapper for [ggsave()][ggplot2::ggsave] that attempts to make a 4 | #' reasonable guess at the plot size, particularly if they have been set in 5 | #' the `theme(panel.widths, panel.heights)` settings or when the 6 | #' `force_panelsizes()` function has been used. 7 | #' 8 | #' @inheritParams ggplot2::ggsave 9 | #' @inheritDotParams ggplot2::ggsave -width -height 10 | #' @param width,height Plot size in units expressed by the `units` argument. 11 | #' If `NULL` (default), the plot size will be measured. When the plot 12 | #' does not have a fixed size, these become `NA`, meaning that the size of 13 | #' the current graphics device is used. 14 | #' @returns The file name with `width` and `height` attributes in inches, 15 | #' invisibly. 16 | #' @export 17 | #' 18 | #' @examples 19 | #' # A plot with fixed dimensions 20 | #' p <- ggplot(mpg, aes(displ, hwy)) + 21 | #' geom_point() + 22 | #' theme( 23 | #' panel.widths = unit(10, "cm"), 24 | #' panel.heights = unit(2, "cm") 25 | #' ) 26 | #' 27 | #' # Save plot to a temporary file 28 | #' tmp <- tempfile(fileext = ".png") 29 | #' save_plot(tmp, plot = p) 30 | #' 31 | #' # Clean up temporary file 32 | #' unlink(tmp) 33 | save_plot <- function( 34 | ..., 35 | plot = get_last_plot(), 36 | width = NULL, 37 | height = NULL, 38 | units = c("in", "cm", "mm", "px"), 39 | dpi = 300 40 | ) { 41 | gt <- ggplotGrob(plot) 42 | units <- arg_match0(units, c("in", "cm", "mm", "px")) 43 | 44 | if (is.null(width)) { 45 | width <- gt$widths 46 | if (has_null_unit(width)) { 47 | width <- NA_real_ 48 | } else { 49 | width <- sum(width_cm(width)) / 2.54 50 | } 51 | } else { 52 | width <- width / switch(units, `in` = 1, cm = 2.54, mm = 25.4, px = dpi) 53 | } 54 | 55 | if (is.null(height)) { 56 | height <- gt$heights 57 | if (has_null_unit(height)) { 58 | height <- NA_real_ 59 | } else { 60 | height <- sum(height_cm(height)) / 2.54 61 | } 62 | } else { 63 | height <- height / switch(units, `in` = 1, cm = 2.54, mm = 25.4, px = dpi) 64 | } 65 | 66 | out_file <- ggsave( 67 | ..., 68 | plot = plot, 69 | width = width, 70 | height = height, 71 | units = "in", 72 | dpi = dpi 73 | ) 74 | attr(out_file, "width") <- width 75 | attr(out_file, "height") <- height 76 | out_file 77 | } 78 | 79 | has_null_unit <- function(x) { 80 | any(unitType(x) == "null") 81 | } 82 | -------------------------------------------------------------------------------- /man/position_disjoint_ranges.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/position_disjoint_ranges.R 3 | \name{position_disjoint_ranges} 4 | \alias{position_disjoint_ranges} 5 | \title{Segregating overlapping ranges} 6 | \usage{ 7 | position_disjoint_ranges(extend = 1, stepsize = 1) 8 | } 9 | \arguments{ 10 | \item{extend}{a \code{numeric} of length 1 indicating how far a range should 11 | be extended in total for calculating overlaps. Setting this argument to a 12 | positive number leaves some space between ranges in the same bin.} 13 | 14 | \item{stepsize}{a \code{numeric} of length 1 that determines how much space 15 | is added between bins in the y-direction. A positive value grows the bins 16 | from bottom to top, while a negative value grows the bins from top to 17 | bottom.} 18 | } 19 | \value{ 20 | A \emph{PositionDisjointRanges} object. 21 | } 22 | \description{ 23 | One-dimensional ranged data in the x-direction is segregated in 24 | the y-direction such that no overlap in two-dimensional space occurs. This 25 | positioning works best when no relevant information is plotted in the 26 | y-direction. 27 | } 28 | \details{ 29 | An object is considered disjoint from a second object when the range 30 | between their \code{xmin} and \code{xmax} coordinates don't overlap. 31 | Objects that overlap are assigned to different bins in the y-direction, 32 | whereby lower bins are filled first. This way, information in the 33 | x-direction is preserved and different objects can be discerned. 34 | 35 | Note that this positioning is only particularly useful when y-coordinates 36 | do not encode relevant information. Geoms that pair well with this 37 | positioning are \code{\link[ggplot2:geom_tile]{geom_rect()}} and 38 | \code{\link[ggplot2:geom_tile]{ggplot2::geom_tile()}}. 39 | 40 | This positioning function was inspired by the \code{disjointBins()} 41 | function in the \code{IRanges} package, but has been written such that it 42 | accepts any numeric input next to solely integer input. 43 | } 44 | \examples{ 45 | # Even though geom_tile() is parametrised by middle-x values, it is 46 | # internally converted to xmin, xmax, ymin, ymax parametrisation so the 47 | # positioning still works. 48 | 49 | ggplot() + 50 | geom_tile(aes(x = rnorm(200), y = 0), 51 | width = 0.2, height = 0.9, 52 | position = position_disjoint_ranges(extend = 0.1)) 53 | } 54 | \seealso{ 55 | The \code{disjointBins} function the Bioconductor IRanges package. 56 | } 57 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://teunbrand.github.io/ggh4x 2 | template: 3 | bootstrap: 5 4 | 5 | reference: 6 | - title: "Facets" 7 | desc: > 8 | Extended facet functions with additional options to customise the strips 9 | and axes of the classic 'wrap' and 'grid' layouts. 10 | - contents: 11 | - facet_grid2 12 | - facet_wrap2 13 | - facet_nested 14 | - facet_nested_wrap 15 | - facet_manual 16 | - title: "Facet helpers" 17 | desc: > 18 | Helper functions that can tweak the appearance of facet panels, the strips 19 | and position scales. 20 | - contents: 21 | - strip_vanilla 22 | - strip_themed 23 | - strip_nested 24 | - strip_split 25 | - strip_tag 26 | - force_panelsizes 27 | - facetted_pos_scales 28 | - scale_x_facet 29 | - title: Position guides and scales 30 | desc: > 31 | Additional ways to organise and display the x- and y-axes. 32 | - contents: 33 | - scale_x_dendrogram 34 | - scale_x_manual 35 | - guide_dendro 36 | - guide_axis_truncated 37 | - guide_axis_colour 38 | - guide_axis_minor 39 | - guide_axis_logticks 40 | - guide_axis_nested 41 | - guide_axis_manual 42 | - guide_axis_scalebar 43 | - coord_axes_inside 44 | - title: "Colour scales and guide" 45 | desc: > 46 | Two ways of mapping non-standard aesthetics to colour/fill scales and a 47 | legend of coloured text. 48 | - contents: 49 | - guide_stringlegend 50 | - scale_fill_multi 51 | - scale_listed 52 | - title: "Stats" 53 | desc: > 54 | Statistical layers that perform a data transformation 55 | - contents: 56 | - stat_theodensity 57 | - stat_difference 58 | - stat_rollingkernel 59 | - stat_funxy 60 | - stat_rle 61 | - title: "Geoms" 62 | desc: > 63 | A small collection of geometry layers. 64 | - contents: 65 | - geom_pointpath 66 | - geom_outline_point 67 | - geom_polygonraster 68 | - geom_rectmargin 69 | - geom_tilemargin 70 | - geom_text_aimed 71 | - geom_box 72 | - title: "Positions" 73 | desc: > 74 | Two position adjustments that can be added to layers. 75 | - contents: 76 | - position_disjoint_ranges 77 | - position_lineartrans 78 | - title: "Miscellaneous" 79 | desc: > 80 | Functions that don't belong to a family of functions, may might be 81 | helpful in specific circumstances. 82 | - contents: 83 | - ggh4x_extensions 84 | - theme_extensions 85 | - save_plot 86 | - help_secondary 87 | - center_limits 88 | - element_part_rect 89 | - ggsubset 90 | - elem_list_rect 91 | - weave_factors 92 | - sep_discrete 93 | - at_panel 94 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: ggh4x 2 | Title: Hacks for 'ggplot2' 3 | Version: 0.3.1.9000 4 | Authors@R: 5 | person(given = "Teun", 6 | family = "van den Brand", 7 | role = c("aut", "cre"), 8 | email = "tahvdbrand@gmail.com", 9 | comment = c(ORCID = "0000-0002-9335-7468")) 10 | Description: A 'ggplot2' extension that does a variety of little 11 | helpful things. The package extends 'ggplot2' facets through 12 | customisation, by setting individual scales per panel, resizing panels 13 | and providing nested facets. Also allows multiple colour and fill 14 | scales per plot. Also hosts a smaller collection of stats, geoms and axis 15 | guides. 16 | License: MIT + file LICENSE 17 | URL: https://github.com/teunbrand/ggh4x, 18 | https://teunbrand.github.io/ggh4x/ 19 | BugReports: https://github.com/teunbrand/ggh4x/issues 20 | Depends: 21 | ggplot2 (>= 4.0.0) 22 | Imports: 23 | grid, 24 | gtable, 25 | scales, 26 | vctrs (>= 0.5.0), 27 | rlang (>= 1.1.0), 28 | lifecycle, 29 | stats, 30 | cli, 31 | S7 32 | Suggests: 33 | covr, 34 | fitdistrplus, 35 | ggdendro, 36 | vdiffr, 37 | knitr, 38 | MASS, 39 | rmarkdown, 40 | testthat (>= 3.0.0), 41 | utils 42 | VignetteBuilder: 43 | knitr 44 | Encoding: UTF-8 45 | RoxygenNote: 7.3.2 46 | Config/testthat/edition: 3 47 | Collate: 48 | 'at_panel.R' 49 | 'borrowed_ggplot2.R' 50 | 'conveniences.R' 51 | 'ggh4x_extensions.R' 52 | 'coord_axes_inside.R' 53 | 'deprecated.R' 54 | 'element_part_rect.R' 55 | 'facet_grid2.R' 56 | 'facet_wrap2.R' 57 | 'facet_manual.R' 58 | 'facet_nested.R' 59 | 'facet_nested_wrap.R' 60 | 'facetted_pos_scales.R' 61 | 'force_panelsize.R' 62 | 'geom_box.R' 63 | 'geom_outline_point.R' 64 | 'geom_pointpath.R' 65 | 'geom_polygonraster.R' 66 | 'geom_rectrug.R' 67 | 'geom_text_aimed.R' 68 | 'ggh4x-package.R' 69 | 'guide_stringlegend.R' 70 | 'help_secondary.R' 71 | 'position_disjoint_ranges.R' 72 | 'position_lineartrans.R' 73 | 'save.R' 74 | 'scale_facet.R' 75 | 'scale_listed.R' 76 | 'scale_manual.R' 77 | 'scale_multi.R' 78 | 'stat_difference.R' 79 | 'stat_funxy.R' 80 | 'stat_rle.R' 81 | 'stat_roll.R' 82 | 'stat_theodensity.R' 83 | 'strip_vanilla.R' 84 | 'strip_themed.R' 85 | 'strip_nested.R' 86 | 'strip_split.R' 87 | 'strip_tag.R' 88 | 'themes.R' 89 | 'utils.R' 90 | 'utils_grid.R' 91 | 'utils_gtable.R' 92 | Roxygen: list(markdown = TRUE) 93 | -------------------------------------------------------------------------------- /man/strip_tag.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/strip_tag.R 3 | \name{strip_tag} 4 | \alias{strip_tag} 5 | \title{Strips as tags} 6 | \usage{ 7 | strip_tag( 8 | clip = "inherit", 9 | order = c("x", "y"), 10 | just = c(0, 1), 11 | text_x = NULL, 12 | text_y = element_text(angle = 0), 13 | background_x = NULL, 14 | background_y = NULL, 15 | by_layer_x = FALSE, 16 | by_layer_y = FALSE 17 | ) 18 | } 19 | \arguments{ 20 | \item{clip}{A \code{character(1)} that controls whether text labels are clipped to 21 | the background boxes. Can be either \code{"inherit"} (default), \code{"on"} or 22 | \code{"off"}.} 23 | 24 | \item{order}{Either \code{c("x", "y")} or \code{c("y", "x")}, setting the top-to-bottom 25 | order of horizontal versus "vertical" labels in facets with a grid layout.} 26 | 27 | \item{just}{A \verb{} setting the horizontal and vertical 28 | justification of placing the textbox.} 29 | 30 | \item{text_x, text_y}{A \code{list()} with 31 | \code{\link[ggplot2:element]{element_text()}} elements. See details.} 32 | 33 | \item{background_x, background_y}{A \code{list()} with 34 | \code{\link[ggplot2:element]{element_rect()}} elements. See details.} 35 | 36 | \item{by_layer_x, by_layer_y}{A \code{logical(1)} that when \code{TRUE}, maps the 37 | different elements to different layers of the strip. When \code{FALSE}, maps the 38 | different elements to individual strips, possibly repeating the elements 39 | to match the number of strips through \code{rep_len()}.} 40 | } 41 | \value{ 42 | A \code{StripTag} ggproto object that can be given as an argument to 43 | facets in ggh4x. 44 | } 45 | \description{ 46 | This strip style renders the strips as text with fitted boxes onto the panels 47 | of the plot. This is in contrast to strips that match the panel size and 48 | are located outside the panels. 49 | } 50 | \examples{ 51 | # A standard plot 52 | p <- ggplot(mpg, aes(displ, hwy)) + 53 | geom_point() 54 | 55 | # Typical use 56 | p + facet_wrap2( 57 | ~ class, 58 | strip = strip_tag() 59 | ) 60 | 61 | # Adjusting justification 62 | p + facet_wrap2( 63 | ~ class, 64 | strip = strip_tag(just = c(1, 0)) 65 | ) 66 | 67 | p + facet_wrap2( 68 | ~ drv + year, 69 | strip = strip_tag() 70 | ) 71 | 72 | # With a grid layout, you can control in which order the labels are drawn 73 | p + facet_grid2( 74 | "vertical" ~ "horizontal", 75 | strip = strip_tag(order = c("x", "y")) # default 76 | ) 77 | 78 | p +facet_grid2( 79 | "vertical" ~ "horizontal", 80 | strip = strip_tag(order = c("y", "x")) # invert order 81 | ) 82 | } 83 | \seealso{ 84 | Other strips: 85 | \code{\link{strip_nested}()}, 86 | \code{\link{strip_split}()}, 87 | \code{\link{strip_themed}()}, 88 | \code{\link{strip_vanilla}()} 89 | } 90 | \concept{strips} 91 | -------------------------------------------------------------------------------- /man/scale_fill_multi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scale_multi.R 3 | \name{scale_fill_multi} 4 | \alias{scale_fill_multi} 5 | \alias{scale_colour_multi} 6 | \title{Multiple gradient colour scales} 7 | \usage{ 8 | scale_fill_multi( 9 | ..., 10 | colours, 11 | values = NULL, 12 | na.value = "transparent", 13 | guide = "colourbar", 14 | aesthetics = "fill", 15 | colors 16 | ) 17 | 18 | scale_colour_multi( 19 | ..., 20 | colours, 21 | values = NULL, 22 | na.value = "transparent", 23 | guide = "colourbar", 24 | aesthetics = "colour", 25 | colors 26 | ) 27 | } 28 | \arguments{ 29 | \item{..., colours, values, na.value, guide, colors}{listed arguments in 30 | \code{\link[ggplot2:scale_gradient]{scale_colour_gradientn()}} (e.g. \code{colours = list(c("white", "red"), c("black", "blue"))}).} 31 | 32 | \item{aesthetics}{a \code{character} vector with names of aesthetic mapping.} 33 | } 34 | \value{ 35 | A nested list-like structure of the class \code{MultiScale}. 36 | } 37 | \description{ 38 | Maps multiple aesthetics to multiple colour fill gradient 39 | scales. It takes in listed arguments for each aesthetic and disseminates 40 | these to \code{\link[ggplot2:continuous_scale]{ggplot2::continuous_scale()}}. 41 | } 42 | \details{ 43 | This function should only be called after all layers that this 44 | function affects are added to the plot. 45 | 46 | The list elements of the listed arguments are assumed to follow the 47 | \code{aesthetics} order, i.e. the n\emph{th} list element belongs to the n\emph{th} 48 | aesthetic. When there are more list elements than n aesthetics, only the 49 | first n\emph{th} list elements are taken. When there are more \code{aesthetics} 50 | than list elements, the first list element is used for the remaining 51 | aesthethics. 52 | 53 | In contrast to other \verb{scale_*_continous}-family functions, the 54 | \code{guide} argument is interpreted before adding it to the plot instead 55 | of at the time of plot building. This behaviour ensures that the 56 | \code{available_aes} argument of the guides are set correctly, but may 57 | interfere with the \code{\link[ggplot2:guides]{ggplot2::guides()}} function. 58 | } 59 | \examples{ 60 | # Setup dummy data 61 | df <- rbind(data.frame(x = 1:3, y = 1, v = NA, w = 1:3, z = NA), 62 | data.frame(x = 1:3, y = 2, v = 1:3, w = NA, z = NA), 63 | data.frame(x = 1:3, y = 3, v = NA, w = NA, z = 1:3)) 64 | 65 | ggplot(df, aes(x, y)) + 66 | geom_raster(aes(fill1 = v)) + 67 | geom_raster(aes(fill2 = w)) + 68 | geom_raster(aes(fill3 = z)) + 69 | scale_fill_multi(aesthetics = c("fill1", "fill2", "fill3"), 70 | colours = list(c("white", "red"), 71 | c("black", "blue"), 72 | c("grey50", "green"))) 73 | } 74 | -------------------------------------------------------------------------------- /man/force_panelsizes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/force_panelsize.R 3 | \name{force_panelsizes} 4 | \alias{force_panelsizes} 5 | \title{Force a facetted plot to have specified panel sizes} 6 | \usage{ 7 | force_panelsizes( 8 | rows = NULL, 9 | cols = NULL, 10 | respect = NULL, 11 | total_width = NULL, 12 | total_height = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{rows, cols}{a \code{numeric} or \code{unit} vector for setting panel heights 17 | (rows) or panel widths (cols).} 18 | 19 | \item{respect}{a \code{logical} value. If \code{TRUE}, widths and heights 20 | specified in \verb{"null" unit}s are proportional. If \code{FALSE}, 21 | \verb{"null" unit}s in x- and y-direction vary independently.} 22 | 23 | \item{total_width, total_height}{an absolute \code{unit} of length 1 setting the 24 | total width or height of all panels and the decoration between panels. 25 | If not \code{NULL}, \code{rows} and \code{cols} should be \code{numeric} and not \code{unit}s.} 26 | } 27 | \value{ 28 | A \code{forcedsize} S3 object that can be added to a plot. 29 | } 30 | \description{ 31 | Takes a ggplot and modifies its facet drawing behaviour such that the widths 32 | and heights of panels are set by the user. 33 | } 34 | \details{ 35 | Forcing the panel sizes should in theory work regardless of what 36 | facetting choice was made, as long as this function is called after the 37 | facet specification. Even when no facets are specified, ggplot2 defaults to 38 | the \code{\link[ggplot2:facet_null]{ggplot2::facet_null()}} specification; a single panel. 39 | \code{force_panelsizes} works by wrapping the original panel drawing 40 | function inside a function that modifies the widths and heights of panel 41 | grobs in the original function's output gtable. 42 | 43 | When \code{rows} or \code{cols} are \code{numeric} vectors, panel sizes are 44 | defined as ratios i.e. relative \verb{"null" unit}s. \code{rows} and 45 | \code{cols} vectors are repeated or shortened to fit the number of panels 46 | in their direction. When \code{rows} or \code{cols} are \code{NULL}, no 47 | changes are made in that direction. 48 | 49 | When \code{respect = NULL}, default behaviour specified elsewhere is 50 | inherited. 51 | 52 | No attempt is made to guarantee that the plot fits the output device. The 53 | \code{space} argument in \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} will be 54 | overruled. When individual panels span multiple rows or columns, this 55 | function may not work as intended. 56 | } 57 | \examples{ 58 | ggplot(mtcars, aes(disp, mpg)) + 59 | geom_point() + 60 | facet_grid(vs ~ am) + 61 | force_panelsizes(rows = c(2, 1), 62 | cols = c(2, 1)) 63 | } 64 | \seealso{ 65 | \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} 66 | \code{\link[ggplot2:facet_null]{ggplot2::facet_null()}} \code{\link[grid:unit]{grid::unit()}} 67 | } 68 | -------------------------------------------------------------------------------- /R/guide_stringlegend.R: -------------------------------------------------------------------------------- 1 | # Constructor ------------------------------------------------------------- 2 | 3 | #' String legend 4 | #' 5 | #' This type of legend shows colour and fill mappings as coloured text. It does 6 | #' not draw keys as `guide_legend()` does. 7 | #' 8 | #' @inheritParams ggplot2::guide_legend 9 | #' 10 | #' @return A `GuideStringlegend` object. 11 | #' @export 12 | #' 13 | #' @examples 14 | #' p <- ggplot(mpg, aes(displ, hwy)) + 15 | #' geom_point(aes(colour = manufacturer)) 16 | #' 17 | #' # String legend can be set in the `guides()` function 18 | #' p + guides(colour = guide_stringlegend(ncol = 2)) 19 | #' 20 | #' # The string legend can also be set as argument to the scale 21 | #' p + scale_colour_viridis_d(guide = "stringlegend") 22 | guide_stringlegend <- function( 23 | title = waiver(), 24 | theme = NULL, 25 | position = NULL, 26 | direction = NULL, 27 | nrow = NULL, 28 | ncol = NULL, 29 | reverse = FALSE, 30 | order = 0 31 | ) { 32 | new_guide( 33 | title = title, 34 | theme = theme, 35 | direction = direction, 36 | nrow = nrow, ncol = ncol, 37 | reverse = reverse, 38 | order = order, 39 | position = position, 40 | available_aes = c("colour", "fill", "family", "fontface"), 41 | name = "stringlegend", 42 | super = GuideStringlegend 43 | ) 44 | } 45 | 46 | # Class ------------------------------------------------------------------- 47 | 48 | #' @usage NULL 49 | #' @format NULL 50 | #' @export 51 | #' @rdname ggh4x_extensions 52 | GuideStringlegend <- ggproto( 53 | "GuideStringlegend", GuideLegend, 54 | 55 | get_layer_key = function(params, ...) { 56 | params 57 | }, 58 | 59 | setup_params = function(params) { 60 | params <- GuideLegend$setup_params(params) 61 | params$sizes <- list(widths = 0, heights = 0) 62 | params 63 | }, 64 | 65 | setup_elements = function(params, elements, theme) { 66 | theme <- theme + params$theme 67 | params$theme <- NULL 68 | elements <- GuideLegend$setup_elements(params, elements, theme) 69 | elements$spacing_y <- calc_element("legend.key.spacing.y", theme) 70 | elements$text$margin <- calc_element("legend.text", theme)$margin 71 | elements$key_height <- elements$key_width <- unit(0, "cm") 72 | elements 73 | }, 74 | 75 | build_labels = function(key, elements, params) { 76 | n_labels <- length(key$.label) 77 | if (n_labels < 1) { 78 | out <- rep(list(zeroGrob()), nrow(key)) 79 | return(out) 80 | } 81 | colour <- key$colour %||% key$fill 82 | lapply( 83 | seq_along(key$.label), 84 | function(i) { 85 | text <- element_grob( 86 | elements$text, label = key$.label[i], 87 | colour = colour[i], 88 | family = key$family[i], 89 | face = key$fontface[i], 90 | margin_x = TRUE, 91 | margin_y = TRUE 92 | ) 93 | } 94 | ) 95 | }, 96 | 97 | build_decor = function(...) zeroGrob() 98 | ) 99 | -------------------------------------------------------------------------------- /man/distribute_args.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conveniences.R 3 | \name{distribute_args} 4 | \alias{distribute_args} 5 | \alias{elem_list_text} 6 | \alias{elem_list_rect} 7 | \title{Element list constructors} 8 | \usage{ 9 | distribute_args(..., .fun = element_text, .cull = TRUE) 10 | 11 | elem_list_text(...) 12 | 13 | elem_list_rect(...) 14 | } 15 | \arguments{ 16 | \item{...}{Vectorised arguments to pass on to functions.} 17 | 18 | \item{.fun}{A function to distribute arguments to.} 19 | 20 | \item{.cull}{A \code{logical(1)} determining if unknown arguments are being 21 | culled.} 22 | } 23 | \value{ 24 | A \code{list} of outputs from \code{fun}. 25 | } 26 | \description{ 27 | These functions take a vector of arguments and pass on the 28 | \ifelse{html}{\out{ith}}{\eqn{i^{th}}} item of the vector to an 29 | \ifelse{html}{\out{ith}}{\eqn{i^{th}}} call of a function. The 30 | \code{elem_list_text} and \code{elem_list_rect} are convenience functions for 31 | constructing lists of \code{\link[ggplot2:element]{element_text()}} and 32 | \code{\link[ggplot2:element]{element_rect()}} theme elements. 33 | } 34 | \details{ 35 | \code{NA}s and \code{NULL}s will be silently dropped. If you want to pass on a 36 | transparent \code{fill} or \code{colour} argument, you should use the more verbose 37 | character \code{"transparent"} instead. However, you \emph{can} use a \code{NA} to 38 | indicate that it's argument should not be passed to a function in that 39 | position. 40 | } 41 | \note{ 42 | Whereas the \code{distribute_args} function might seem amenable for 43 | off-label uses elsewhere (besides constructing lists of theme elements), it 44 | is not intended as such. For example, because valid arguments will be 45 | deduced from the formals of a function, using certain functions can be 46 | troublesome. For example, the \code{distribute_args} function does not properly 47 | recognise the utility of a \code{...} argument in a function that it is supposed 48 | to distribute arguments to. This can be a problem for object-oriented 49 | functions: if the methods contain more arguments than the generic itself, 50 | these extra arguments will be silently dropped. 51 | } 52 | \examples{ 53 | # Providing arguments for `element_rect()` 54 | elem_list_rect( 55 | # The first element_rect will have linetype 1, the second gets 3 56 | linetype = c(1, 3), 57 | # If an argument doesn't exist, it will be silently dropped 58 | nonsense_argument = c("I", "will", "be", "filtered", "out") 59 | ) 60 | 61 | # Providing arguments for `element_text()` 62 | elem_list_text( 63 | # `NA`s will be skipped 64 | family = c("mono", NA, "sans"), 65 | # Providing a list of more complex arguments. `NULL` will be skipped too. 66 | margin = list(NULL, margin(t = 5)) 67 | ) 68 | 69 | # Providing arguments to other functions 70 | distribute_args( 71 | lineend = c("round", "butt", "square"), 72 | # If you want to pass a vector instead of a scalar, you can use a list 73 | colour = list(c("blue", "red"), "green"), 74 | .fun = element_line 75 | ) 76 | } 77 | \seealso{ 78 | The \code{\link[ggplot2:element]{element_text()}} and 79 | \code{\link[ggplot2:element]{element_rect()}} theme elements for a 80 | description of their arguments. 81 | } 82 | -------------------------------------------------------------------------------- /man/save_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/save.R 3 | \name{save_plot} 4 | \alias{save_plot} 5 | \title{Save a ggplot} 6 | \usage{ 7 | save_plot( 8 | ..., 9 | plot = get_last_plot(), 10 | width = NULL, 11 | height = NULL, 12 | units = c("in", "cm", "mm", "px"), 13 | dpi = 300 14 | ) 15 | } 16 | \arguments{ 17 | \item{...}{ 18 | Arguments passed on to \code{\link[ggplot2:ggsave]{ggplot2::ggsave}} 19 | \describe{ 20 | \item{\code{filename}}{File name to create on disk.} 21 | \item{\code{device}}{Device to use. Can either be a device function 22 | (e.g. \link{png}), or one of "eps", "ps", "tex" (pictex), 23 | "pdf", "jpeg", "tiff", "png", "bmp", "svg" or "wmf" (windows only). If 24 | \code{NULL} (default), the device is guessed based on the \code{filename} extension.} 25 | \item{\code{path}}{Path of the directory to save plot to: \code{path} and \code{filename} 26 | are combined to create the fully qualified file name. Defaults to the 27 | working directory.} 28 | \item{\code{scale}}{Multiplicative scaling factor.} 29 | \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not 30 | save images larger than 50x50 inches, to prevent the common error of 31 | specifying dimensions in pixels.} 32 | \item{\code{bg}}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value 33 | from the plot theme.} 34 | \item{\code{create.dir}}{Whether to create new directories if a non-existing 35 | directory is specified in the \code{filename} or \code{path} (\code{TRUE}) or return an 36 | error (\code{FALSE}, default). If \code{FALSE} and run in an interactive session, 37 | a prompt will appear asking to create a new directory when necessary.} 38 | }} 39 | 40 | \item{plot}{Plot to save, defaults to last plot displayed.} 41 | 42 | \item{width, height}{Plot size in units expressed by the \code{units} argument. 43 | If \code{NULL} (default), the plot size will be measured. When the plot 44 | does not have a fixed size, these become \code{NA}, meaning that the size of 45 | the current graphics device is used.} 46 | 47 | \item{units}{One of the following units in which the \code{width} and \code{height} 48 | arguments are expressed: \code{"in"}, \code{"cm"}, \code{"mm"} or \code{"px"}.} 49 | 50 | \item{dpi}{Plot resolution. Also accepts a string input: "retina" (320), 51 | "print" (300), or "screen" (72). Only applies when converting pixel units, 52 | as is typical for raster output types.} 53 | } 54 | \value{ 55 | The file name with \code{width} and \code{height} attributes in inches, 56 | invisibly. 57 | } 58 | \description{ 59 | This is a wrapper for \link[ggplot2:ggsave]{ggsave()} that attempts to make a 60 | reasonable guess at the plot size, particularly if they have been set in 61 | the \code{theme(panel.widths, panel.heights)} settings or when the 62 | \code{force_panelsizes()} function has been used. 63 | } 64 | \examples{ 65 | # A plot with fixed dimensions 66 | p <- ggplot(mpg, aes(displ, hwy)) + 67 | geom_point() + 68 | theme( 69 | panel.widths = unit(10, "cm"), 70 | panel.heights = unit(2, "cm") 71 | ) 72 | 73 | # Save plot to a temporary file 74 | tmp <- tempfile(fileext = ".png") 75 | save_plot(tmp, plot = p) 76 | 77 | # Clean up temporary file 78 | unlink(tmp) 79 | } 80 | -------------------------------------------------------------------------------- /vignettes/ggh4x.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introduction to ggh4x" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Introduction to ggh4x} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | The name 'ggh4x', pronounced G-G-hacks (ʤiː-ʤiː-hæks) is leetspeak ---or *1ee75p34k*, if you will--- for grammar of graphics hacks. The ggh4x packages uses the extension capabilities of ggplot2 to provide a variety of utility functions to use in conjunction with ggplot2. A few among these functions do not "fit" within the layered approach of the grammar, as these make small but useful edits to preceding components of a plot. It is for this reason these functions can be a bit hacky and from which the package's name derives. However, most functions that were added since use the conventional extension system and as such can be used with ggplot2 as you would use the native functions. 18 | 19 | # Getting started 20 | 21 | Using ggh4x is not that different from using ggplot2, as most of the function following their API conventions. Below is an example of the types of things you could do, with as much ggh4x functions as could be reasonably fit into a single plot. 22 | 23 | ```{r} 24 | library(ggplot2) 25 | library(ggh4x) 26 | 27 | # Setting up some random data 28 | n <- 200 29 | df <- data.frame( 30 | x = c(rpois(n, 25), 31 | rnbinom(n, 5, 0.2), 32 | rgamma(n, 30, 1.5), 33 | rchisq(n, 15)), 34 | distribution = rep(c("Poisson", "Negative Binomial", 35 | "Gamma", "Chi-squared"), each = n), 36 | type = rep(c("Discrete", "Continuous"), each = 2 * n) 37 | ) 38 | 39 | ggplot(df, aes(x, y = after_stat(count), 40 | fill = distribution, colour = distribution)) + 41 | geom_histogram(position = "identity", binwidth = 1, 42 | alpha = 0.3, colour = NA) + 43 | # One type of theoretical densities for discrete distributions with steps 44 | stat_theodensity(data = ~ subset(.x, type == "Discrete"), 45 | distri = "nbinom", geom = "step", 46 | position = position_nudge(x = -0.5)) + 47 | # Another type for the continuous ones with lines 48 | stat_theodensity(data = ~ subset(.x, type == "Continuous"), 49 | distri = "gamma") + 50 | scale_colour_discrete(aesthetics = c("colour", "fill"), guide = "none") + 51 | # Have the facet strips span categories 52 | facet_nested(~ type + distribution, scales = "free_x") + 53 | # Precisely control aspect ratio of panels 54 | force_panelsizes(rows = 1.618, cols = 1, respect = TRUE) + 55 | # Tweak the scales of individual panels 56 | facetted_pos_scales(list( 57 | scale_x_continuous(labels = scales::number_format(0.1)), 58 | # Give the 2nd panel minor ticks 59 | scale_x_continuous(guide = guide_axis(minor.ticks = TRUE)), 60 | scale_x_continuous(limits = c(0, 40), oob = scales::oob_keep), 61 | scale_x_continuous(expand = c(1, 0)) 62 | )) 63 | ``` 64 | 65 | # Further reading 66 | 67 | Since ggh4x touches several aspects of ggplot2 plots, a few topics are discussed in more detail in vignettes. 68 | Please see the vignettes on [facet_* functions](Facets.html) or [stat_* functions](Statistics.html).). 69 | -------------------------------------------------------------------------------- /R/at_panel.R: -------------------------------------------------------------------------------- 1 | #' Constrain layer to panels 2 | #' 3 | #' This function limits the panels in which a layer is displayed. It can be 4 | #' used to make panel-specific annotations. 5 | #' 6 | #' @param layer A `layer` as returned by [`layer()`][ggplot2::layer]. 7 | #' Alternatively, a bare list of layers. 8 | #' @param expr An `expression` that, when evaluated in the facet's layout 9 | #' data.frame, yields a `logical` vector parallel to the rows. 10 | #' 11 | #' @details 12 | #' The `expr` argument's expression will be evaluated in the context of the 13 | #' plot's layout. This is an internal `data.frame` structure that isn't 14 | #' ordinarily exposed to users, so it will require some extra knowledge. For 15 | #' most facets, the layout describes the panels with one panel per row. It 16 | #' typically has `COL`, `ROW` and `PANEL` columns that keep track of where a 17 | #' panel goes in a grid-layout of cells. In addition, the layout contains the 18 | #' facetting variables provided to the `facets` or `rows` and `cols` arguments 19 | #' of the facets. For example, if we have a plot facetted on the `var` variable 20 | #' with the levels `A`, `B` and `C`, as 1 row and 3 columns, we might target 21 | #' the second `B` panel iwth any of these expressions: `var == "B"`, 22 | #' `PANEL == 2` or `COL == 2`. We can inspect the layout structure by using 23 | #' `ggplot_build(p)$layout$layout`, wherein `p` is a plot. 24 | #' 25 | #' @return A modified `layer` which will only show in some panels. 26 | #' @export 27 | #' 28 | #' @examples 29 | #' p <- ggplot(mpg, aes(displ, hwy)) + 30 | #' geom_point() + 31 | #' facet_grid(year ~ drv) 32 | #' 33 | #' anno <- annotate("text", x = 3, y = 40, label = "My text") 34 | #' 35 | #' # Target specific panels 36 | #' p + at_panel(anno, PANEL %in% c(2, 4)) 37 | #' 38 | #' # Target a variable 39 | #' p + at_panel(anno, drv == "f") 40 | #' 41 | #' # Or combine variable with position 42 | #' p + at_panel(anno, drv == "f" & ROW == 2) 43 | at_panel <- function(layer, expr) { 44 | expr <- rlang::enquo(expr) 45 | if (quo_is_missing(expr)) { 46 | cli::cli_abort("{.arg expr} must be an expression, it cannot be missing.") 47 | } 48 | 49 | if (!inherits(layer, "LayerInstance")) { 50 | # Accept `geom_sf()`, which returns a list with a layer in first spot, and 51 | # other lists of layers 52 | if (is_bare_list(layer)) { 53 | is_layer <- vapply(layer, inherits, logical(1), what = "LayerInstance") 54 | layer[is_layer] <- lapply(layer[is_layer], at_panel, expr = !!expr) 55 | return(layer) 56 | } else { 57 | cli::cli_abort( 58 | "{.arg layer} must be a layer, not {.obj_type_friendly {layer}}." 59 | ) 60 | } 61 | } 62 | 63 | old_geom <- layer$geom 64 | new_geom <- ggproto( 65 | NULL, old_geom, 66 | draw_layer = function(self, data, params, layout, coord) { 67 | # Evaluate expression masked by plot layout 68 | panels <- layout$layout 69 | keep <- as.logical(eval_tidy(expr, panels)) 70 | 71 | # Select panels to keep 72 | keep <- rep_len(keep, nrow(panels)) 73 | panels <- panels$PANEL[keep] 74 | 75 | # Subset and pass to parent 76 | data <- vec_slice(data, data$PANEL %in% panels) 77 | ggproto_parent(old_geom, self)$draw_layer(data, params, layout, coord) 78 | } 79 | ) 80 | 81 | ggproto(NULL, layer, geom = new_geom) 82 | } 83 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(element_grob,element_part_rect) 4 | S3method(ggplot_add,MultiScale) 5 | S3method(ggplot_add,facetted_pos_scales) 6 | S3method(ggplot_add,forcedsize) 7 | S3method(ggplot_add,scale_facet) 8 | S3method(makeContent,aimed_text) 9 | S3method(makeContext,gapsegments) 10 | S3method(makeContext,gapsegmentschain) 11 | export(CoordAxesInside) 12 | export(FacetGrid2) 13 | export(FacetManual) 14 | export(FacetNested) 15 | export(FacetNestedWrap) 16 | export(FacetWrap2) 17 | export(GeomBox) 18 | export(GeomPointPath) 19 | export(GeomPointpath) 20 | export(GeomPolygonRaster) 21 | export(GeomRectMargin) 22 | export(GeomTextAimed) 23 | export(GeomTileMargin) 24 | export(GuideStringlegend) 25 | export(PositionDisjointRanges) 26 | export(PositionLinearTrans) 27 | export(StatDifference) 28 | export(StatFunxy) 29 | export(StatRle) 30 | export(StatRollingkernel) 31 | export(StatTheoDensity) 32 | export(Strip) 33 | export(StripNested) 34 | export(StripSplit) 35 | export(StripThemed) 36 | export(at_panel) 37 | export(center_limits) 38 | export(coord_axes_inside) 39 | export(distribute_args) 40 | export(elem_list_rect) 41 | export(elem_list_text) 42 | export(element_part_rect) 43 | export(facet_grid2) 44 | export(facet_manual) 45 | export(facet_nested) 46 | export(facet_nested_wrap) 47 | export(facet_wrap2) 48 | export(facetted_pos_scales) 49 | export(force_panelsizes) 50 | export(geom_box) 51 | export(geom_outline_point) 52 | export(geom_pointpath) 53 | export(geom_polygonraster) 54 | export(geom_rectmargin) 55 | export(geom_text_aimed) 56 | export(geom_tilemargin) 57 | export(ggsubset) 58 | export(guide_axis_color) 59 | export(guide_axis_colour) 60 | export(guide_axis_manual) 61 | export(guide_axis_minor) 62 | export(guide_axis_nested) 63 | export(guide_axis_scalebar) 64 | export(guide_axis_truncated) 65 | export(guide_dendro) 66 | export(guide_stringlegend) 67 | export(help_secondary) 68 | export(position_disjoint_ranges) 69 | export(position_lineartrans) 70 | export(save_plot) 71 | export(scale_colour_multi) 72 | export(scale_fill_multi) 73 | export(scale_listed) 74 | export(scale_x_dendrogram) 75 | export(scale_x_facet) 76 | export(scale_x_manual) 77 | export(scale_y_dendrogram) 78 | export(scale_y_facet) 79 | export(scale_y_manual) 80 | export(sep_discrete) 81 | export(stat_centroid) 82 | export(stat_difference) 83 | export(stat_funxy) 84 | export(stat_midpoint) 85 | export(stat_rle) 86 | export(stat_rollingkernel) 87 | export(stat_theodensity) 88 | export(strip_nested) 89 | export(strip_split) 90 | export(strip_tag) 91 | export(strip_themed) 92 | export(strip_vanilla) 93 | export(weave_factors) 94 | if (packageVersion("ggplot2") <= "3.5.0") export(guide_axis_logticks) 95 | import(ggplot2) 96 | import(grid) 97 | import(gtable) 98 | import(rlang) 99 | import(scales) 100 | import(vctrs) 101 | importFrom(cli,cli_abort) 102 | importFrom(ggplot2,layer) 103 | importFrom(lifecycle,deprecated) 104 | importFrom(stats,ccf) 105 | importFrom(stats,coef) 106 | importFrom(stats,dcauchy) 107 | importFrom(stats,dnorm) 108 | importFrom(stats,dunif) 109 | importFrom(stats,lm) 110 | importFrom(stats,median) 111 | importFrom(stats,rt) 112 | importFrom(stats,setNames) 113 | importFrom(utils,getFromNamespace) 114 | importFrom(utils,head) 115 | importFrom(utils,tail) 116 | -------------------------------------------------------------------------------- /R/deprecated.R: -------------------------------------------------------------------------------- 1 | #' Deprecated functions 2 | #' 3 | #' The functions listed here are deprecated and no longer work. 4 | #' 5 | #' @param ... Not used. 6 | #' 7 | #' @returns None, raises deprecation signal 8 | #' @name deprecated 9 | #' 10 | #' @examples 11 | #' # None 12 | NULL 13 | 14 | #' @rawNamespace if (packageVersion("ggplot2") <= "3.5.0") export(guide_axis_logticks) 15 | #' @rdname deprecated 16 | guide_axis_logticks <- function(...) { 17 | lifecycle::deprecate_warn( 18 | "0.3.0", 19 | "ggh4x::guide_axis_logticks()", 20 | "ggplot2::guide_axis_logticks()" 21 | ) 22 | ggplot2::guide_axis_logticks() 23 | } 24 | 25 | #' @export 26 | #' @rdname deprecated 27 | guide_axis_manual <- function(...) { 28 | lifecycle::deprecate_warn( 29 | "0.3.0", 30 | "guide_axis_manual()", 31 | "legendry::guide_axis_base()" 32 | ) 33 | guide_axis() 34 | } 35 | 36 | #' @export 37 | #' @rdname deprecated 38 | guide_axis_minor <- function(...) { 39 | lifecycle::deprecate_warn( 40 | "0.3.0", 41 | "guide_axis_minor()", 42 | I("`ggplot2::guide_axis(minor.ticks = TRUE)`") 43 | ) 44 | guide_axis() 45 | } 46 | 47 | #' @export 48 | #' @rdname deprecated 49 | guide_axis_nested <- function(...) { 50 | lifecycle::deprecate_warn( 51 | "0.3.0", 52 | "guide_axis_nested()", 53 | "legendry::guide_axis_nested()" 54 | ) 55 | guide_axis() 56 | } 57 | 58 | #' @export 59 | #' @rdname deprecated 60 | guide_axis_scalebar <- function(...) { 61 | lifecycle::deprecate_warn( 62 | "0.3.0", 63 | "guide_axis_scalebar()", 64 | "legendry::primitive_bracket()" 65 | ) 66 | guide_axis() 67 | } 68 | 69 | #' @export 70 | #' @rdname deprecated 71 | guide_axis_truncated <- function(...) { 72 | lifecycle::deprecate_warn( 73 | "0.3.0", 74 | "guide_axis_truncated()", 75 | I("`ggplot2::guide_axis(cap = TRUE)`") 76 | ) 77 | guide_axis() 78 | } 79 | 80 | #' @export 81 | #' @rdname deprecated 82 | guide_axis_colour <- function(...) { 83 | lifecycle::deprecate_warn( 84 | "0.3.0", 85 | "guide_axis_truncated()", 86 | I("`ggplot2::guide_axis(theme)`") 87 | ) 88 | guide_axis() 89 | } 90 | 91 | #' @export 92 | #' @rdname deprecated 93 | guide_axis_color <- guide_axis_colour 94 | 95 | #' @export 96 | #' @rdname deprecated 97 | guide_dendro <- function(...) { 98 | lifecycle::deprecate_warn( 99 | "0.3.0", 100 | "ggh4x::guide_dendro()", 101 | "legendry::guide_axis_dendro()" 102 | ) 103 | guide_axis() 104 | } 105 | 106 | #' @export 107 | #' @rdname deprecated 108 | ggsubset <- function(...) { 109 | lifecycle::deprecate_stop( 110 | "0.2.0", 111 | "ggsubset()", 112 | details = paste0("This is best replaced by using ", 113 | "`data = ~ subset(.x, ...)` instead.") 114 | ) 115 | } 116 | 117 | #' @export 118 | #' @rdname deprecated 119 | scale_x_dendrogram <- function(...) { 120 | lifecycle::deprecate_warn( 121 | "0.3.0", 122 | "ggh4x::scale_x_dendrogram()", 123 | "legendry::scale_x_dendro()" 124 | ) 125 | scale_x_discrete() 126 | } 127 | 128 | #' @export 129 | #' @rdname deprecated 130 | scale_y_dendrogram <- function(...) { 131 | lifecycle::deprecate_warn( 132 | "0.3.0", 133 | "ggh4x::scale_y_dendrogram()", 134 | "legendry::scale_y_dendro()" 135 | ) 136 | scale_y_discrete() 137 | } 138 | -------------------------------------------------------------------------------- /man/coord_axes_inside.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coord_axes_inside.R 3 | \name{coord_axes_inside} 4 | \alias{coord_axes_inside} 5 | \title{Cartesian coordinates with interior axes} 6 | \usage{ 7 | coord_axes_inside( 8 | xlim = NULL, 9 | ylim = NULL, 10 | xintercept = 0, 11 | yintercept = 0, 12 | labels_inside = FALSE, 13 | ratio = NULL, 14 | expand = TRUE, 15 | default = FALSE, 16 | clip = "on" 17 | ) 18 | } 19 | \arguments{ 20 | \item{xlim, ylim}{Limits for the x and y axes.} 21 | 22 | \item{xintercept, yintercept}{A \code{numeric(1)} for the positions where the 23 | orthogonal axes should be placed. If these are outside the bounds of the 24 | limits, the axes are placed to the nearest extreme.} 25 | 26 | \item{labels_inside}{One of \code{"x"}, \code{"y"}, \code{"both"} or \code{"none"} specifying 27 | the axes where labels should be placed inside the panel along the axes. 28 | \code{TRUE} is translated as \code{"both"} and \code{FALSE} (default) is translated as 29 | \code{"none"}.} 30 | 31 | \item{ratio}{Either \code{NULL}, or a \code{numeric(1)} for a fixed aspect ratio, 32 | expressed as \code{y / x}.} 33 | 34 | \item{expand}{If \code{TRUE}, the default, adds a small expansion factor to 35 | the limits to ensure that data and axes don't overlap. If \code{FALSE}, 36 | limits are taken exactly from the data or \code{xlim}/\code{ylim}.} 37 | 38 | \item{default}{Is this the default coordinate system? If \code{FALSE} (the default), 39 | then replacing this coordinate system with another one creates a message alerting 40 | the user that the coordinate system is being replaced. If \code{TRUE}, that warning 41 | is suppressed.} 42 | 43 | \item{clip}{Should drawing be clipped to the extent of the plot panel? A 44 | setting of \code{"on"} (the default) means yes, and a setting of \code{"off"} 45 | means no. In most cases, the default of \code{"on"} should not be changed, 46 | as setting \code{clip = "off"} can cause unexpected results. It allows 47 | drawing of data points anywhere on the plot, including in the plot margins. If 48 | limits are set via \code{xlim} and \code{ylim} and some data points fall outside those 49 | limits, then those data points may show up in places such as the axes, the 50 | legend, the plot title, or the plot margins.} 51 | } 52 | \value{ 53 | A \code{CoordAxesInside} object, which can be added to a plot. 54 | } 55 | \description{ 56 | This coordinate system places the plot axes at interior positions. Other 57 | than this, it behaves like \code{\link[ggplot2:coord_cartesian]{coord_cartesian()}} or 58 | \code{\link[ggplot2:coord_fixed]{coord_fixed()}} (the latter if the \code{ratio} argument 59 | is set). 60 | } 61 | \examples{ 62 | # A standard plot 63 | p <- ggplot(mpg, aes(scale(displ), scale(hwy))) + 64 | geom_point() + 65 | theme(axis.line = element_line()) 66 | 67 | # By default, axis text is still placed outside the panel 68 | p + coord_axes_inside() 69 | 70 | # However, this can simply be changed 71 | p + coord_axes_inside(labels_inside = TRUE) 72 | 73 | # The place where the axes meet can be changed 74 | p + coord_axes_inside(xintercept = 1, yintercept = -1) 75 | 76 | # Axes snap to the nearest limit when out-of-bounds 77 | p + coord_axes_inside(xintercept = -5, yintercept = Inf, clip = "off") 78 | 79 | # Can be combined with other non-default axes 80 | p + guides(x = guide_axis(minor.ticks = TRUE)) + 81 | coord_axes_inside() 82 | } 83 | -------------------------------------------------------------------------------- /tests/testthat/test-facet_manual.R: -------------------------------------------------------------------------------- 1 | # Construction ------------------------------------------------------------ 2 | 3 | test_that("facet_manual can be constructed", { 4 | test <- facet_manual(vars(a), design = "A") 5 | expect_s3_class(test, c("FacetManual", "FacetWrap2", "FacetWrap")) 6 | }) 7 | 8 | test_that("facet_manual returns facet_null without vars", { 9 | test <- facet_manual(vars(), design = "A") 10 | expect_s3_class(test, c("FacetNull", "Facet")) 11 | }) 12 | 13 | test_that("facet_manual matches widths/heights to design", { 14 | test <- facet_manual(vars(a), design = matrix(c(1,1,2,2), 2, 2), 15 | widths = 1, height = c(0.5, 2)) 16 | test <- test$params[c("widths", "heights")] 17 | expect_equal(test$widths, unit(c(1, 1), "null")) 18 | expect_equal(test$heights, unit(c(0.5, 2), "null")) 19 | }) 20 | 21 | # Correctness ------------------------------------------------------------- 22 | 23 | test_that("facet_manual rejects some designs", { 24 | expect_snapshot_error(validate_design(list(1, "A"))) 25 | 26 | expect_snapshot_error(validate_design("AA\nB")) 27 | 28 | expect_snapshot_error(validate_design(NULL)) 29 | }) 30 | 31 | test_that("facet_manual can build correct plots", { 32 | design <- " 33 | A## 34 | AB# 35 | #BC 36 | ##C 37 | " 38 | p <- ggplot(mtcars, aes(mpg, wt)) + 39 | geom_point() + 40 | facet_manual(vars(cyl), design) 41 | p <- ggplot_build(p) 42 | 43 | gt <- ggplot_gtable(p)$layout 44 | 45 | extra <- if (new_guide_system) 2 else 0 46 | 47 | # Test panel positions 48 | panels <- gt[grepl("^panel-", gt$name), , drop = FALSE] 49 | expect_equal(unlist(panels[1:4], use.names = FALSE), 50 | c(8, 12, 17, 5, 9, 13, 12, 17, 20, 5, 9, 13) + extra) 51 | # Test axis positions 52 | axes_b <- gt[grepl("^axis-b-", gt$name), , drop = FALSE] 53 | expect_equal(unname(panels$b), unname(axes_b$b - 1)) 54 | axes_l <- gt[grepl("^axis-l-", gt$name), , drop = FALSE] 55 | expect_equal(unname(panels$l), unname(axes_l$l) + 1) 56 | # Test strip positions 57 | strips <- gt[grepl("^strip-t-", gt$name), , drop = FALSE] 58 | expect_equal(unname(panels$t), unname(strips$t) + 1) 59 | }) 60 | 61 | test_that("facet_manual can assume layouts", { 62 | design <- matrix(c(3,3,2,1), 2, 2) 63 | p <- ggplot(mtcars, aes(mpg, wt)) + 64 | geom_point() + 65 | facet_manual(vars(cyl), design, strip.position = "right") + 66 | scale_x_continuous(position = "top") + 67 | scale_y_continuous(position = "right") + 68 | theme(strip.placement = "outside") 69 | p <- ggplot_build(p) 70 | 71 | gtab <- ggplot_gtable(p) 72 | gt <- gtab$layout 73 | 74 | # Test panel positions 75 | extra <- if (new_guide_system) 2 else 0 76 | panels <- gt[grepl("^panel-", gt$name), , drop = FALSE] 77 | expect_equal(unlist(panels[1:4], use.names = FALSE), 78 | c(11, 7, 7, 11, 11, 5, 11, 7, 11, 11, 11, 5) + extra) 79 | # Test axis positions 80 | axes_t <- gt[grepl("^axis-t-", gt$name), , drop = FALSE] 81 | expect_equal(unname(panels$t), unname(axes_t$t) + 1) 82 | axes_r <- gt[grepl("^axis-r-", gt$name), , drop = FALSE] 83 | expect_equal(unname(panels$r), unname(axes_r$r) - 1) 84 | # Test strip positions 85 | strips <- gt[grepl("^strip-r-", gt$name), , drop = FALSE] 86 | # 1 offset for axis, 1 offset for padding, 1 offset for strip 87 | expect_equal(unname(panels$r), unname(strips$r) - 3) 88 | }) 89 | 90 | # Visual tests ------------------------------------------------------------ 91 | -------------------------------------------------------------------------------- /man/strip_nested.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/strip_nested.R 3 | \name{strip_nested} 4 | \alias{strip_nested} 5 | \title{Nested strips} 6 | \usage{ 7 | strip_nested( 8 | clip = "inherit", 9 | size = "constant", 10 | bleed = FALSE, 11 | text_x = NULL, 12 | text_y = NULL, 13 | background_x = NULL, 14 | background_y = NULL, 15 | by_layer_x = FALSE, 16 | by_layer_y = FALSE 17 | ) 18 | } 19 | \arguments{ 20 | \item{clip}{A \code{character(1)} that controls whether text labels are clipped to 21 | the background boxes. Can be either \code{"inherit"} (default), \code{"on"} or 22 | \code{"off"}.} 23 | 24 | \item{size}{A \code{character(1)} stating that the strip margins in different 25 | layers remain \code{"constant"} or are \code{"variable"}.} 26 | 27 | \item{bleed}{A \code{logical(1)} indicating whether merging of lower-layer 28 | variables is allowed when the higher-layer variables are separate. See 29 | details.} 30 | 31 | \item{text_x, text_y}{A \code{list()} with 32 | \code{\link[ggplot2:element]{element_text()}} elements. See the details 33 | section in \code{\link[=strip_themed]{strip_themed()}}.} 34 | 35 | \item{background_x, background_y}{A \code{list()} with 36 | \code{\link[ggplot2:element]{element_rect()}} elements. See the details 37 | section in \code{\link[=strip_themed]{strip_themed()}}.} 38 | 39 | \item{by_layer_x, by_layer_y}{A \code{logical(1)} that when \code{TRUE}, maps the 40 | different elements to different layers of the strip. When \code{FALSE}, maps the 41 | different elements to individual strips, possibly repeating the elements to 42 | match the number of strips through \code{rep_len()}.} 43 | } 44 | \value{ 45 | A \code{StripNested} ggproto object that can be given as an argument to 46 | facets in ggh4x. 47 | } 48 | \description{ 49 | This strip style groups strips on the same layer that share a label. It is 50 | the default strip for \code{\link[=facet_nested]{facet_nested()}} and 51 | \code{\link[=facet_nested_wrap]{facet_nested_wrap()}}. 52 | } 53 | \details{ 54 | The display order is always such that the outermost 55 | variable is placed the furthest away from the panels. Strips are 56 | automatically grouped when they span a nested variable. 57 | 58 | The \code{bleed} argument controls whether lower-layer strips are allowed 59 | to be merged when higher-layer strips are different, i.e. they can bleed 60 | over hierarchies. Suppose the \code{strip_vanilla()} behaviour would be the 61 | following for strips: 62 | 63 | \verb{[_1_][_2_][_2_]} \cr \verb{[_3_][_3_][_4_]} 64 | 65 | In such case, the default \code{bleed = FALSE} argument would result in the 66 | following: 67 | 68 | \verb{[_1_][___2____]} \cr \verb{[_3_][_3_][_4_]} 69 | 70 | Whereas \code{bleed = TRUE} would allow the following: 71 | 72 | \verb{[_1_][___2____]} \cr \verb{[___3____][_4_]} 73 | } 74 | \examples{ 75 | # A standard plot 76 | p <- ggplot(mpg, aes(displ, hwy)) + 77 | geom_point() 78 | 79 | # Combine the strips 80 | p + facet_wrap2(vars(cyl, drv), strip = strip_nested()) 81 | 82 | # The facet_nested and facet_nested_wrap functions have nested strips 83 | # automatically 84 | p + facet_nested_wrap(vars(cyl, drv)) 85 | 86 | # Changing the bleed argument merges the "f" labels in the top-right 87 | p + facet_wrap2(vars(cyl, drv), strip = strip_nested(bleed = TRUE)) 88 | } 89 | \seealso{ 90 | Other strips: 91 | \code{\link{strip_split}()}, 92 | \code{\link{strip_tag}()}, 93 | \code{\link{strip_themed}()}, 94 | \code{\link{strip_vanilla}()} 95 | } 96 | \concept{strips} 97 | -------------------------------------------------------------------------------- /man/strip_themed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/strip_themed.R 3 | \name{strip_themed} 4 | \alias{strip_themed} 5 | \title{Strip with themed boxes and texts} 6 | \usage{ 7 | strip_themed( 8 | clip = "inherit", 9 | size = "constant", 10 | text_x = NULL, 11 | text_y = NULL, 12 | background_x = NULL, 13 | background_y = NULL, 14 | by_layer_x = FALSE, 15 | by_layer_y = FALSE 16 | ) 17 | } 18 | \arguments{ 19 | \item{clip}{A \code{character(1)} that controls whether text labels are clipped to 20 | the background boxes. Can be either \code{"inherit"} (default), \code{"on"} or 21 | \code{"off"}.} 22 | 23 | \item{size}{A \code{character(1)} stating that the strip margins in different 24 | layers remain \code{"constant"} or are \code{"variable"}.} 25 | 26 | \item{text_x, text_y}{A \code{list()} with 27 | \code{\link[ggplot2:element]{element_text()}} elements. See details.} 28 | 29 | \item{background_x, background_y}{A \code{list()} with 30 | \code{\link[ggplot2:element]{element_rect()}} elements. See details.} 31 | 32 | \item{by_layer_x, by_layer_y}{A \code{logical(1)} that when \code{TRUE}, maps the 33 | different elements to different layers of the strip. When \code{FALSE}, maps the 34 | different elements to individual strips, possibly repeating the elements 35 | to match the number of strips through \code{rep_len()}.} 36 | } 37 | \value{ 38 | A \code{StripThemed} ggproto object that can be given as an argument to 39 | facets in ggh4x. 40 | } 41 | \description{ 42 | A style of strips with individually themed strips. 43 | } 44 | \details{ 45 | With respect to the \verb{text_*} and \verb{background_*} arguments, they can 46 | be a list with (a mix of) the following objects: 47 | \itemize{ 48 | \item \code{NULL} indicates that the global plot theme applies. 49 | \item \code{element_blank()} omits drawing the background or text. 50 | \item An \code{element} class object inheriting from the \code{element_text} or 51 | \code{element_rect} classes. 52 | } 53 | 54 | For constructing homogeneous lists of elements, the 55 | \code{\link[=elem_list_text]{elem_list_text()}} and 56 | \code{\link[=elem_list_rect]{elem_list_rect()}} are provided for convenience. 57 | } 58 | \examples{ 59 | # Some simple plot 60 | p <- ggplot(mpg, aes(displ, hwy)) + 61 | geom_point() 62 | 63 | # Set some theming options, we can use `element_blank()` 64 | backgrounds <- list(element_blank(), element_rect(fill = "dodgerblue")) 65 | # Or we could use `NULL` to use the global theme 66 | texts <- list(element_text(colour = "red"), NULL, element_text(face = "bold")) 67 | 68 | # Elements are repeated until the fit the number of facets 69 | p + facet_wrap2( 70 | vars(drv, year), 71 | strip = strip_themed( 72 | background_x = backgrounds, 73 | text_x = texts 74 | ) 75 | ) 76 | 77 | # Except when applied to each layer instead of every strip 78 | p + facet_wrap2( 79 | vars(drv, year), 80 | strip = strip_themed( 81 | background_x = backgrounds, 82 | text_x = texts, 83 | by_layer_x = TRUE 84 | ) 85 | ) 86 | 87 | # To conveniently distribute arguments over a list of the same elements, 88 | # you can use the following wrappers: 89 | p + facet_wrap2( 90 | vars(drv, year), 91 | strip = strip_themed( 92 | text_x = elem_list_text(colour = c("blue", "red")), 93 | background_x = elem_list_rect(fill = c("white", "grey80")), 94 | by_layer_x = TRUE 95 | ) 96 | ) 97 | } 98 | \seealso{ 99 | Other strips: 100 | \code{\link{strip_nested}()}, 101 | \code{\link{strip_split}()}, 102 | \code{\link{strip_tag}()}, 103 | \code{\link{strip_vanilla}()} 104 | } 105 | \concept{strips} 106 | -------------------------------------------------------------------------------- /man/scale_facet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scale_facet.R 3 | \name{scale_facet} 4 | \alias{scale_facet} 5 | \alias{scale_x_facet} 6 | \alias{scale_y_facet} 7 | \title{Position scales for individual panels in facets} 8 | \usage{ 9 | scale_x_facet(expr, ..., type = "continuous") 10 | 11 | scale_y_facet(expr, ..., type = "continuous") 12 | } 13 | \arguments{ 14 | \item{expr}{An \code{expression} that, when evaluated in the facet's layout 15 | data.frame, yields a \code{logical} vector. See details.} 16 | 17 | \item{...}{Other arguments passed to the scale.} 18 | 19 | \item{type}{A \code{character(1)} indicating the type of scale, such that 20 | \verb{scale_(x/y)_\{type\}} spells a scale function. Defaults to \code{"continuous"}.} 21 | } 22 | \value{ 23 | A \code{scale_facet} object that can be added to a plot. 24 | } 25 | \description{ 26 | This function adds position scales (x and y) of individual panels. These 27 | can be used to fine-tune limits, breaks and other scale parameters for 28 | individual panels, provided the facet allows free scales. 29 | } 30 | \details{ 31 | These scale functions work through the mechanism of the 32 | \code{\link[=facetted_pos_scales]{facetted_pos_scales()}} function, and the same limitations apply: scale 33 | transformations are applied after \code{stat} transformations, and the \code{oob} 34 | argument of scales is ignored. 35 | 36 | For the \code{expr} argument, the expression will be evaluated in the context 37 | of the plot's layout. This is an internal \code{data.frame} structure that 38 | isn't normally exposed, so it requires some extra knowledge. For most 39 | facets, the layout describes the panels, with one panel per row. It 40 | typically has \code{COL}, \code{ROW} and \code{PANEL} columns that keep track of what 41 | panel goes where in a grid of cells. In addition, it contains the 42 | facetting variables provided to the \code{facets} or \code{rows} and \code{cols} arguments 43 | of the facets. For example, if we have a plot facetted on the \code{var} 44 | variable with the levels \code{A}, \code{B} and \code{C}, as 1 row and 3 columns, we might 45 | target the second \code{B} panel with any of these expressions: \code{var == "B"}, 46 | \code{PANEL == 2} or \code{COL == 2}. We can inspect the layout structure by using 47 | \code{ggplot_build(p)$layout$layout}, wherein \code{p} is a plot. 48 | 49 | When using multiple \verb{scale_(x/y)_facet()}, the \code{expr} argument can target 50 | the same panels. In such case, the scales added to the plot first overrule 51 | the scales that were added later. 52 | } 53 | \examples{ 54 | # A standard plot with continuous scales 55 | p <- ggplot(mtcars, aes(disp, mpg)) + 56 | geom_point() + 57 | facet_wrap(~ cyl, scales = "free") 58 | 59 | # Adding a scale for a value for a facetting variable 60 | p + scale_x_facet(cyl == 8, limits = c(200, 600)) 61 | 62 | # Adding a scale by position in the layout 63 | p + scale_x_facet(COL == 3, limits = c(200, 600)) 64 | 65 | # Setting the default scale and making an exception for one panel 66 | p + scale_y_continuous(limits = c(0, 40)) + 67 | scale_y_facet(PANEL == 1, limits = c(10, 50)) 68 | 69 | # Using multiple panel-specific scales 70 | p + scale_y_facet(PANEL == 1, limits = c(10, 50)) + 71 | scale_y_facet(cyl == 6, breaks = scales::breaks_width(0.5)) 72 | 73 | # When multiple scales target the same panel, the scale added first gets 74 | # priority over scales added later. 75 | p + scale_y_facet(COL == 2, limits = c(10, 40)) + 76 | scale_y_facet(cyl \%in\% c(4, 6), breaks = scales::breaks_width(1)) 77 | 78 | # A standard plot with discrete x scales 79 | p <- ggplot(mtcars, aes(factor(cyl), mpg)) + 80 | geom_boxplot() + 81 | facet_wrap(~ vs, scales = "free") 82 | 83 | # Expanding limits to show every level 84 | p + scale_x_facet(vs == 1, limits = factor(c(4, 6, 8)), type = "discrete") 85 | 86 | # Shrinking limits to hide a level 87 | p + scale_x_facet(vs == 0, limits = factor(c(4, 6)), type = "discrete") 88 | } 89 | \seealso{ 90 | The \code{\link[=facetted_pos_scales]{facetted_pos_scales()}} function. 91 | } 92 | -------------------------------------------------------------------------------- /tests/testthat/test-facet_nested_wrap.R: -------------------------------------------------------------------------------- 1 | # Setup basic plot -------------------------------------------------------- 2 | 3 | basic <- ggplot(mpg, aes(displ, hwy)) + 4 | geom_point() 5 | 6 | 7 | # Basic tests ------------------------------------------------------------- 8 | 9 | test_that("facet_nested_wrap can be added to a plot", { 10 | g <- basic + facet_nested_wrap(vars(cyl, drv)) 11 | expect_s3_class(g$facet, "gg") 12 | expect_s3_class(g$facet, "Facet") 13 | expect_s3_class(g$facet, "FacetWrap2") 14 | expect_s3_class(g$facet, "FacetNestedWrap") 15 | }) 16 | 17 | test_that("facet_nested_wrap can be build", { 18 | g <- basic + facet_nested_wrap(vars(cyl, drv), dir = "v") 19 | g <- ggplot_build(g) 20 | expect_s3_class(g$layout, "Layout") 21 | expect_true(is_ggplot(g$plot)) 22 | }) 23 | 24 | test_that("facet_nested_wrap can be interpreted as gtable", { 25 | test <- basic + facet_nested_wrap(vars(cyl, drv)) 26 | ctrl <- basic + facet_wrap(vars(cyl, drv)) 27 | 28 | test <- ggplotGrob(test) 29 | ctrl <- ggplotGrob(ctrl) 30 | 31 | expect_equal(class(ctrl), class(test)) 32 | expect_s3_class(test, "gtable") 33 | }) 34 | 35 | default <- basic + facet_nested_wrap(vars(cyl, drv)) 36 | default_gtable <- ggplotGrob(default) 37 | 38 | test_that("facet_nested_wrap doesn't nest 1-dimensional strips",{ 39 | test <- basic + facet_nested_wrap(vars(cyl)) 40 | ctrl <- basic + facet_wrap(vars(cyl)) 41 | 42 | test <- ggplotGrob(test) 43 | ctrl <- ggplotGrob(ctrl) 44 | 45 | test <- sum(grepl("strip", test$layout$name)) 46 | ctrl <- sum(grepl("strip", ctrl$layout$name)) 47 | 48 | expect_equal(test, ctrl) 49 | }) 50 | 51 | test_that("facet_nested_wrap bleed argument works", { 52 | test <- basic + facet_nested_wrap(vars(cyl, drv), 53 | strip = strip_nested(bleed = TRUE)) 54 | 55 | test <- ggplotGrob(test) 56 | ctrl <- default_gtable 57 | 58 | test <- sum(grepl("strip", test$layout$name)) 59 | ctrl <- sum(grepl("strip", ctrl$layout$name)) 60 | 61 | expect_equal(test + 1, ctrl) 62 | }) 63 | 64 | test_that("facet_nested_wrap nest_line parameter works", { 65 | f <- quote(facet_nested_wrap(vars(cyl, drv), nest_line = element_rect())) 66 | expect_error(eval(f)) 67 | 68 | f <- facet_nested_wrap(vars(cyl, drv), nest_line = FALSE) 69 | expect_true(is_theme_element(f$params$nest_line, "blank")) 70 | 71 | f <- facet_nested_wrap(vars(cyl, drv), nest_line = TRUE) 72 | expect_true(is_theme_element(f$params$nest_line, "line")) 73 | 74 | test <- basic + f 75 | 76 | test <- ggplotGrob(test) 77 | ctrl <- default_gtable 78 | 79 | test <- test$grobs[test$layout$name == "strip-t-1-1"][[1]] 80 | ctrl <- ctrl$grobs[ctrl$layout$name == "strip-t-1-1"][[1]] 81 | 82 | expect_equal(length(test$grobs), length(ctrl$grobs) + 1) 83 | expect_true("nester" %in% test$layout$name) 84 | expect_false("nester" %in% ctrl$layout$name) 85 | }) 86 | 87 | test_that("facet_nested_wrap all strip positions are OK", { 88 | top <- basic + facet_nested_wrap(vars(cyl, drv), 89 | strip.position = "top") 90 | bottom <- basic + facet_nested_wrap(vars(cyl, drv), 91 | strip.position = "bottom") 92 | left <- basic + facet_nested_wrap(vars(cyl, drv), 93 | strip.position = "left", dir = "v") 94 | right <- basic + facet_nested_wrap(vars(cyl, drv), 95 | strip.position = "right", 96 | strip = strip_nested(bleed = TRUE)) 97 | 98 | tables <- lapply(list(top, bottom, left, right), ggplotGrob) 99 | 100 | nstrips <- vapply(tables, function(gt) { 101 | sum(grepl("strip", gt$layout$name)) 102 | }, numeric(1)) 103 | 104 | expect_equal(nstrips, c(13, 13, 13, 13)) 105 | }) 106 | 107 | test_that("facet_nested_wrap constructors throws appropriate warnings", { 108 | 109 | x <- quote(facet_nested_wrap(vars(dummy), bleed = "dummy")) 110 | expect_warning(eval(x)) 111 | }) 112 | 113 | -------------------------------------------------------------------------------- /man/strip_split.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/strip_split.R 3 | \name{strip_split} 4 | \alias{strip_split} 5 | \title{Split strips} 6 | \usage{ 7 | strip_split( 8 | position = c("top", "left"), 9 | clip = "inherit", 10 | size = "constant", 11 | bleed = FALSE, 12 | text_x = NULL, 13 | text_y = NULL, 14 | background_x = NULL, 15 | background_y = NULL, 16 | by_layer_x = FALSE, 17 | by_layer_y = FALSE 18 | ) 19 | } 20 | \arguments{ 21 | \item{position}{A \code{character} vector stating where the strips of faceting 22 | variables should be placed. Can be some of the following: \code{"top"}, 23 | \code{"bottom"}, \code{"left"} or \code{"right"}. The length of the \code{position} argument 24 | must match the length of variables provided to the \code{facets} argument in 25 | wrap/manual layouts, or those provided to the \code{rows} and \code{cols} arguments 26 | in the grid layout.} 27 | 28 | \item{clip}{A \code{character(1)} that controls whether text labels are clipped to 29 | the background boxes. Can be either \code{"inherit"} (default), \code{"on"} or 30 | \code{"off"}.} 31 | 32 | \item{size}{A \code{character(1)} stating that the strip margins in different 33 | layers remain \code{"constant"} or are \code{"variable"}.} 34 | 35 | \item{bleed}{A \code{logical(1)} indicating whether merging of lower-layer 36 | variables is allowed when the higher-layer variables are separate. See 37 | the details of \code{\link{strip_nested}} for more info. Note that currently, 38 | \code{strip_split()} cannot recognise collisions between strips, so changing 39 | to \code{bleed = TRUE} can have unexpected results.} 40 | 41 | \item{text_x, text_y}{A \code{list()} with 42 | \code{\link[ggplot2:element]{element_text()}} elements. See the details 43 | section in \code{\link[=strip_themed]{strip_themed()}}.} 44 | 45 | \item{background_x, background_y}{A \code{list()} with 46 | \code{\link[ggplot2:element]{element_rect()}} elements. See the details 47 | section in \code{\link[=strip_themed]{strip_themed()}}.} 48 | 49 | \item{by_layer_x, by_layer_y}{A \code{logical(1)} that when \code{TRUE}, maps the 50 | different elements to different layers of the strip. When \code{FALSE}, maps the 51 | different elements to individual strips, possibly repeating the elements to 52 | match the number of strips through \code{rep_len()}.} 53 | } 54 | \value{ 55 | A \code{StripSplit} ggproto object that can be given as an argument to 56 | facets in ggh4x. 57 | } 58 | \description{ 59 | \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} 60 | 61 | This strip style allows a greater control over where a strip is placed 62 | relative to the panel. Different facetting variables are allowed to be 63 | placed on different sides. 64 | } 65 | \details{ 66 | Using this style of strip completely overrules the \code{strip.position} 67 | and \code{switch} arguments. 68 | } 69 | \examples{ 70 | # A standard plot 71 | p <- ggplot(mpg, aes(displ, hwy)) + 72 | geom_point() 73 | 74 | # --- Wrap examples ------ 75 | 76 | # Defaults to 1st (cyl) at top, 2nd (drv) on left 77 | p + facet_wrap2(vars(cyl, drv), strip = strip_split()) 78 | 79 | # Change cyl to left, drv to bottom 80 | p + facet_wrap2(vars(cyl, drv), strip = strip_split(c("left", "bottom"))) 81 | 82 | # --- Grid examples ----- 83 | 84 | # Display both strips levels on the left 85 | p + facet_grid2(vars(drv), vars(cyl), 86 | strip = strip_split(c("left", "left"))) 87 | 88 | # Separate the strips again 89 | p + facet_grid2(vars(cyl, year), 90 | strip = strip_split(c("bottom", "left"))) 91 | 92 | # Using a dummy variable as a title strip 93 | p + facet_grid2(vars(cyl, "year", year), 94 | strip = strip_split(c("bottom", "left", "left"))) 95 | } 96 | \seealso{ 97 | Other strips: 98 | \code{\link{strip_nested}()}, 99 | \code{\link{strip_tag}()}, 100 | \code{\link{strip_themed}()}, 101 | \code{\link{strip_vanilla}()} 102 | } 103 | \concept{strips} 104 | -------------------------------------------------------------------------------- /man/facetted_pos_scales.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/facetted_pos_scales.R 3 | \name{facetted_pos_scales} 4 | \alias{facetted_pos_scales} 5 | \title{Set individual scales in facets} 6 | \usage{ 7 | facetted_pos_scales(x = NULL, y = NULL) 8 | } 9 | \arguments{ 10 | \item{x, y}{A \code{list} wherein elements are either x/y position scales or 11 | \code{NULL}s. Alternatively, a list of formulae (see details).} 12 | } 13 | \value{ 14 | A \emph{facetted_pos_scales} object, instructing a ggplot how to 15 | adjust the scales per facet. 16 | } 17 | \description{ 18 | This function allows the tweaking of the position scales (x and y) of 19 | individual facets. You can use it to fine-tune limits, breaks and other scale 20 | parameters for individual facets, provided the facet allows free scales. 21 | } 22 | \details{ 23 | It is intended that this function works with both 24 | \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} and \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}}. 25 | For \code{facet_wrap}, the scales are used for each individual panel. For 26 | \code{facet_grid}, the scales are used for the rows and columns. Note that 27 | these facets must be used with \code{scales = "free"} or \code{"free_x"} or 28 | \code{"free_y"}, depending on what scales are added. 29 | 30 | Axis titles are derived from the first scale in the list (or the default 31 | position scale when the first list element is \code{NULL}). 32 | 33 | \subsection{Scale transformations}{It is allowed to use individual scale 34 | transformations for facets, but this functionality comes with the trade-off 35 | that the out of bounds (\code{oob}) argument for individual scales is 36 | ignored. Values that are out of bounds will be clipped. Whereas the 37 | \code{stat} part of a ggplot layer is typically calculated after scale 38 | transformations, the calculation of the \code{stat} happens before scale 39 | transformation with this function, which can lead to some awkward results. 40 | The suggested workaround is to pre-transform the data for layers with 41 | non-identity \code{stat} parts.} 42 | 43 | \subsection{Scale list input}{\code{NULL}s are valid list elements and 44 | signal that the default position scale should be used at the position in 45 | the list where the \code{NULL} occurs. Since transformations are applied 46 | before facet scales are initiated, it is not recommended to use a default 47 | position (either the first in the list, or defined outside 48 | \code{facetted_pos_scales()}) scale with a transformation other than 49 | \code{trans = "identity"} (the default).} 50 | 51 | \subsection{Formula list input}{The \code{x} and \code{y} arguments also 52 | accept a list of two-sided formulas. The left hand side of a formula should 53 | evaluate to a \code{logical} vector. The right hand side of the formula 54 | should evaluate to a position scale, wherein the \code{x} argument accepts 55 | x-position scales and the \code{y} argument accepts y-position scales. 56 | Notably, the left hand side of the formula is evaluated using the tidy 57 | evaluation framework, whereby the \code{data.frame} with the plot's layout 58 | is given priority over the environment in which the formula was created. As 59 | a consequence, variables (columns) that define faceting groups can be 60 | references directly.} 61 | } 62 | \examples{ 63 | plot <- ggplot(iris, aes(Sepal.Width, Sepal.Length)) + 64 | geom_point(aes(colour = Species)) + 65 | facet_wrap(Species ~ ., scales = "free_y") 66 | 67 | # Reversing the y-axis in the second panel. When providing a list of scales, 68 | # NULL indicates to use the default, global scale 69 | plot + 70 | facetted_pos_scales( 71 | y = list(NULL, scale_y_continuous(trans = "reverse")) 72 | ) 73 | 74 | # Alternative for specifying scales with formula lists. The LHS can access 75 | # columns in the plot's layout. 76 | plot + 77 | facetted_pos_scales( 78 | y = list( 79 | Species == "virginica" ~ scale_y_continuous(breaks = c(6, 7)), 80 | Species == "versicolor" ~ scale_y_reverse() 81 | ) 82 | ) 83 | } 84 | \seealso{ 85 | \code{\link[ggplot2:scale_continuous]{ggplot2::scale_x_continuous()}} and \code{scale_x_discrete}. 86 | } 87 | -------------------------------------------------------------------------------- /tests/testthat/test-facet_grid2.R: -------------------------------------------------------------------------------- 1 | p <- ggplot(mtcars, aes(disp, drat)) + geom_point() 2 | 3 | grab_axis <- function(gt, where = "b") { 4 | gt$grobs[grepl(paste0("^axis-", where), gt$layout$name)] 5 | } 6 | 7 | test_that("facet_grid2 can duplicate axes and remove labels", { 8 | test <- p + facet_grid2(vs ~ am, axes = "all", remove_labels = "y") 9 | test <- ggplotGrob(test) 10 | 11 | b <- grab_axis(test, "b") 12 | btest <- vapply(b, inherits, logical(1), "absoluteGrob") 13 | expect_length(b, 4) 14 | expect_true(all(btest)) 15 | 16 | l <- grab_axis(test, "l") 17 | ltest <- vapply(l, inherits, logical(1), "absoluteGrob") 18 | expect_length(l, 4) 19 | expect_true(all(ltest)) 20 | 21 | b <- vapply(b, function(x){length(x$children[[2]]$grobs)}, integer(1)) 22 | l <- vapply(l, function(x){length(x$children[[2]]$grobs)}, integer(1)) 23 | 24 | if (!new_guide_system) { 25 | expect_equal(b, c(2L, 2L, 2L, 2L)) 26 | expect_equal(l, c(1L, 1L, 2L, 2L)) 27 | } else { 28 | expect_equal(b, c(3L, 3L, 3L, 3L)) 29 | expect_equal(l, c(1L, 1L, 3L, 3L)) 30 | } 31 | }) 32 | 33 | test_that("facet_grid2 can have free and independent scales", { 34 | test <- p + facet_grid2(vs ~ am, scales = "free", independent = "all") 35 | ctrl <- p + facet_grid2(vs ~ am, scales = "free", independent = "none") 36 | 37 | test <- ggplot_build(test) 38 | ctrl <- ggplot_build(ctrl) 39 | 40 | test <- test$layout$layout 41 | ctrl <- ctrl$layout$layout 42 | 43 | expect_equal(test[, c("PANEL", "ROW", "COL", "vs", "am")], 44 | ctrl[, c("PANEL", "ROW", "COL", "vs", "am")]) 45 | expect_equal(test$SCALE_X, 1:4) 46 | expect_equal(ctrl$SCALE_X, c(1L, 2L, 1L, 2L)) 47 | expect_equal(test$SCALE_Y, 1:4) 48 | expect_equal(ctrl$SCALE_Y, c(1L, 1L, 2L, 2L)) 49 | }) 50 | 51 | test_that("facet_grid2 respects aspect ratio", { 52 | case_null <- p + facet_grid2(~ vs) 53 | case_asp <- case_null + theme(aspect.ratio = 2) 54 | 55 | case_null <- ggplotGrob(case_null) 56 | case_asp <- ggplotGrob(case_asp) 57 | 58 | panel_col <- panel_cols(case_null)$l 59 | panel_row <- panel_rows(case_null)$t 60 | 61 | expect_equal(as.character(case_null$widths[panel_col]), c("1null", "1null")) 62 | expect_equal(as.character(case_asp$widths[panel_col]), c("1null", "1null")) 63 | 64 | expect_equal(as.character(case_null$heights[panel_row]), "1null") 65 | expect_equal(as.character(case_asp$heights[panel_row]), "2null") 66 | 67 | expect_false(case_null$respect) 68 | expect_true(case_asp$respect) 69 | }) 70 | 71 | test_that("facet_grid2 can use `render_empty` to omit panels", { 72 | 73 | case_null <- p + facet_grid2(vars(cyl), vars(gear), render_empty = TRUE) 74 | case_test <- p + facet_grid2(vars(cyl), vars(gear), render_empty = FALSE) 75 | 76 | case_null <- ggplotGrob(case_null) 77 | case_test <- ggplotGrob(case_test) 78 | 79 | is_panel_null <- grepl("^panel", case_null$layout$name) 80 | is_panel_test <- grepl("^panel", case_test$layout$name) 81 | 82 | expect_equal(is_panel_null, is_panel_test) 83 | 84 | null_zero <- vapply(case_null$grobs[is_panel_null], inherits, what = "zeroGrob", logical(1)) 85 | expect_true(!any(null_zero)) 86 | 87 | test_zero <- vapply(case_test$grobs[is_panel_test], inherits, what = "zeroGrob", logical(1)) 88 | expect_equal(test_zero, c(rep(FALSE, 7), TRUE, FALSE)) 89 | 90 | }) 91 | 92 | test_that("facet_grid2 warns about inappropriate arguments", { 93 | expect_snapshot_error(facet_grid2(vs ~ am, independent = "x")) 94 | expect_snapshot_error(facet_grid2(vs ~ am, independent = "y")) 95 | expect_snapshot_warning( 96 | facet_grid2(vs ~ am, space = "free_x", independent = "x", scales = "free_x") 97 | ) 98 | expect_snapshot_warning( 99 | facet_grid2(vs ~ am, independent = "y", space = "free_y", scales = "free_y") 100 | ) 101 | expect_snapshot_warning( 102 | facet_grid2(vs ~ am, independent = "x", scales = "free_x", 103 | remove_labels = "x") 104 | ) 105 | expect_snapshot_warning( 106 | facet_grid2(vs ~ am, independent = "y", scales = "free_y", 107 | remove_labels = "y") 108 | ) 109 | }) 110 | -------------------------------------------------------------------------------- /R/facet_nested_wrap.R: -------------------------------------------------------------------------------- 1 | # Main function ----------------------------------------------------------- 2 | 3 | #' Ribbon of panels with nested strips. 4 | #' 5 | #' `facet_nested_wrap()` wraps a sequence of panels onto a two-dimensional 6 | #' layout, and nests grouped facets where possible. 7 | #' 8 | #' @inheritParams facet_wrap2 9 | #' @inheritParams facet_nested 10 | #' @param strip An object created by a call to a strip function, such as 11 | #' [ggh4x::strip_nested()]. 12 | #' 13 | #' @details This function inherits the capabilities of 14 | #' [ggh4x::facet_wrap2()]. 15 | #' 16 | #' This function only merges strips in the same row or column as they appear 17 | #' through regular `facet_wrap()` layout behaviour. 18 | #' 19 | #' Hierarchies are inferred from the order of variables supplied to 20 | #' `facets`. The first variable is interpreted to be the outermost 21 | #' variable, while the last variable is interpreted to be the innermost 22 | #' variable. They display order is always such that the outermost 23 | #' variable is placed the furthest away from the panels. For more information 24 | #' about the nesting of strips, please visit the documentation of 25 | #' [ggh4x::strip_nested()]. 26 | #' 27 | #' @return A `FacetNestedWrap` ggproto object that can be added to a plot. 28 | #' @export 29 | #' @family facetting functions 30 | #' @include facet_wrap2.R 31 | #' 32 | #' @seealso See [ggh4x::strip_nested()] for nested strips. See 33 | #' [ggplot2::facet_wrap()] for descriptions of the original 34 | #' arguments. See [grid::unit()] for the construction of a 35 | #' `unit` vector. 36 | #' 37 | #' @examples 38 | #' # A standard plot 39 | #' p <- ggplot(mpg, aes(displ, hwy)) + 40 | #' geom_point() 41 | #' 42 | #' # Similar to `facet_wrap2(..., strip = strip_nested())`. 43 | #' p + facet_nested_wrap(vars(cyl, drv)) 44 | #' 45 | #' # A nest line inherits from the global theme 46 | #' p + facet_nested_wrap(vars(cyl, drv), 47 | #' nest_line = element_line(colour = "red")) + 48 | #' theme(ggh4x.facet.nestline = element_line(linetype = 3)) 49 | facet_nested_wrap <- function( 50 | facets, nrow = NULL, ncol = NULL, 51 | scales = "fixed", axes = "margins", 52 | remove_labels = "none", 53 | shrink = TRUE, labeller = "label_value", 54 | as.table = TRUE, drop = TRUE, 55 | dir = "h", strip.position = "top", 56 | nest_line = element_line(inherit.blank = TRUE), 57 | solo_line = FALSE, 58 | resect = unit(0, "mm"), 59 | trim_blank = TRUE, 60 | strip = "nested", 61 | bleed = NULL 62 | ) { 63 | strip <- resolve_strip(strip) 64 | if (!is.null(bleed)) { 65 | lifecycle::deprecate_warn( 66 | when = "0.2.0", 67 | what = "facet_nested_wrap(bleed)", 68 | details = paste0("The `bleed` argument should be set in the ", 69 | "`strip_nested()` function instead.") 70 | ) 71 | strip$params$bleed <- isTRUE(bleed) 72 | } 73 | # Convert logical to elements for backward compatibility 74 | if (isTRUE(nest_line)) { 75 | nest_line <- element_line() 76 | } 77 | if (isFALSE(nest_line)) { 78 | nest_line <- element_blank() 79 | } 80 | if (!(is_theme_element(nest_line, "line") || 81 | is_theme_element(nest_line, "blank"))) { 82 | cli::cli_abort( 83 | "The {.arg nest_line} argument must be {.cls element_blank} or inherit \\ 84 | from {.cls element_line}." 85 | ) 86 | } 87 | params <- list( 88 | nest_line = nest_line, 89 | solo_line = isTRUE(solo_line), 90 | resect = resect 91 | ) 92 | new_wrap_facets( 93 | facets, nrow, ncol, 94 | scales, axes, remove_labels, 95 | shrink, labeller, 96 | as.table, drop, dir, 97 | strip.position, strip, 98 | trim_blank, params, 99 | super = FacetNestedWrap 100 | ) 101 | } 102 | 103 | # ggproto ----------------------------------------------------------------- 104 | 105 | #' @usage NULL 106 | #' @format NULL 107 | #' @export 108 | #' @rdname ggh4x_extensions 109 | FacetNestedWrap <- ggproto( 110 | "FacetNestedWrap", FacetWrap2, 111 | finish_panels = function(self, panels, layout, params, theme) { 112 | add_nest_indicator(panels, params, theme) 113 | } 114 | ) 115 | -------------------------------------------------------------------------------- /R/geom_polygonraster.R: -------------------------------------------------------------------------------- 1 | # Main function ---------------------------------------------------------------- 2 | 3 | #' Polygon parameterisation for rasters 4 | #' 5 | #' `geom_polygonraster` takes data that describes a raster with pixels of 6 | #' the same size and reparametrises the data as a polygon. This allows for more 7 | #' flexible transformations of the data, but comes at an efficiency cost. 8 | #' 9 | #' @inheritParams ggplot2::geom_raster 10 | #' 11 | #' @details For each pixel in a raster, makes a vertex for each of the four 12 | #' corner points. These coordinates can then by transformed by 13 | #' `coord`-functions such as [ggplot2::coord_polar()] or 14 | #' `position`-functions such as 15 | #' [ggh4x::position_lineartrans()]. Currently substitutes group 16 | #' aesthetics right before drawing in favour of pixel identifiers. 17 | #' 18 | #' @section Aesthetics: 19 | #' 20 | #' `geom_raster()` understands the following aesthetics (required 21 | #' aesthetics are in bold): 22 | #' 23 | #' \itemize{ 24 | #' \item **x** 25 | #' \item **y** 26 | #' \item fill 27 | #' \item alpha 28 | #' \item group 29 | #' } 30 | #' 31 | #' @seealso [`geom_raster()`][ggplot2::geom_tile] 32 | #' 33 | #' @export 34 | #' 35 | #' @return A *Layer* ggproto object. 36 | #' 37 | #' @examples 38 | #' # Combining with coord_polar() 39 | #' ggplot(faithfuld, aes(waiting, eruptions)) + 40 | #' geom_polygonraster(aes(fill = density)) + 41 | #' coord_polar() 42 | #' 43 | #' # Combining with linear transformations 44 | #' df <- data.frame(x = row(volcano)[TRUE], 45 | #' y = col(volcano)[TRUE], 46 | #' z = volcano[TRUE]) 47 | #' 48 | #' ggplot(df, aes(x, y, fill = z)) + 49 | #' geom_polygonraster(position = position_lineartrans(angle = 30, 50 | #' shear = c(1, 0))) 51 | geom_polygonraster <- function( 52 | mapping = NULL, data = NULL, stat = "identity", 53 | position = position_lineartrans(), 54 | ..., hjust = 0.5, vjust = 0.5, na.rm = FALSE, show.legend = NA, 55 | inherit.aes = TRUE 56 | ) { 57 | stopifnot(is.numeric(hjust), length(hjust) == 1) 58 | stopifnot(is.numeric(vjust), length(vjust) == 1) 59 | layer( 60 | data = data, 61 | mapping = mapping, 62 | stat = stat, 63 | geom = GeomPolygonRaster, 64 | position = position, 65 | show.legend = show.legend, 66 | inherit.aes = inherit.aes, 67 | params = list( 68 | hjust = hjust, 69 | vjust = vjust, 70 | na.rm = na.rm, 71 | ... 72 | ) 73 | ) 74 | } 75 | 76 | # ggproto ----------------------------------------------------------------- 77 | 78 | #' @usage NULL 79 | #' @format NULL 80 | #' @export 81 | #' @rdname ggh4x_extensions 82 | GeomPolygonRaster <- ggproto( 83 | "GeomPolygonRaster", GeomRaster, 84 | setup_data = function(data, params) { 85 | w <- resolution(data$x) 86 | h <- resolution(data$y) 87 | hjust <- params$hjust %||% 0.5 88 | vjust <- params$vjust %||% 0.5 89 | 90 | data$id <- seq_len(NROW(data)) 91 | 92 | coords <- matrix( 93 | c(rep(data$x - w * (1 - hjust), 2), 94 | rep(data$x + w * hjust, 2), 95 | data$y - h * (1 - vjust), 96 | rep(data$y + h * vjust, 2), 97 | data$y - h * (1 - vjust)), 98 | ncol = 2 99 | ) 100 | 101 | data <- rbind(data, data, data, data) 102 | data$x <- coords[, 1] 103 | data$y <- coords[, 2] 104 | data <- data[order(data$id), ] 105 | rownames(data) <- NULL 106 | data 107 | }, 108 | draw_panel = function(data, panel_params, coord, hjust = 0.5, vjust = 0.5) { 109 | n <- nrow(data) 110 | if (n == 1) 111 | return(zeroGrob()) 112 | 113 | data$group <- data$id 114 | coords <- coord_munch(coord, data, panel_params) 115 | 116 | first <- coords[!duplicated(data$id), ] 117 | 118 | ggname( 119 | "geom_polygon", 120 | polygonGrob( 121 | coords$x, coords$y, default.units = "native", id = coords$id, 122 | gp = gpar( 123 | col = 0, 124 | fill = alpha(first$fill, first$alpha), 125 | lwd = 0, 126 | lty = 0) 127 | ) 128 | ) 129 | } 130 | ) 131 | -------------------------------------------------------------------------------- /man/help_secondary.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/help_secondary.R 3 | \name{help_secondary} 4 | \alias{help_secondary} 5 | \title{Secondary axis helper} 6 | \usage{ 7 | help_secondary( 8 | data = NULL, 9 | primary = c(0, 1), 10 | secondary = c(0, 1), 11 | method = c("range", "max", "fit", "ccf", "sortfit"), 12 | na.rm = TRUE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{data}{A \code{data.frame} object.} 18 | 19 | \item{primary, secondary}{An expression that is evaluated in the context of 20 | the \code{data} argument. These can be symbols for column names or plain 21 | expressions.} 22 | 23 | \item{method}{One of the following: \describe{ 24 | \item{\code{"range"}}{Causes the ranges of \code{primary} and \code{secondary} data to 25 | overlap completely.} 26 | \item{\code{"max"}}{Causes the maxima of \code{primary} and \code{secondary} data to 27 | coincide.} 28 | \item{\code{"fit"}}{Uses the coefficients of \code{lm(primary ~ secondary)} to make 29 | the axes fit.} 30 | \item{\code{"ccf"}}{Uses the lag at which maximum cross-correlation occurs to 31 | then align the data by truncation. The aligned data is then passed to the 32 | \code{"fit"} method.} 33 | \item{\code{"sortfit"}}{Sorts the both \code{primary} and \code{secondary} independently 34 | before passing these on to the \code{"fit"} method.} 35 | }} 36 | 37 | \item{na.rm}{A \code{logical(1)}: whether to remove missing values (\code{TRUE}) or 38 | propagate missing values (\code{FALSE}). Applies to the \code{method = "range"} and 39 | \code{method = "max"} methods.} 40 | 41 | \item{...}{ 42 | Arguments passed on to \code{\link[ggplot2:sec_axis]{ggplot2::sec_axis}} 43 | \describe{ 44 | \item{\code{transform}}{A formula or function of a strictly monotonic transformation} 45 | \item{\code{name}}{The name of the secondary axis} 46 | \item{\code{breaks}}{One of: 47 | \itemize{ 48 | \item \code{NULL} for no breaks 49 | \item \code{waiver()} for the default breaks computed by the transformation object 50 | \item A numeric vector of positions 51 | \item A function that takes the limits as input and returns breaks as output 52 | }} 53 | \item{\code{labels}}{One of: 54 | \itemize{ 55 | \item \code{NULL} for no labels 56 | \item \code{waiver()} for the default labels computed by the transformation object 57 | \item A character vector giving labels (must be same length as \code{breaks}) 58 | \item A function that takes the breaks as input and returns labels as output 59 | }} 60 | \item{\code{guide}}{A position guide that will be used to render 61 | the axis on the plot. Usually this is \code{\link[ggplot2:guide_axis]{guide_axis()}}.} 62 | }} 63 | } 64 | \value{ 65 | An \code{AxisSecondary} ggproto object with a \code{proj} method for projecting 66 | secondary data. 67 | } 68 | \description{ 69 | The purpose of this function is to construct a secondary axis with a 70 | projection function. 71 | } 72 | \details{ 73 | The intent is to run this function before starting a plot. The 74 | output of the function is a secondary axis wherein the \code{trans} argument of 75 | \code{sec_axis()} is populated by an appropriate transformation. In addition, 76 | the output also contains a \code{output$proj()} function that helps transform the 77 | secondary data. 78 | } 79 | \examples{ 80 | # Run the secondary axis helper 81 | sec <- help_secondary(economics, primary = unemploy, secondary = psavert) 82 | 83 | # Making primary plot 84 | p <- ggplot(economics, aes(date)) + 85 | geom_line(aes(y = unemploy), colour = "blue") 86 | 87 | # For the secondary data, later we use the `proj` function from the helper 88 | p <- p + geom_line(aes(y = sec$proj(psavert)), colour = "red") 89 | 90 | # We feed the scale the secondary axis 91 | p + scale_y_continuous(sec.axis = sec) 92 | 93 | # Setup cross-correlated data 94 | set.seed(42) 95 | n <- 100 96 | lag <- 20 97 | dat <- cumsum(rnorm(n + lag)) 98 | df <- data.frame( 99 | x = seq_len(n), 100 | y1 = head(dat, n), 101 | y2 = 10 + tail(dat, n) * 5 # offset and scale y2 102 | ) 103 | # Choosing the cross-correlation function method. 104 | sec <- help_secondary(df, y1, y2, method = "ccf") 105 | 106 | ggplot(df, aes(x)) + 107 | geom_line(aes(y = y1), colour = "blue") + 108 | geom_line(aes(y = sec$proj(y2)), colour = "red") + 109 | scale_y_continuous(sec.axis = sec) 110 | } 111 | -------------------------------------------------------------------------------- /tests/testthat/test-facet_wrap2.R: -------------------------------------------------------------------------------- 1 | 2 | strip_layout <- function(p) { 3 | data <- ggplot_build(p) 4 | plot <- data$plot 5 | layout <- data$layout 6 | data <- data$data 7 | theme <- ggplot2:::plot_theme(plot) 8 | 9 | geom_grobs <- Map(function(l, d) { l$draw_geom(d, layout) }, 10 | plot$layers, data) 11 | 12 | 13 | facet <- layout$render(geom_grobs, data, theme, plot$labels) 14 | layout <- facet$layout 15 | strip_layout <- layout[grepl("^strip", layout$name), 1:4] 16 | as.list(strip_layout) 17 | } 18 | 19 | p <- ggplot(mtcars, aes(disp, drat)) + geom_point() 20 | 21 | test_that("facet_wrap2() builds correct output", { 22 | wrap <- p + facet_wrap2(~cyl, axes = "all", remove_labels = "y") 23 | 24 | wrap_expected <- list( 25 | t = c(3, 3, 3), 26 | l = c(3, 7, 11), 27 | b = c(3, 3, 3), 28 | r = c(3, 7, 11) 29 | ) 30 | 31 | expect_equal(strip_layout(wrap), wrap_expected) 32 | }) 33 | 34 | grab_axis <- function(gt, where = "b") { 35 | gt$grobs[grepl(paste0("^axis-", where), gt$layout$name)] 36 | } 37 | 38 | nchildren <- function(gt, where) { 39 | axis <- grab_axis(gt, where) 40 | vapply(axis, function(x){ 41 | if (!length(x$children)) { 42 | return(0L) 43 | } 44 | x <- x$children 45 | x <- x[names(x) == "axis"][[1]] 46 | length(x$grobs) 47 | }, integer(1)) 48 | } 49 | 50 | test_that("facet_wrap2() can some repeat axes", { 51 | case <- p + facet_wrap2(am ~ cyl, axes = "x", dir = "v", ncol = 2) 52 | ctrl <- p + facet_wrap2(am ~ cyl, axes = "margins", dir = "v", ncol = 2) 53 | 54 | case <- ggplotGrob(case) 55 | ctrl <- ggplotGrob(ctrl) 56 | 57 | case <- grab_axis(case, "b") 58 | ctrl <- grab_axis(ctrl, "b") 59 | 60 | case <- vapply(case, is.zero, logical(1)) 61 | ctrl <- vapply(ctrl, is.zero, logical(1)) 62 | 63 | expect_equal(sum(case), 0L) 64 | expect_equal(sum(ctrl), 4L) 65 | }) 66 | 67 | test_that("facet_wrap2 respects aspect ratio", { 68 | case_null <- p + facet_wrap2(~ vs) 69 | case_asp <- case_null + theme(aspect.ratio = 2) 70 | 71 | case_null <- ggplotGrob(case_null) 72 | case_asp <- ggplotGrob(case_asp) 73 | 74 | panel_col <- panel_cols(case_null)$l 75 | panel_row <- panel_rows(case_null)$t 76 | 77 | expect_equal(as.character(case_null$widths[panel_col]), c("1null", "1null")) 78 | expect_equal(as.character(case_asp$widths[panel_col]), c("1null", "1null")) 79 | 80 | expect_equal(as.character(case_null$heights[panel_row]), "1null") 81 | expect_equal(as.character(case_asp$heights[panel_row]), "2null") 82 | 83 | expect_false(case_null$respect) 84 | expect_true(case_asp$respect) 85 | }) 86 | 87 | test_that("facet_wrap2() can remove some labels", { 88 | case1 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "y") 89 | case2 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "x") 90 | ctrl1 <- p + facet_wrap2(am~cyl, axes = "margins") 91 | ctrl2 <- p + facet_wrap2(am~cyl, axes = "all", remove_labels = "none") 92 | 93 | # Convert to gtables 94 | case1 <- ggplotGrob(case1) 95 | case2 <- ggplotGrob(case2) 96 | ctrl1 <- ggplotGrob(ctrl1) 97 | ctrl2 <- ggplotGrob(ctrl2) 98 | 99 | # Compare x-axis 100 | if (!new_guide_system) { 101 | expect_equal(nchildren(case1, "b"), rep(2L, 6)) 102 | expect_equal(nchildren(case2, "b"), c(2L, 2L, 2L, 1L, 1L, 1L)) 103 | expect_equal(nchildren(ctrl1, "b"), c(2L, 2L, 2L, 0L, 0L, 0L)) 104 | expect_equal(nchildren(ctrl2, "b"), rep(2L, 6)) 105 | } else { 106 | expect_equal(nchildren(case1, "b"), rep(3L, 6)) 107 | expect_equal(nchildren(case2, "b"), c(3L, 3L, 3L, 1L, 1L, 1L)) 108 | expect_equal(nchildren(ctrl1, "b"), c(3L, 3L, 3L, 0L, 0L, 0L)) 109 | expect_equal(nchildren(ctrl2, "b"), rep(3L, 6)) 110 | } 111 | 112 | # Compare y-axis 113 | if (!new_guide_system) { 114 | expect_equal(nchildren(case1, "l"), c(1L, 1L, 1L, 1L, 2L, 2L)) 115 | expect_equal(nchildren(case2, "l"), rep(2L, 6)) 116 | expect_equal(nchildren(ctrl1, "l"), c(0L, 0L, 0L, 0L, 2L, 2L)) 117 | expect_equal(nchildren(ctrl2, "l"), rep(2L, 6)) 118 | } else { 119 | expect_equal(nchildren(case1, "l"), c(1L, 1L, 1L, 1L, 3L, 3L)) 120 | expect_equal(nchildren(case2, "l"), rep(3L, 6)) 121 | expect_equal(nchildren(ctrl1, "l"), c(0L, 0L, 0L, 0L, 3L, 3L)) 122 | expect_equal(nchildren(ctrl2, "l"), rep(3L, 6)) 123 | } 124 | }) 125 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_rectmargin.R: -------------------------------------------------------------------------------- 1 | df <- data.frame( 2 | xmin = c(1, 5), 3 | xmax = c(2, 7), 4 | ymin = c(1, 2), 5 | ymax = c(2, 4), 6 | fill = c("A", "B") 7 | ) 8 | 9 | base <- ggplot(df, aes(xmin = xmin, xmax = xmax, 10 | ymin = ymin, ymax = ymax, 11 | fill = fill)) + 12 | geom_rect() 13 | 14 | test_that("geom_rectmargin can be added to plots", { 15 | g <- base + geom_rectmargin() 16 | expect_s3_class(g$layers[[2]]$geom, "GeomRectMargin") 17 | 18 | gt <- ggplotGrob(g) 19 | gt <- gt$grobs[grepl("panel", gt$layout$name)][[1]] 20 | gt <- gt$children[[4]]$children 21 | 22 | expect_s3_class(gt[[1]], "rect") 23 | expect_s3_class(gt[[2]], "rect") 24 | }) 25 | 26 | test_that("geom_rectmargin recognises sides argument", { 27 | t <- base + geom_rectmargin(sides = "t") 28 | b <- base + geom_rectmargin(sides = "b") 29 | l <- base + geom_rectmargin(sides = "l") 30 | r <- base + geom_rectmargin(sides = "r") 31 | 32 | t <- layer_grob(t, 2)[[1]]$children[[1]] 33 | b <- layer_grob(b, 2)[[1]]$children[[1]] 34 | l <- layer_grob(l, 2)[[1]]$children[[1]] 35 | r <- layer_grob(r, 2)[[1]]$children[[1]] 36 | 37 | expect_equal(as.numeric(t$y), 1) 38 | expect_equal(as.numeric(b$y), 0) 39 | expect_equal(as.numeric(l$x), 0) 40 | expect_equal(as.numeric(r$x), 1) 41 | 42 | sizes <- c(t$height, b$height, 43 | r$width, l$width) 44 | expect_equal(sizes, c(0.03, 0.03, 0.03, 0.03)) 45 | }) 46 | 47 | test_that("geom_rectmargin size can be set", { 48 | a <- base + geom_rectmargin(length = unit(1, "inch")) 49 | b <- base + geom_rectmargin(length = unit(5, "mm")) 50 | a <- layer_grob(a, 2)[[1]]$children[[1]]$height 51 | b <- layer_grob(b, 2)[[1]]$children[[1]]$height 52 | expect_identical(a, unit(1, "inch")) 53 | expect_identical(b, unit(5, "mm")) 54 | }) 55 | 56 | test_that("coord flip flips rectmargins", { 57 | a <- base + geom_rectmargin(sides = "b") 58 | b <- a + coord_flip() 59 | a <- layer_grob(a, 2)[[1]]$children[[1]] 60 | b <- layer_grob(b, 2)[[1]]$children[[1]] 61 | 62 | expect_equal(as.numeric(a$width), as.numeric(b$height)) 63 | }) 64 | 65 | 66 | # geom_tilemargin ------------------------------------------------------------ 67 | 68 | df <- data.frame( 69 | x = c(1, 4), 70 | y = c(1, 2), 71 | width = c(2, 1), 72 | height = c(1, 2), 73 | fill = c("A", "B") 74 | ) 75 | 76 | base <- ggplot(df, aes(x, y, 77 | width = width, height = height, 78 | fill = fill)) + 79 | geom_tile() 80 | 81 | test_that("geom_rectmargin can be added to plots", { 82 | g <- base + geom_tilemargin() 83 | expect_s3_class(g$layers[[2]]$geom, "GeomTileMargin") 84 | expect_s3_class(g$layers[[2]]$geom, "GeomRectMargin") 85 | 86 | gt <- ggplotGrob(g) 87 | gt <- gt$grobs[grepl("panel", gt$layout$name)][[1]] 88 | gt <- gt$children[[4]]$children 89 | 90 | expect_s3_class(gt[[1]], "rect") 91 | expect_s3_class(gt[[2]], "rect") 92 | }) 93 | 94 | test_that("geom_tilemargin recognises sides argument", { 95 | t <- base + geom_tilemargin(sides = "t") 96 | b <- base + geom_tilemargin(sides = "b") 97 | l <- base + geom_tilemargin(sides = "l") 98 | r <- base + geom_tilemargin(sides = "r") 99 | 100 | t <- layer_grob(t, 2)[[1]]$children[[1]] 101 | b <- layer_grob(b, 2)[[1]]$children[[1]] 102 | l <- layer_grob(l, 2)[[1]]$children[[1]] 103 | r <- layer_grob(r, 2)[[1]]$children[[1]] 104 | 105 | expect_equal(as.numeric(t$y), 1) 106 | expect_equal(as.numeric(b$y), 0) 107 | expect_equal(as.numeric(l$x), 0) 108 | expect_equal(as.numeric(r$x), 1) 109 | 110 | sizes <- c(t$height, b$height, 111 | r$width, l$width) 112 | expect_equal(sizes, c(0.03, 0.03, 0.03, 0.03)) 113 | }) 114 | 115 | test_that("geom_tilemargin size can be set", { 116 | a <- base + geom_tilemargin(length = unit(1, "inch")) 117 | b <- base + geom_tilemargin(length = unit(5, "mm")) 118 | a <- layer_grob(a, 2)[[1]]$children[[1]]$height 119 | b <- layer_grob(b, 2)[[1]]$children[[1]]$height 120 | expect_identical(a, unit(1, "inch")) 121 | expect_identical(b, unit(5, "mm")) 122 | }) 123 | 124 | test_that("coord flip flips tilemargins", { 125 | a <- base + geom_tilemargin(sides = "b") 126 | b <- a + coord_flip() 127 | a <- layer_grob(a, 2)[[1]]$children[[1]] 128 | b <- layer_grob(b, 2)[[1]]$children[[1]] 129 | 130 | expect_equal(as.numeric(a$width), as.numeric(b$height)) 131 | }) 132 | -------------------------------------------------------------------------------- /R/utils_gtable.R: -------------------------------------------------------------------------------- 1 | # Weaving ----------------------------------------------------------------- 2 | 3 | #' Weave rows and columns in panel tables 4 | #' 5 | #' When drawing a plot with `ggplot2`, the canvas is laid out in a `gtable` 6 | #' object containing panels and additional plot components. This is called the 7 | #' "panel table". This function is to insert new rows and columns into the table 8 | #' relative to some position of the panels. 9 | #' 10 | #' @param table A `gtable` object containing objects in the layout that are 11 | #' called `"panel"-*`. 12 | #' @param table2 A `data.frame` with columns named `"t"`, `"b"`, `"l"` and `"r"` 13 | #' containing indices to the panels of the `table` argument, *and* a column 14 | #' with the name specified in `grob_var` that contains a list of `grob`s. 15 | #' @param row_shift,col_shift An `integer(1)` determining where relative to the 16 | #' panel a new row or column needs to be inserted. 17 | #' @param row_height,col_width A `unit` object specifying the size of the row 18 | #' or column to be inserted. 19 | #' @param name A `character(1)` 20 | #' @param z,clip See `[gtable_add_grob()][gtable::gtable_add_grob()]`. 21 | #' @param pos A `character(1)` or `NULL` specifying what position takes 22 | #' precedence. 23 | #' @param grob_var A `character(1)` with the name of the `grob`-list column. 24 | #' 25 | #' @return This returns the `table` input with additional rows or columns 26 | #' containing the grobs from the `grob_var`-column in `table2`. 27 | #' @md 28 | #' @noRd 29 | #' @seealso `ggplot2:::weave_tables_col()` and `ggplot2:::weave_tables_row()`. 30 | #' 31 | #' @examples 32 | #' NULL 33 | weave_panel_rows <- function(table, table2, row_shift, row_height, 34 | name, z = 1, clip = "off", pos = NULL, 35 | grob_var = "grobs") { 36 | if (is.null(pos)) { 37 | # As no position is specified, interpret verbatim 38 | pos <- "t" 39 | alt <- "b" 40 | } else { 41 | # Otherwise, interpret opposite as position too 42 | alt <- pos 43 | } 44 | 45 | # Ensure top-to-bottom order of unique panels 46 | rows <- panel_rows(table) 47 | rows <- sort(unique(rows[[pos]])) 48 | 49 | # Keep adding heights bottom-to-top 50 | for (i in rev(seq_along(rows))) { 51 | table <- gtable_add_rows(table, row_height[i], pos = rows[i] + row_shift) 52 | } 53 | 54 | if (!missing(table2)) { 55 | # Offset shift because we already added the rows 56 | row_shift <- ifelse(row_shift > -1, 1 + row_shift, row_shift) 57 | panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] 58 | panels[, c("t", "b")] <- panels[, c("t", "b")] + row_shift 59 | 60 | table <- gtable_add_grob( 61 | table, table2[[grob_var]], 62 | t = panels[[pos]][table2$t], 63 | b = panels[[alt]][table2$b], 64 | l = panels$l[table2$l], 65 | r = panels$r[table2$r], 66 | clip = clip, z = z, 67 | name = paste0(name, "-", seq_along(table2$l), "-", seq_along(table2$t)) 68 | ) 69 | } 70 | table 71 | } 72 | 73 | # See documentation for weave_panel_rows above 74 | weave_panel_cols <- function(table, table2, col_shift, col_width, 75 | name, z = 1, clip = "off", pos = NULL, 76 | grob_var = "grobs") { 77 | if (is.null(pos)) { 78 | # As no position is specified, interpret verbatim 79 | pos <- "l" 80 | alt <- "r" 81 | } else { 82 | # Otherwise, interpret opposite as position too 83 | alt <- pos 84 | } 85 | 86 | # Ensure left-to-right ordering of unique panels 87 | cols <- panel_cols(table) 88 | cols <- sort(unique(cols[[pos]])) 89 | 90 | # Keep adding widths right-to-left 91 | for (i in rev(seq_along(cols))) { 92 | table <- gtable_add_cols(table, col_width[i], pos = cols[i] + col_shift) 93 | } 94 | 95 | if (!missing(table2)) { 96 | # Offset shift because we already added the columns 97 | col_shift <- ifelse(col_shift > -1, 1 + col_shift, col_shift) 98 | panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] 99 | panels[, c("l", "r")] <- panels[, c("l", "r")] + col_shift 100 | 101 | table <- gtable_add_grob( 102 | table, table2[[grob_var]], 103 | t = panels$t[table2$t], 104 | b = panels$b[table2$b], 105 | l = panels[[pos]][table2$l], 106 | r = panels[[alt]][table2$r], 107 | clip = clip, z= z, 108 | name = paste0(name, "-", seq_along(table2$t), "-", seq_along(table2$l)) 109 | ) 110 | } 111 | table 112 | } 113 | -------------------------------------------------------------------------------- /tests/testthat/test-position_lineartrans.R: -------------------------------------------------------------------------------- 1 | df <- data.frame(x = c(1, 0, 0, 1), 2 | y = c(1, 1, 0, 0)) 3 | 4 | base <- ggplot(df, aes(x, y)) 5 | 6 | test_that("position_lineartrans can perform identity transformations", { 7 | M <- matrix(c(1, 0, 0, 1), 2) 8 | ctrl <- base + geom_polygon(position = position_identity()) 9 | test1 <- base + geom_polygon(position = position_lineartrans()) 10 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 11 | 12 | ctrl <- layer_data(ctrl) 13 | test1 <- layer_data(test1) 14 | test2 <- layer_data(test2) 15 | 16 | expect_identical(test1, test2) 17 | expect_identical(test1, ctrl) 18 | }) 19 | 20 | test_that("position_lineartrans can scale data", { 21 | M <- matrix(c(2,0,0,2), 2) 22 | ctrl <- base + geom_polygon(position = position_identity()) 23 | test1 <- base + geom_polygon(position = position_lineartrans(scale = c(2, 2))) 24 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 25 | 26 | ctrl <- layer_data(ctrl) 27 | test1 <- layer_data(test1) 28 | test2 <- layer_data(test2) 29 | 30 | expect_identical(test1, test2) 31 | expect_identical(test1$x, ctrl$x * 2) 32 | expect_identical(test1$y, ctrl$y * 2) 33 | }) 34 | 35 | test_that("position_lineartrans can squeeze data", { 36 | M <- matrix(c(2, 0, 0, 0.5), 2) 37 | ctrl <- base + geom_polygon(position = position_identity()) 38 | test1 <- base + geom_polygon(position = position_lineartrans(scale = c(2, 0.5))) 39 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 40 | 41 | ctrl <- layer_data(ctrl) 42 | test1 <- layer_data(test1) 43 | test2 <- layer_data(test2) 44 | 45 | expect_identical(test1, test2) 46 | expect_identical(test1$x, ctrl$x * 2) 47 | expect_identical(test1$y, ctrl$y * 0.5) 48 | }) 49 | 50 | test_that("position_lineartrans can reflect data", { 51 | M <- matrix(c(1, 0, 0, -1), 2) 52 | ctrl <- base + geom_polygon(position = position_identity()) 53 | test1 <- base + geom_polygon(position = position_lineartrans(scale = c(1, -1))) 54 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 55 | 56 | ctrl <- layer_data(ctrl) 57 | test1 <- layer_data(test1) 58 | test2 <- layer_data(test2) 59 | 60 | expect_identical(test1, test2) 61 | expect_identical(test1$x, ctrl$x) 62 | expect_identical(test1$y, ctrl$y * -1) 63 | }) 64 | 65 | test_that("position_lineartrans can project data", { 66 | M <- matrix(c(0, 0, 0, 1), 2) 67 | ctrl <- base + geom_polygon(position = position_identity()) 68 | test1 <- base + geom_polygon(position = position_lineartrans(scale = c(0, 1))) 69 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 70 | 71 | ctrl <- layer_data(ctrl) 72 | test1 <- layer_data(test1) 73 | test2 <- layer_data(test2) 74 | 75 | expect_identical(test1, test2) 76 | expect_identical(test1$x, ctrl$x * 0) 77 | expect_identical(test1$y, ctrl$y) 78 | }) 79 | 80 | test_that("position_lineartrans can shear data vertically", { 81 | M <- matrix(c(1, 0.1, 0, 1), 2) 82 | ctrl <- base + geom_polygon(position = position_identity()) 83 | test1 <- base + geom_polygon(position = position_lineartrans(shear = c(0.1, 0))) 84 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 85 | 86 | ctrl <- layer_data(ctrl) 87 | test1 <- layer_data(test1) 88 | test2 <- layer_data(test2) 89 | 90 | expect_identical(test1, test2) 91 | expect_identical(test1$x, ctrl$x) 92 | expect_identical(test1$y, ctrl$y + c(0.1, 0, 0, 0.1)) 93 | }) 94 | 95 | test_that("position_lineartrans can shear data horizontally", { 96 | M <- matrix(c(1, 0, 0.5, 1), 2) 97 | ctrl <- base + geom_polygon(position = position_identity()) 98 | test1 <- base + geom_polygon(position = position_lineartrans(shear = c(0, 0.5))) 99 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 100 | 101 | ctrl <- layer_data(ctrl) 102 | test1 <- layer_data(test1) 103 | test2 <- layer_data(test2) 104 | 105 | expect_identical(test1, test2) 106 | expect_identical(test1$x, ctrl$x + c(0.5, 0.5, 0, 0)) 107 | expect_identical(test1$y, ctrl$y) 108 | }) 109 | 110 | test_that("position_lineartrans can rotate data", { 111 | M <- matrix(c(0, 1, -1, 0), 2) 112 | ctrl <- base + geom_polygon(position = position_identity()) 113 | test1 <- base + geom_polygon(position = position_lineartrans(angle = -90)) 114 | test2 <- base + geom_polygon(position = position_lineartrans(M = M)) 115 | 116 | ctrl <- layer_data(ctrl) 117 | test1 <- layer_data(test1) 118 | test2 <- layer_data(test2) 119 | 120 | expect_equal(test1, test2) 121 | expect_identical(test2$x, ctrl$x[c(4, 1:3)] * -1) 122 | expect_identical(test2$y, ctrl$y[c(2:4, 1)]) 123 | }) -------------------------------------------------------------------------------- /R/geom_outline_point.R: -------------------------------------------------------------------------------- 1 | # Main function ----------------------------------------------------------- 2 | 3 | #' Points with outline 4 | #' 5 | #' This is a variant of the point geom, wherein overlapping points are given 6 | #' a shared outline. It works by drawing an additional layer of points below a 7 | #' regular layer of points with a thicker stroke. 8 | #' 9 | #' @inheritParams ggplot2::geom_point 10 | #' 11 | #' @return A ggplot `Layer` 12 | #' @export 13 | #' @eval fixup_docs(ggplot2:::rd_aesthetics("geom", "outline_point")) 14 | #' 15 | #' @details Due to the way this geom is implemented, it handles the `alpha` 16 | #' aesthetic pretty ungracefully. 17 | #' 18 | #' @examples 19 | #' # A standard plot 20 | #' p <- ggplot(mpg, aes(displ, cty, colour = factor(cyl))) + 21 | #' geom_outline_point(size = 10, stroke = 3) 22 | #' p 23 | #' 24 | #' # The colour of the stroke can be mapped to a scale by setting the 25 | #' # aesthetics to `"stroke_colour"`. 26 | #' p + 27 | #' aes(stroke_colour = factor(cyl)) + 28 | #' scale_colour_hue( 29 | #' aesthetics = "stroke_colour", 30 | #' l = 50 31 | #' ) 32 | geom_outline_point <- function( 33 | mapping = NULL, 34 | data = NULL, 35 | stat = "identity", 36 | position = "identity", 37 | ..., 38 | na.rm = FALSE, 39 | show.legend = NA, 40 | inherit.aes = TRUE 41 | ) { 42 | layer( 43 | data = data, 44 | mapping = mapping, 45 | stat = stat, 46 | geom = GeomOutlinePoint, 47 | position = position, 48 | show.legend = show.legend, 49 | inherit.aes = inherit.aes, 50 | params = list2( 51 | na.rm = na.rm, 52 | ... 53 | ) 54 | ) 55 | } 56 | 57 | # Key drawing ------------------------------------------------------------- 58 | 59 | draw_key_outline_point <- function(data, params, size) { 60 | 61 | is_solid <- data$shape > 14 62 | has_fill <- data$shape > 20 63 | 64 | stroke_size <- data$stroke 65 | stroke_size[is.na(stroke_size)] <- 0 66 | lwd <- ifelse(is_solid & !has_fill, 0, stroke_size * .stroke / 2) 67 | 68 | foreground <- pointsGrob( 69 | x = 0.5, y = 0.5, 70 | pch = data$shape, 71 | gp = gpar( 72 | col = alpha(data$colour, data$alpha), 73 | fill = alpha(data$fill, data$alpha), 74 | fontsize = data$size * .pt, 75 | lwd = lwd 76 | ) 77 | ) 78 | 79 | size <- data$size * .pt + ifelse(is_solid, stroke_size * .stroke, 0) 80 | lwd <- lwd + ifelse(is_solid, 0, stroke_size * .stroke) 81 | 82 | background <- pointsGrob( 83 | x = 0.5, y = 0.5, 84 | pch = data$shape, 85 | gp = gpar( 86 | col = alpha(data$stroke_colour, data$alpha), 87 | fill = alpha(data$stroke_colour, data$alpha), 88 | lwd = lwd, 89 | fontsize = size 90 | ) 91 | ) 92 | 93 | grobTree(background, foreground) 94 | } 95 | 96 | # ggproto class ----------------------------------------------------------- 97 | 98 | GeomOutlinePoint <- ggproto( 99 | "GeomOutlinePoint", GeomPoint, 100 | 101 | default_aes = aes( 102 | shape = from_theme(pointshape), 103 | colour = from_theme(colour %||% col_mix(ink, paper)), 104 | size = from_theme(pointsize), 105 | fill = from_theme(fill %||% NA), 106 | alpha = NA, 107 | stroke = from_theme(borderwidth), 108 | stroke_colour = from_theme(ink) 109 | ), 110 | 111 | draw_key = draw_key_outline_point, 112 | 113 | draw_panel = function(data, panel_params, coord, na.rm = TRUE) { 114 | 115 | coords <- coord$transform(data, panel_params) 116 | 117 | is_solid <- coords$shape > 14 118 | has_fill <- coords$shape > 20 119 | 120 | stroke_size <- coords$stroke 121 | stroke_size[is.na(stroke_size)] <- 0 122 | 123 | lwd <- ifelse(is_solid & !has_fill, 0, stroke_size * .stroke / 2) 124 | 125 | foreground <- pointsGrob( 126 | x = coords$x, y = coords$y, 127 | pch = coords$shape, 128 | gp = gpar( 129 | col = alpha(coords$colour, coords$alpha), 130 | fill = alpha(coords$fill, coords$alpha), 131 | fontsize = coords$size * .pt, 132 | lwd = lwd 133 | ) 134 | ) 135 | 136 | size <- coords$size * .pt + ifelse(is_solid, stroke_size * .stroke, 0) 137 | lwd <- lwd + ifelse(is_solid, 0, stroke_size * .stroke) 138 | 139 | background <- pointsGrob( 140 | x = coords$x, y = coords$y, 141 | pch = coords$shape, 142 | gp = gpar( 143 | col = alpha(coords$stroke_colour, coords$alpha), 144 | fill = alpha(coords$stroke_colour, coords$alpha), 145 | lwd = lwd, 146 | fontsize = size 147 | ) 148 | ) 149 | 150 | grob <- grobTree( 151 | background, foreground 152 | ) 153 | grob$name <- grobName(grob, "outline_points") 154 | grob 155 | } 156 | ) 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /tests/testthat/test-position_disjoint_ranges.R: -------------------------------------------------------------------------------- 1 | # Setup data -------------------------------------------------------------- 2 | 3 | df <- data.frame(xmin = c(1, 4, 7, 13, 19), 4 | xmax = c(5, 8, 11, 17, 23), 5 | ymin = 1, 6 | ymax = 2, 7 | group = c(1,2,3,4,3)) 8 | base <- ggplot(df, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax)) 9 | 10 | 11 | # Basic tests ------------------------------------------------------------- 12 | 13 | test_that("position_disjoint_ranges repositions disjoint ranges", { 14 | 15 | ctrl <- base + geom_rect() 16 | test <- base + geom_rect(position = position_disjoint_ranges()) 17 | 18 | ctrl <- layer_data(ctrl) 19 | test <- layer_data(test) 20 | 21 | expect_equal(ctrl[, c("xmin", "xmax")], test[, c("xmin", "xmax")]) 22 | expect_false(identical(ctrl[, c("ymin", "ymax")], test[, c("ymin", "ymax")])) 23 | expect_equal(test$ymin, c(1,2,1,1,1)) 24 | expect_equal(test$ymax, c(2,3,2,2,2)) 25 | }) 26 | 27 | test_that("position_disjoint_ranges can be used with geom_tile", { 28 | df2 <- data.frame(x = (df$xmin + df$xmax)/2, 29 | y = (df$ymin + df$ymax)/2, 30 | width = df$xmax - df$xmin, 31 | height = df$ymax - df$ymin) 32 | base2 <- ggplot(df2, aes(x, y, width = width, height = height)) 33 | 34 | ctrl <- base + geom_rect(position = position_disjoint_ranges()) 35 | test <- base2 + geom_tile(position = position_disjoint_ranges()) 36 | 37 | ctrl <- layer_data(ctrl) 38 | test <- layer_data(test) 39 | 40 | isect <- intersect(names(ctrl), names(test)) 41 | # default fills and sizes differ between geom_rect and geom_tile 42 | isect <- isect[!(isect %in% c("fill", "size", "linewidth"))] 43 | 44 | expect_equal(ctrl[,isect], test[,isect]) 45 | expect_equal(test$ymin, c(1,2,1,1,1)) 46 | expect_equal(test$ymax, c(2,3,2,2,2)) 47 | }) 48 | 49 | # Group tests ------------------------------------------------------------- 50 | 51 | test_that("position_disjoint_ranges respects groups", { 52 | 53 | ctrl <- base + geom_rect(aes(group = NULL), position = position_disjoint_ranges()) 54 | test <- base + geom_rect(aes(group = group), position = position_disjoint_ranges()) 55 | 56 | ctrl <- layer_data(ctrl) 57 | test <- layer_data(test) 58 | 59 | expect_equal(ctrl[, c("xmin", "xmax")], test[, c("xmin", "xmax")]) 60 | expect_false(identical(ctrl[, c("ymin", "ymax")], test[, c("ymin", "ymax")])) 61 | expect_equal(ctrl$ymin, c(1,2,1,1,1)) 62 | expect_equal(ctrl$ymax, c(2,3,2,2,2)) 63 | expect_equal(test$ymin, c(1,2,1,2,1)) 64 | expect_equal(test$ymax, c(2,3,2,3,2)) 65 | }) 66 | 67 | test_that("position_disjoint_ranges distinguishes proper groups from improper groups", { 68 | ctrl <- base + geom_rect(aes(group = NULL), position = position_disjoint_ranges()) 69 | test <- base + geom_rect(aes(group = 1), position = position_disjoint_ranges()) 70 | 71 | ctrl <- layer_data(ctrl) 72 | test <- layer_data(test) 73 | 74 | expect_equal(ctrl[, c("xmin", "xmax")], test[, c("xmin", "xmax")]) 75 | expect_false(identical(ctrl[, c("ymin", "ymax")], test[, c("ymin", "ymax")])) 76 | expect_equal(ctrl$ymin, c(1,2,1,1,1)) 77 | expect_equal(ctrl$ymax, c(2,3,2,2,2)) 78 | expect_equal(test$ymin, c(1,1,1,1,1)) 79 | expect_equal(test$ymax, c(2,2,2,2,2)) 80 | }) 81 | 82 | # Arguments Tests --------------------------------------------------------- 83 | 84 | test_that("position_disjoint_ranges extends ranges", { 85 | ctrl <- base + geom_rect(position = position_disjoint_ranges(extend = 0)) 86 | test <- base + geom_rect(position = position_disjoint_ranges(extend = 100)) 87 | 88 | ctrl <- layer_data(ctrl) 89 | test <- layer_data(test) 90 | 91 | expect_equal(ctrl[, c("xmin", "xmax")], test[, c("xmin", "xmax")]) 92 | expect_false(identical(ctrl[, c("ymin", "ymax")], test[, c("ymin", "ymax")])) 93 | expect_equal(ctrl$ymin, c(1,2,1,1,1)) 94 | expect_equal(ctrl$ymax, c(2,3,2,2,2)) 95 | expect_equal(test$ymin, 1:5) 96 | expect_equal(test$ymax, 2:6) 97 | }) 98 | 99 | test_that("position_disjoint_ranges stepsize works", { 100 | ctrol <- base + geom_rect(position = position_disjoint_ranges(stepsize = 1)) 101 | small <- base + geom_rect(position = position_disjoint_ranges(stepsize = 0.5)) 102 | large <- base + geom_rect(position = position_disjoint_ranges(stepsize = 10)) 103 | 104 | exp <- c(1,2,1,1,1) 105 | 106 | ctrol <- layer_data(ctrol) 107 | small <- layer_data(small) 108 | large <- layer_data(large) 109 | 110 | expect_equal(ctrol$ymin, exp) 111 | expect_equal(ctrol$ymin, ctrol$ymax - 1) 112 | expect_equal(small$ymin, 0.5 * (exp - 1) + 1) 113 | expect_equal(small$ymin, small$ymax - 1) 114 | expect_equal(large$ymin, 10 * (exp - 1) + 1) 115 | expect_equal(large$ymin, large$ymax - 1) 116 | }) 117 | -------------------------------------------------------------------------------- /R/stat_difference.R: -------------------------------------------------------------------------------- 1 | # Constructor ------------------------------------------------------------- 2 | 3 | #' Difference ribbon 4 | #' 5 | #' This makes a ribbon that is filled depending on whether the `max` is 6 | #' higher than `min`. This can be useful for displaying differences 7 | #' between two series. 8 | #' 9 | #' @inheritParams ggplot2::stat_density 10 | #' @param geom Use to override the default connection between 11 | #' `geom_ribbon()` and `stat_difference()`. 12 | #' @param levels A `character(2)` indicating factor levels for the `fill` 13 | #' aesthetic for the cases where (1) `max > min` and where (2) `max < min`. 14 | #' 15 | #' @return A `Layer` object that can be added to a plot. 16 | #' @export 17 | #' 18 | #' @details The stat may reorder the `group` aesthetic to accommodate two 19 | #' different fills for the signs of differences. The stat takes care to 20 | #' interpolate a series whenever a crossover between `max` and `min` series 21 | #' happens. This makes the ribbon not look stumpy at these crossovers. 22 | #' 23 | #' @note 24 | #' When there is a run of more than two 0-difference values, the inner values 25 | #' will be ignored. 26 | #' 27 | #' @eval fixup_docs(ggplot2:::rd_aesthetics("geom", "ribbon")) 28 | #' @section Computed variables: \describe{ 29 | #' \item{`sign`}{A `factor` with the `levels` attribute set to the `levels` 30 | #' argument.} 31 | #' } 32 | #' 33 | #' @md 34 | #' @examples 35 | #' set.seed(2021) 36 | #' df <- data.frame( 37 | #' x = 1:100, 38 | #' y = cumsum(rnorm(100)), 39 | #' z = cumsum(rnorm(100)) 40 | #' ) 41 | #' 42 | #' ggplot(df, aes(x = x)) + 43 | #' stat_difference(aes(ymin = y, ymax = z), alpha = 0.3) + 44 | #' geom_line(aes(y = y, colour = "min")) + 45 | #' geom_line(aes(y = z, colour = "max")) 46 | stat_difference <- function( 47 | mapping = NULL, 48 | data = NULL, 49 | geom = "ribbon", 50 | position = "identity", 51 | ..., 52 | levels = c("+", "-"), 53 | na.rm = FALSE, 54 | orientation = NA, 55 | show.legend = NA, 56 | inherit.aes = TRUE 57 | ) { 58 | layer( 59 | data = data, 60 | mapping = mapping, 61 | stat = StatDifference, 62 | geom = geom, 63 | position = position, 64 | show.legend = show.legend, 65 | inherit.aes = inherit.aes, 66 | params = list2( 67 | na.rm = na.rm, 68 | orientation = orientation, 69 | levels = levels, 70 | ... 71 | ) 72 | ) 73 | } 74 | 75 | # ggproto ----------------------------------------------------------------- 76 | 77 | #' @usage NULL 78 | #' @format NULL 79 | #' @export 80 | #' @rdname ggh4x_extensions 81 | StatDifference <- ggproto( 82 | "StatDifference", Stat, 83 | required_aes = c("x|y", "ymin|xmin", "ymax|xmax"), 84 | default_aes = aes(fill = after_stat(sign)), 85 | setup_params = function(data, params) { 86 | params$flipped_aes <- has_flipped_aes( 87 | data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE 88 | ) 89 | params 90 | }, 91 | extra_params = c("na.rm", "orientation", "levels"), 92 | compute_panel = function(self, data, scales, flipped_aes = FALSE, ...) { 93 | data <- flip_data(data, flipped_aes) 94 | data <- ggproto_parent(Stat, self)$compute_panel( 95 | data, scales, ... 96 | ) 97 | data$group <- cumsum(data$id) 98 | data$id <- NULL 99 | data$flipped_aes <- flipped_aes 100 | flip_data(data, flipped_aes) 101 | }, 102 | compute_group = function(data, scales, levels = c("+", "-"), 103 | na.rm = FALSE, flipped_aes = FALSE) { 104 | data <- data[order(data$x),] 105 | y <- data$ymax - data$ymin 106 | data$sign <- sign(y) 107 | sign_rle <- vec_unrep(data$sign) 108 | 109 | # Find crossing points 110 | ends <- cumsum(sign_rle$times) 111 | dups <- ends[-length(ends)] 112 | cross <- -y[dups] * (data$x[dups + 1] - data$x[dups]) / 113 | (y[dups + 1] - y[dups]) + data$x[dups] 114 | 115 | # Interpolate at cross points 116 | x <- vec_rep_each(cross, 2) 117 | ymin <- approx(data$x, data$ymin, x)$y 118 | ymax <- approx(data$x, data$ymax, x)$y 119 | 120 | # Match metadata 121 | sign <- vec_rep_each(sign_rle$key, 2) 122 | sign <- sign[-c(1, length(sign))] 123 | id <- rep(c(0, 1), length(cross)) 124 | ord <- cumsum(id) + 1 125 | data_ord <- vec_rep_each(seq_along(sign_rle$times), sign_rle$times) 126 | 127 | new <- data_frame0( 128 | x = c(data$x, x), 129 | ymin = c(data$ymin, ymin), 130 | ymax = c(data$ymax, ymax), 131 | ord = c(data_ord, ord), 132 | id = c(1, rep(0, nrow(data) - 1), id), # Will become group later 133 | sign = c(data$sign, sign) 134 | ) 135 | new <- vec_slice(new, order(new$ord, new$x)) 136 | new <- vec_slice(new, new$sign != 0) 137 | new$sign <- factor(new$sign, levels = c("1", "-1"), labels = levels[1:2]) 138 | new$ord <- NULL 139 | new 140 | } 141 | ) 142 | -------------------------------------------------------------------------------- /tests/testthat/test-strips.R: -------------------------------------------------------------------------------- 1 | # Construction ------------------------------------------------------------ 2 | 3 | test_that("strip_vanilla can instantiate Strips", { 4 | test <- strip_vanilla() 5 | expect_s3_class(test, c("Strip", "ggproto")) 6 | }) 7 | 8 | test_that("strip_themed can instantiate Strips", { 9 | test <- strip_themed() 10 | expect_s3_class(test, c("StripThemed", "Strip", "ggproto")) 11 | }) 12 | 13 | test_that("strip_nested can instantiate Strips", { 14 | test <- strip_nested() 15 | expect_s3_class(test, c("StripNested", "StripThemed", "Strip", "ggproto")) 16 | }) 17 | 18 | # Correctness ------------------------------------------------------------- 19 | 20 | # `strip_vanilla()` and `strip_nested()` are assumed to be tested sufficiently 21 | # in `facet_wrap2()`/`facet_grid2()` and `facet_nested_wrap()`/`facet_nested()` 22 | # respectively. 23 | # Therefore, we just need to test `strip_themed` for correctness. 24 | 25 | test_that("strip_themed inherits from theme", { 26 | my_theme <- theme_get() + theme( 27 | strip.background.x = element_rect(colour = "green", fill = "blue"), 28 | strip.text.y = element_text(family = "mono", colour = "red") 29 | ) 30 | 31 | strip <- strip_themed( 32 | background_x = list(NULL, element_rect(colour = "blue"), 33 | element_rect(fill = "green")) 34 | ) 35 | elem <- strip$setup_elements(my_theme, "wrap") 36 | bg <- lapply(elem$background$x, `[[`, "gp") 37 | bg <- lapply(bg, unclass) 38 | 39 | # Backgrounds should already have been rendered as grobs 40 | # First element was NULL, so should be directly from theme 41 | expect_equal(bg[[1]][c("col", "fill")], list(col = "green", fill = "blue")) 42 | # Only fill comes from theme, col was specified 43 | expect_equal(bg[[2]][c("col", "fill")], list(col = "blue", fill = "blue")) 44 | # Only colour comes from theme, fill was specified 45 | expect_equal(bg[[3]][c("col", "fill")], list(col = "green", fill = "green")) 46 | 47 | strip <- strip_themed( 48 | text_y = list(element_blank(), element_text(family = "serif")) 49 | ) 50 | elem <- strip$setup_elements(my_theme, "wrap") 51 | txt <- elem$text$y$left 52 | # Text should still be elements 53 | # First one was blank 54 | expect_equal(txt[[1]], element_blank()) 55 | # Second one should have overwritten family but inherited colour 56 | expect_equal(txt[[2]][c("colour", "family")], 57 | list(colour = "red", family = "serif")) 58 | # Third one should not be evaluated until strip is placed 59 | expect_length(txt, 2) 60 | }) 61 | 62 | test_that("strip_themed uses by_layer arguments correctly", { 63 | individ <- strip_themed( 64 | background_y = elem_list_rect(fill = c("green", "blue")), 65 | by_layer_y = FALSE 66 | ) 67 | extra <- if (new_guide_system) 2L else 0L 68 | 69 | layered <- strip_themed( 70 | background_y = elem_list_rect(fill = c("green", "blue")), 71 | by_layer_y = TRUE 72 | ) 73 | 74 | p <- ggplot(mpg, aes(displ, hwy)) + 75 | geom_point() 76 | 77 | individ <- p + 78 | facet_wrap2( 79 | vars("Top layer", drv), strip.position = "right", strip = individ 80 | ) 81 | layered <- p + 82 | facet_wrap2( 83 | vars("Top layer", drv), strip.position = "right", strip = layered 84 | ) 85 | individ <- ggplotGrob(individ) 86 | layered <- ggplotGrob(layered) 87 | 88 | # Test individual 89 | is_strip <- grepl("^strip-r-", individ$layout$name) 90 | lay <- individ$layout[is_strip,] 91 | expect_equal(lay[c("t", "l")], 92 | list(t = c(7, 7, 7) + extra, l = c(6, 11, 16) + extra), 93 | ignore_attr = TRUE) 94 | individ <- individ$grobs[is_strip] 95 | individ <- vapply(individ, function(x) { 96 | fills <- vapply(x$grobs, function(y) { 97 | y$children[[grep("^GRID\\.rect", names(y$children))]]$gp$fill 98 | }, character(1)) 99 | }, character(2)) 100 | expect_equal(as.vector(individ), 101 | c("green", "blue", "blue", "green", "green", "blue")) 102 | 103 | # Test layered 104 | is_strip <- grepl("^strip-r-", layered$layout$name) 105 | lay <- layered$layout[is_strip,] 106 | expect_equal(lay[c("t", "l")], 107 | list(t = c(7, 7, 7) + extra, l = c(6, 11, 16) + extra), 108 | ignore_attr = TRUE) 109 | layered <- layered$grobs[is_strip] 110 | layered <- vapply(layered, function(x) { 111 | fills <- vapply(x$grobs, function(y) { 112 | y$children[[grep("^GRID\\.rect", names(y$children))]]$gp$fill 113 | }, character(1)) 114 | }, character(2)) 115 | expect_equal(as.vector(layered), 116 | rep(c("green", "blue"), 3)) 117 | }) 118 | 119 | # Warnings and errors ----------------------------------------------------- 120 | 121 | test_that("strip_vanilla rejects faulty arguments", { 122 | expect_snapshot_error(strip_vanilla(clip = "nonsense")) 123 | expect_snapshot_error(strip_vanilla(size = "nonsense")) 124 | }) 125 | 126 | test_that("strip_themed rejects faulty theme elements", { 127 | expect_snapshot_error(strip_themed(background_x = "I'm not a theme element")) 128 | expect_snapshot_error(strip_themed(text_y = element_line(colour = "blue"))) 129 | }) 130 | -------------------------------------------------------------------------------- /R/stat_funxy.R: -------------------------------------------------------------------------------- 1 | # Constructor ------------------------------------------------------------- 2 | 3 | #' Apply function to position coordinates 4 | #' 5 | #' The function xy stat applies a function to the x- and y-coordinates of a 6 | #' layers positions by group. The `stat_centroid()` and 7 | #' `stat_midpoint()` functions are convenience wrappers for calculating 8 | #' centroids and midpoints. `stat_funxy()` by default leaves the data 9 | #' as-is, but can be supplied functions and arguments. 10 | #' 11 | #' @inheritParams ggplot2::stat_identity 12 | #' @param funx,funy A `function` to call on the layer's `x` and 13 | #' `y` positions respectively. 14 | #' @param argx,argy A named `list` containing arguments to the `funx`, 15 | #' and `funy` function calls. 16 | #' @param crop_other A `logical` of length one; whether the other data 17 | #' should be fitted to the length of `x` and `y` (default: 18 | #' `TRUE`). Useful to set to `FALSE` when `funx` or `funy` 19 | #' calculate summaries of length one that need to be recycled. 20 | #' 21 | #' @details This statistic only makes a minimal attempt at ensuring that the 22 | #' results from calling both functions are of equal length. Results of length 23 | #' 1 are recycled to match the longest length result. 24 | #' 25 | #' @return A `StatFunxy` ggproto object, that can be added to a plot. 26 | #' @export 27 | #' 28 | #' @examples 29 | #' p <- ggplot(iris, aes(Sepal.Width, Sepal.Length, colour = Species)) 30 | #' 31 | #' # Labelling group midpoints 32 | #' p + geom_point() + 33 | #' stat_midpoint(aes(label = Species, group = Species), 34 | #' geom = "text", colour = "black") 35 | #' 36 | #' # Drawing segments to centroids 37 | #' p + geom_point() + 38 | #' stat_centroid(aes(xend = Sepal.Width, yend = Sepal.Length), 39 | #' geom = "segment", crop_other = FALSE) 40 | #' 41 | #' # Drawing intervals 42 | #' ggplot(iris, aes(Sepal.Width, Sepal.Length, colour = Species)) + 43 | #' geom_point() + 44 | #' stat_funxy(geom = "path", 45 | #' funx = median, funy = quantile, 46 | #' argy = list(probs = c(0.1, 0.9))) 47 | stat_funxy <- 48 | function(mapping = NULL, data = NULL, geom = "point", 49 | position = "identity", ..., funx = force, funy = force, 50 | argx = list(), argy = list(), crop_other = TRUE, 51 | show.legend = NA, inherit.aes = TRUE) { 52 | stopifnot( 53 | "The `funx` argument must be a function." = 54 | is.function(funx), 55 | "The `funy` argument must be a function." = 56 | is.function(funy), 57 | "The `argx` and `argy` arguments must be lists." = 58 | is.list(argx) & is.list(argy), 59 | "The `argx` list must have named elements" = 60 | length(argx) == sum(nzchar(names(argx))), 61 | "The `argy` list must have named elements" = 62 | length(argy) == sum(nzchar(names(argy))) 63 | ) 64 | 65 | layer( 66 | data = data, 67 | mapping = mapping, 68 | stat = StatFunxy, 69 | geom = geom, 70 | position = position, 71 | show.legend = show.legend, 72 | inherit.aes = inherit.aes, 73 | params = list2( 74 | funx = funx, funy = funy, 75 | argx = argx, argy = argy, 76 | crop_other = crop_other, 77 | ... 78 | ) 79 | ) 80 | } 81 | 82 | #' @rdname stat_funxy 83 | #' @export 84 | stat_centroid <- function(..., 85 | funx = mean, funy = mean, 86 | argx = list(na.rm = TRUE), argy = list(na.rm = TRUE)) { 87 | stat_funxy(..., funx = funx, funy = funy, argx = argx, argy = argy) 88 | } 89 | 90 | #' @rdname stat_funxy 91 | #' @export 92 | stat_midpoint <- function(..., 93 | argx = list(na.rm = TRUE), 94 | argy = list(na.rm = TRUE)) { 95 | fun <- function(x, na.rm = TRUE) { 96 | sum(range(x, na.rm = na.rm), na.rm = na.rm)/2 97 | } 98 | stat_funxy(..., funx = fun, funy = fun, argx = argx, argy = argy) 99 | } 100 | 101 | # ggproto ----------------------------------------------------------------- 102 | 103 | #' @usage NULL 104 | #' @format NULL 105 | #' @export 106 | #' @rdname ggh4x_extensions 107 | StatFunxy <- ggproto( 108 | "StatFunxy", Stat, 109 | required_aes = c("x", "y"), 110 | compute_group = function(data, scales, 111 | funx, funy, 112 | argx, argy, 113 | crop_other = TRUE) { 114 | # Make list for cheaper operations 115 | data <- as.list(data) 116 | 117 | # Apply functions 118 | x <- do.call(funx, c(unname(data["x"]), argx)) 119 | y <- do.call(funy, c(unname(data["y"]), argy)) 120 | 121 | # Ensure rest of data is of correct length 122 | other <- setdiff(names(data), c("x", "y")) 123 | size <- seq_len(max(length(x), length(y))) 124 | if (isTRUE(crop_other)) { 125 | other <- lapply(data[other], `[`, i = size) 126 | } else { 127 | other <- data[other] 128 | } 129 | 130 | # Combine data 131 | data <- c(other, list(x = x, y = y)) 132 | data <- do.call(vec_recycle_common, data) 133 | new_data_frame(data) 134 | } 135 | ) 136 | -------------------------------------------------------------------------------- /R/position_disjoint_ranges.R: -------------------------------------------------------------------------------- 1 | # Main function ----------------------------------------------------------- 2 | 3 | #' Segregating overlapping ranges 4 | #' 5 | #' @description One-dimensional ranged data in the x-direction is segregated in 6 | #' the y-direction such that no overlap in two-dimensional space occurs. This 7 | #' positioning works best when no relevant information is plotted in the 8 | #' y-direction. 9 | #' 10 | #' @param extend a `numeric` of length 1 indicating how far a range should 11 | #' be extended in total for calculating overlaps. Setting this argument to a 12 | #' positive number leaves some space between ranges in the same bin. 13 | #' @param stepsize a `numeric` of length 1 that determines how much space 14 | #' is added between bins in the y-direction. A positive value grows the bins 15 | #' from bottom to top, while a negative value grows the bins from top to 16 | #' bottom. 17 | #' 18 | #' @export 19 | #' 20 | #' @return A *PositionDisjointRanges* object. 21 | #' 22 | #' @details An object is considered disjoint from a second object when the range 23 | #' between their `xmin` and `xmax` coordinates don't overlap. 24 | #' Objects that overlap are assigned to different bins in the y-direction, 25 | #' whereby lower bins are filled first. This way, information in the 26 | #' x-direction is preserved and different objects can be discerned. 27 | #' 28 | #' Note that this positioning is only particularly useful when y-coordinates 29 | #' do not encode relevant information. Geoms that pair well with this 30 | #' positioning are [`geom_rect()`][ggplot2::geom_tile] and 31 | #' [ggplot2::geom_tile()]. 32 | #' 33 | #' This positioning function was inspired by the `disjointBins()` 34 | #' function in the `IRanges` package, but has been written such that it 35 | #' accepts any numeric input next to solely integer input. 36 | #' 37 | #' @seealso The `disjointBins` function the Bioconductor IRanges package. 38 | #' 39 | #' @examples 40 | #' # Even though geom_tile() is parametrised by middle-x values, it is 41 | #' # internally converted to xmin, xmax, ymin, ymax parametrisation so the 42 | #' # positioning still works. 43 | #' 44 | #' ggplot() + 45 | #' geom_tile(aes(x = rnorm(200), y = 0), 46 | #' width = 0.2, height = 0.9, 47 | #' position = position_disjoint_ranges(extend = 0.1)) 48 | position_disjoint_ranges <- function(extend = 1, stepsize = 1) { 49 | ggproto(NULL, PositionDisjointRanges, extend = extend, stepsize = stepsize) 50 | } 51 | 52 | # ggproto ----------------------------------------------------------------- 53 | 54 | #' @usage NULL 55 | #' @format NULL 56 | #' @export 57 | #' @rdname ggh4x_extensions 58 | PositionDisjointRanges <- ggplot2::ggproto( 59 | "PositionDisjointRanges", 60 | ggplot2::Position, 61 | extend = NULL, 62 | stepsize = NULL, 63 | required_aes = c("xmin", "xmax", "ymin", "ymax"), 64 | setup_params = function(self, data) { 65 | if (is.null(data$xmin) || is.null(data$xmax)) { 66 | cli::cli_warn(c( 67 | "Undefined ranges in the x-direction.", 68 | i = "Please supply {.field xmin} and {.field xmax}." 69 | )) 70 | } 71 | list(extend = self$extend, 72 | stepsize = self$stepsize) 73 | }, 74 | compute_panel = function(data, params, scales) { 75 | 76 | # Simplify groups to ranges 77 | if (length(unique(data[["group"]])) > 1) { 78 | group <- data$group 79 | ranges <- by(data, data$group, function(dat){ 80 | c(min(dat$xmin), max(dat$xmax), dat$group[1]) 81 | }) 82 | ranges <- do.call(rbind, ranges) 83 | 84 | ranges <- setNames(as.data.frame(ranges), 85 | c("xmin", "xmax", "group")) 86 | } else if (all(data[["group"]] == -1)){ 87 | ranges <- cbind(data[, c("xmin", "xmax")], 88 | group = row(data)[, 1]) 89 | group <- ranges$group 90 | } else { 91 | return(data) 92 | } 93 | 94 | # Extend and sort ranges 95 | ranges$xmin <- ranges$xmin - 0.5 * params$extend 96 | ranges$xmax <- ranges$xmax + 0.5 * params$extend 97 | ord <- order(ranges$xmin) 98 | ranges <- ranges[ord, ] 99 | 100 | # Perform disjoint bins operation similar to IRanges::disjointBins(), but 101 | # generalized to any ranged numeric data, not just integers. 102 | track_bins <- ranges$xmax[1] 103 | ranges$bin <- c(1, vapply(tail(seq_along(ord), -1), function(i) { 104 | dat <- ranges[i, ] 105 | j <- which(track_bins < dat$xmin) 106 | if (length(j) > 0) { 107 | ans <- j[1] 108 | # If a bin is available, update bin 109 | ends <- track_bins 110 | ends[ans] <- dat$xmax 111 | track_bins <<- ends 112 | } else { 113 | # Else, make new bin 114 | track_bins <<- c(track_bins, dat$xmax) 115 | ans <- length(track_bins) 116 | } 117 | return(ans) 118 | }, integer(1))) 119 | 120 | # Transform 121 | map <- match(group, ranges$group) 122 | if (all(c("ymin", "ymax") %in% names(data))) { 123 | data$ymax <- data$ymax + params$stepsize * (ranges$bin[map] - 1) 124 | data$ymin <- data$ymin + params$stepsize * (ranges$bin[map] - 1) 125 | } 126 | 127 | return(data) 128 | } 129 | ) 130 | -------------------------------------------------------------------------------- /R/stat_rle.R: -------------------------------------------------------------------------------- 1 | # Constructor ------------------------------------------------------------- 2 | 3 | #' @title Run length encoding 4 | #' 5 | #' @description Run length encoding takes a vector of values and calculates the 6 | #' lengths of consecutive repeated values. 7 | #' 8 | #' @inheritParams ggplot2::stat_density 9 | #' @param geom Use to override the default connection between 10 | #' `geom_rect()` and `stat_rle()`. 11 | #' @param align A `character` of length one that effect the computed 12 | #' `start` and `end` variables. One of the following: 13 | #' \describe{ 14 | #' \item{`"none"`}{Take exact start and end `x` values.} 15 | #' \item{`"center"`}{Return start and end `x` values in between an 16 | #' end and the subsequent start.} 17 | #' \item{`"start"`}{Align start values with previous end values.} 18 | #' \item{`"end"`}{Align end values with next start values.} 19 | #' } 20 | #' 21 | #' @details 22 | #' The data is first ordered on the `x` aesthetic before run lengths are 23 | #' calculated for the `label` aesthetic. In contrast to `base::rle()`, `NA`s 24 | #' are considered equivalent values, not different values. 25 | #' 26 | #' @section Aesthetics: `stat_rle()` understands the following 27 | #' aesthetics (required aesthetics are in bold) 28 | #' \itemize{ 29 | #' \item{**x**} 30 | #' \item{**label**} 31 | #' \item{group} 32 | #' } 33 | #' 34 | #' @section Computed variables: 35 | #' \describe{ 36 | #' \item{start}{The `x` values at the start of every run.} 37 | #' \item{end}{The `x` values at the end of every run.} 38 | #' \item{start_id}{The index where a run starts.} 39 | #' \item{end_id}{The index where a run ends.} 40 | #' \item{run_id}{The index of a run.} 41 | #' \item{runlength}{The length of a run.} 42 | #' \item{runvalue}{The value associated with a run.} 43 | #' } 44 | #' 45 | #' @return A `ggplot2` layer 46 | #' @export 47 | #' @name stat_rle 48 | #' 49 | #' @examples 50 | #' df <- data.frame( 51 | #' x = seq(0, 10, length.out = 100), 52 | #' y = sin(seq(0, 10, length.out = 100)*2) 53 | #' ) 54 | #' 55 | #' # Label every run of increasing values 56 | #' ggplot(df) + 57 | #' stat_rle(aes(x, label = diff(c(0, y)) > 0), 58 | #' align = "end") + 59 | #' geom_point(aes(x, y)) 60 | #' 61 | #' # Label every run above some threshold 62 | #' ggplot(df) + 63 | #' stat_rle(aes(x, label = y > 0), 64 | #' align = "center") + 65 | #' geom_point(aes(x, y)) 66 | #' 67 | #' # Categorising runs, more complicated usage 68 | #' ggplot(df) + 69 | #' stat_rle(aes(stage(x, after_stat = run_id), 70 | #' after_stat(runlength), 71 | #' label = cut(y, c(-1, -0.6, 0.6, 1)), 72 | #' fill = after_stat(runvalue)), 73 | #' geom = "col") 74 | stat_rle <- function( 75 | mapping = NULL, 76 | data = NULL, 77 | geom = "rect", 78 | position = "identity", 79 | ..., 80 | align = "none", 81 | na.rm = FALSE, 82 | orientation = "x", 83 | show.legend = NA, 84 | inherit.aes = TRUE 85 | ) { 86 | align <- match.arg(align, c("none", "centre", "center", "start", "end")) 87 | if (align == "center") { 88 | align <- "centre" 89 | } 90 | layer( 91 | data = data, 92 | mapping = mapping, 93 | stat = StatRle, 94 | geom = geom, 95 | position = position, 96 | show.legend = show.legend, 97 | inherit.aes = inherit.aes, 98 | params = list2( 99 | na.rm = na.rm, 100 | orientation = orientation, 101 | align = align, 102 | ... 103 | ) 104 | ) 105 | } 106 | 107 | # ggproto class ----------------------------------------------------------- 108 | 109 | #' @usage NULL 110 | #' @format NULL 111 | #' @export 112 | #' @rdname ggh4x_extensions 113 | StatRle <- ggproto( 114 | "StatRle", 115 | Stat, 116 | required_aes = c("x", "label"), 117 | default_aes = aes( 118 | xmin = after_stat(start), 119 | xmax = after_stat(end), 120 | ymin = after_stat(-Inf), 121 | ymax = after_stat(Inf), 122 | fill = after_stat(runvalue) 123 | ), 124 | dropped_aes = c("x", "label"), 125 | setup_params = function(data, params) { 126 | params$flipped_aes <- isTRUE(params$orientation == "y") 127 | params 128 | }, 129 | extra_params = c("na.rm", "orientation", "align"), 130 | compute_group = function(data, flipped_aes = FALSE, align, scales) { 131 | data <- data[order(data$x), ] 132 | n <- nrow(data) 133 | 134 | run <- vec_unrep(data$label) 135 | 136 | start_id <- {end_id <- cumsum(run$times)} - run$times + 1 137 | 138 | if (align == "centre") { 139 | start <- (data$x[pmax(start_id, 1L)] + data$x[pmax(start_id - 1, 1L)]) / 2 140 | end <- (data$x[pmin(end_id, n)] + data$x[pmin(end_id + 1, n)]) / 2 141 | } else if (align == "end") { 142 | start <- data$x[pmax(start_id - 1, 1L)] 143 | end <- data$x[end_id] 144 | } else if (align == "start") { 145 | start <- data$x[start_id] 146 | end <- data$x[pmin(end_id + 1, n)] 147 | } else { 148 | start <- data$x[start_id] 149 | end <- data$x[end_id] 150 | } 151 | 152 | data_frame0( 153 | start = start, 154 | end = end, 155 | start_id = start_id, 156 | end_id = end_id, 157 | run_id = seq_along(run$key), 158 | runlength = run$times, 159 | runvalue = run$key 160 | ) 161 | } 162 | ) 163 | --------------------------------------------------------------------------------