diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 21b8a93..9882260 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -6,7 +6,9 @@ on: pull_request: branches: [main, master] -name: test-coverage +name: test-coverage.yaml + +permissions: read-all jobs: test-coverage: @@ -23,18 +25,27 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::covr + extra-packages: any::covr, any::xml2 needs: coverage - name: Test coverage run: | - covr::codecov( + cov <- covr::package_coverage( quiet = FALSE, clean = FALSE, install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + covr::to_cobertura(cov) shell: Rscript {0} + - uses: codecov/codecov-action@v4 + with: + fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + - name: Show testthat output if: always() run: | diff --git a/NAMESPACE b/NAMESPACE index e46af27..4d0fa66 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,12 +3,20 @@ S3method(round_any,POSIXct) S3method(round_any,numeric) export("%>%") +export(PositionDiverging) export(PositionLikert) -export(PositionLikertCount) export(StatCross) export(StatProp) export(StatWeightedMean) export(augment_chisq_add_phi) +export(geom_diverging) +export(geom_diverging_text) +export(geom_likert) +export(geom_likert_text) +export(geom_prop_bar) +export(geom_prop_text) +export(geom_pyramid) +export(geom_pyramid_text) export(geom_stripped_cols) export(geom_stripped_rows) export(ggcoef_compare) @@ -26,8 +34,8 @@ export(label_number_abs) export(label_percent_abs) export(likert_pal) export(pal_extender) +export(position_diverging) export(position_likert) -export(position_likert_count) export(round_any) export(scale_colour_extended) export(scale_fill_extended) diff --git a/NEWS.md b/NEWS.md index 51a5409..0beafa9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggstats (development version) +**Minor breaking change** + +* `position_likert_count()` has been renamed as `position_diverging()` (#69) + **Improvements** * new scale `scale_fill_likert()` @@ -10,6 +14,14 @@ * new sorting option `"prop_lower"` for `gglikert()` (#62) * new helper `symmetric_limits()` to make a scale symmetric (#66) * new argument `symmetric` for `gglikert()` (#66) +* new arguments `default_by`, `height`, `labels` and `labeller` for + `stat_prop()` (#69) +* new returned statistics for `stat_prop()`: `after_stat(denominator)`, + `after_stat(height)` and `after_stat(labels)` +* new geometries: `geom_diverging()`, `geom_likert()`, + `geom_pyramid()` and `geom_diverging_text()`, `geom_likert_text()`, + `geom_pyramid_text()` (#69) +* new geometries: `geom_prop_bar()` and `geom_prop_text()` (#69) # ggstats 0.6.0 diff --git a/R/geom_diverging.R b/R/geom_diverging.R new file mode 100644 index 0000000..ae25010 --- /dev/null +++ b/R/geom_diverging.R @@ -0,0 +1,233 @@ +#' Geometries for diverging bar plots +#' +#' These geometries are similar to [`ggplot2::geom_bar()`] but provides +#' different set of default values. +#' +#' - `geom_diverging()` is designed for stacked diverging bar plots, using +#' [`position_diverging()`]. +#' - `geom_likert()` is designed for Likert-type items. Using +#' `position_likert()` (each bar sums to 100%). +#' - `geom_pyramid()` is similar to `geom_diverging()` but uses +#' proportions of the total instead of counts. +#' +#' To add labels on the bar plots, simply use `geom_diverging_text()`, +#' `geom_likert_text()`, or `geom_pyramid_text()`. +#' +#' @param mapping Optional set of aesthetic mappings. +#' @param data The data to be displayed in this layers. +#' @param stat The statistical transformation to use on the data for this layer. +#' @param position A position adjustment to use on the data for this layer. +#' @param ... Other arguments passed on to [`ggplot2::geom_bar()`] +#' @param complete An aesthetic for those unobserved values should be completed, +#' see [`stat_prop()`]. Passed only if `stat = "prop"`. +#' @param default_by Name of an aesthetic determining denominators by default, +#' see [`stat_prop()`]. Passed only if `stat = "prop"`. +#' @param height Statistic used, by default, to determine the height/width, +#' see [`stat_prop()`]. Passed only if `stat = "prop"`. +#' @param labels Statistic used, by default, to determine the labels, +#' see [`stat_prop()`]. Passed only if `stat = "prop"`. +#' @param labeller Labeller function to format labels, +#' see [`stat_prop()`]. Passed only if `stat = "prop"`. +#' @inheritParams position_likert +#' @export +#' @examples +#' library(ggplot2) +#' ggplot(diamonds) + +#' aes(x = clarity, fill = cut) + +#' geom_diverging() +#' +#' ggplot(diamonds) + +#' aes(x = clarity, fill = cut) + +#' geom_diverging(cutoff = 4) +#' +#' ggplot(diamonds) + +#' aes(y = clarity, fill = cut) + +#' geom_likert() + +#' geom_likert_text(aes(color = after_scale(hex_bw(.data$fill)))) +#' +#' d <- Titanic |> as.data.frame() +#' +#' ggplot(d) + +#' aes(y = Class, fill = Sex, weight = Freq) + +#' geom_diverging() + +#' geom_diverging_text() +#' +#' ggplot(d) + +#' aes(y = Class, fill = Sex, weight = Freq) + +#' geom_pyramid() + +#' geom_pyramid_text() +geom_diverging <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging( + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = "fill", + default_by = "total", + height = "count", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL) { + + args <- list(...) + if (stat == "prop") { + args$complete <- complete + args$default_by <- default_by + args$height <- height + } + + args$mapping <- mapping + args$data <- data + args$stat <- stat + args$position <- position + do.call(ggplot2::geom_bar, args) +} + +#' @rdname geom_diverging +#' @export +geom_likert <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_likert( + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = "fill", + default_by = "x", + height = "prop", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL) { + + args <- c(as.list(environment()), list(...)) + do.call(geom_diverging, args) +} + +#' @rdname geom_diverging +#' @export +geom_pyramid <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging( + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = NULL, + default_by = "total", + height = "prop", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL) { + + args <- c(as.list(environment()), list(...)) + do.call(geom_diverging, args) +} + +#' @rdname geom_diverging +#' @export +geom_diverging_text <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging( + vjust = vjust, + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = "fill", + default_by = "total", + height = "count", + labels = "count", + labeller = + label_number_abs(hide_below = hide_below), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL) { + + args <- list(...) + if (stat == "prop") { + args$complete <- complete + args$default_by <- default_by + args$height <- height + args$labels <- labels + args$labeller <- labeller + } + + args$mapping <- mapping + args$data <- data + args$stat <- stat + args$position <- position + do.call(ggplot2::geom_text, args) +} + +#' @rdname geom_diverging +#' @param hide_below If provided, values below `hide_below` will be masked. +#' Argument passed to [`label_number_abs()`] or [`label_percent_abs()`]. +#' @export +geom_likert_text <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_likert( + vjust = vjust, + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = "fill", + default_by = "x", + height = "prop", + labels = "prop", + labeller = label_percent_abs( + accuracy = 1, + hide_below = hide_below + ), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL) { + + args <- c(as.list(environment()), list(...)) + do.call(geom_diverging_text, args) +} + +#' @rdname geom_diverging +#' @export +geom_pyramid_text <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging( + vjust = vjust, + reverse = reverse, + exclude_fill_values = exclude_fill_values, + cutoff = cutoff + ), + ..., + complete = NULL, + default_by = "total", + height = "prop", + labels = "prop", + labeller = label_percent_abs( + accuracy = 1, + hide_below = hide_below + ), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL) { + + args <- c(as.list(environment()), list(...)) + do.call(geom_diverging_text, args) +} diff --git a/R/position_likert.R b/R/position_likert.R index f154463..8fbecdf 100644 --- a/R/position_likert.R +++ b/R/position_likert.R @@ -1,10 +1,11 @@ #' Stack objects on top of each another and center them around 0 #' -#' `position_likert()` stacks proportion bars on top of each other and +#' `position_diverging()` stacks bars on top of each other and #' center them around zero (the same number of categories are displayed on -#' each side). This type of presentation is commonly used to display -#' Likert-type scales. -#' `position_likert_count()` uses counts instead of proportions. +#' each side). +#' `position_likert()` uses proportions instead of counts. This type of +#' presentation is commonly used to display Likert-type scales. +#' #' #' It is recommended to use `position_likert()` with `stat_prop()` #' and its `complete` argument (see examples). @@ -50,7 +51,7 @@ #' #' ggplot(diamonds) + #' aes(y = clarity, fill = cut) + -#' geom_bar(position = "likert_count") + +#' geom_bar(position = "diverging") + #' scale_x_continuous(label = label_number_abs()) + #' scale_fill_likert() #' @@ -144,13 +145,13 @@ position_likert <- function(vjust = 1, #' @export #' @rdname position_likert -position_likert_count <- function(vjust = 1, - reverse = FALSE, - exclude_fill_values = NULL, - cutoff = NULL) { +position_diverging <- function(vjust = 1, + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL) { ggplot2::ggproto( NULL, - PositionLikertCount, + PositionDiverging, vjust = vjust, reverse = reverse, exclude_fill_values = exclude_fill_values, @@ -295,7 +296,7 @@ pos_likert <- function(df, #' @format NULL #' @usage NULL #' @export -PositionLikertCount <- ggproto("PositionLikertCount", PositionLikert, +PositionDiverging <- ggproto("PositionDiverging", PositionLikert, fill = FALSE ) diff --git a/R/stat_prop.R b/R/stat_prop.R index 0af9f48..23eb49a 100644 --- a/R/stat_prop.R +++ b/R/stat_prop.R @@ -3,25 +3,42 @@ #' `stat_prop()` is a variation of [ggplot2::stat_count()] allowing to #' compute custom proportions according to the **by** aesthetic defining #' the denominator (i.e. all proportions for a same value of **by** will -#' sum to 1). The **by** aesthetic should be a factor. If **by** is not -#' specified, proportions of the total will be computed. +#' sum to 1). If the **by** aesthetic is not specified, denominators will be +#' determined according to the `default_by` argument. #' #' @inheritParams ggplot2::stat_count #' @param geom Override the default connection with [ggplot2::geom_bar()]. #' @param complete Name (character) of an aesthetic for those statistics should -#' be completed for unobserved values (see example) +#' be completed for unobserved values (see example). +#' @param default_by If the **by** aesthetic is not available, name of another +#' aesthetic that will be used to determine the denominators (e.g. `"fill"`), +#' or `NULL` or `"total"` to compute proportions of the total. To be noted, +#' `default_by = "x"` works both for vertical and horizontal bars. +#' @param height Which statistic (`"count"` or `"prop"`) should be used, by +#' default, for determining the height/width of the geometry (accessible +#' through `after_stat(height)`)? +#' @param labels Which statistic (`"prop"` or `"count"`) should be used, by +#' default, for generating formatted labels (accessible through +#' `after_stat(labels)`)? +#' @param labeller Labeller function to format labels and populate +#' `after_stat(labels)`. +#' #' @section Aesthetics: #' `stat_prop()` understands the following aesthetics #' (required aesthetics are in bold): #' #' - **x *or* y** -#' - by (this aesthetic should be a **factor**) -#' - group +#' - by #' - weight #' @section Computed variables: #' \describe{ -#' \item{count}{number of points in bin} -#' \item{prop}{computed proportion} +#' \item{`after_stat(count)`}{number of points in bin} +#' \item{`after_stat(denominator)`}{denominator for the proportions} +#' \item{`after_stat(prop)`}{computed proportion, i.e. +#' `after_stat(count)`/`after_stat(denominator)`} +#' \item{`after_stat(height)`}{counts or proportions, according to `height`} +#' \item{`after_stat(labels)`}{formatted heights, according to `labels` and +#' `labeller`} #' } #' @seealso `vignette("stat_prop")`, [ggplot2::stat_count()]. For an alternative #' approach, see @@ -61,6 +78,11 @@ #' ) #' } #' +#' ggplot(d) + +#' aes(y = Class, fill = Survived, weight = Freq) + +#' geom_prop_bar() + +#' geom_prop_text() +#' #' # displaying unobserved levels with complete #' d <- diamonds %>% #' dplyr::filter(!(cut == "Ideal" & clarity == "I1")) %>% @@ -72,6 +94,7 @@ #' p + geom_text(stat = "prop", position = position_fill(.5)) #' p + geom_text(stat = "prop", position = position_fill(.5), complete = "fill") #' } + stat_prop <- function(mapping = NULL, data = NULL, geom = "bar", @@ -82,12 +105,20 @@ stat_prop <- function(mapping = NULL, orientation = NA, show.legend = NA, inherit.aes = TRUE, - complete = NULL) { + complete = NULL, + default_by = "total", + height = c("count", "prop"), + labels = c("prop", "count"), + labeller = scales::label_percent(accuracy = .1)) { params <- list( na.rm = na.rm, orientation = orientation, width = width, complete = complete, + default_by = default_by, + height = height, + labels = labels, + labeller = labeller, ... ) if (!is.null(params$y)) { @@ -116,8 +147,10 @@ stat_prop <- function(mapping = NULL, StatProp <- ggplot2::ggproto("StatProp", ggplot2::Stat, required_aes = c("x|y"), default_aes = ggplot2::aes( - x = after_stat(count), y = after_stat(count), weight = 1, - label = scales::percent(after_stat(prop), accuracy = .1), + x = after_stat(height), + y = after_stat(height), + weight = 1, + label = after_stat(labels), by = 1 ), setup_params = function(data, params) { @@ -141,23 +174,37 @@ StatProp <- ggplot2::ggproto("StatProp", ggplot2::Stat, call. = FALSE ) } - # there is an unresolved bug when by is a character vector. To be explored. - if (is.character(data$by)) { - cli::cli_abort( - "The {.arg by} aesthetic should be a factor instead of a character.", - call. = FALSE - ) - } params }, extra_params = c("na.rm"), compute_panel = function(self, data, scales, - width = NULL, flipped_aes = FALSE, complete = NULL) { + width = NULL, + flipped_aes = FALSE, + complete = NULL, + default_by = "total", + height = c("count", "prop"), + labels = c("prop", "count"), + labeller = + scales::label_percent(accuracy = .1)) { + height <- match.arg(height) + labels <- match.arg(labels) data <- ggplot2::flip_data(data, flipped_aes) data$weight <- data$weight %||% rep(1, nrow(data)) + + if (default_by == "y") default_by <- "x" + if ( + is.null(data[["by"]]) && + !is.null(default_by) && + !is.null(data[[default_by]]) + ) { + data$by <- data[[default_by]] + } + data$by <- data$by %||% rep(1, nrow(data)) width <- width %||% (ggplot2::resolution(data$x) * 0.9) + if (is.character(data$by)) data$by <- factor(data$by) + # sum weights for each combination of by and aesthetics # the use of . allows to consider all aesthetics defined in data panel <- stats::aggregate(weight ~ ., data = data, sum, na.rm = TRUE) @@ -165,7 +212,7 @@ StatProp <- ggplot2::ggproto("StatProp", ggplot2::Stat, names(panel)[which(names(panel) == "weight")] <- "count" panel$count[is.na(panel$count)] <- 0 - if (!is.null(complete)) { + if (!is.null(complete) && complete %in% names(panel)) { panel <- panel %>% dplyr::select(-dplyr::all_of("group")) cols <- names(panel) cols <- cols[!cols %in% c("count", complete)] @@ -183,10 +230,73 @@ StatProp <- ggplot2::ggproto("StatProp", ggplot2::Stat, sum_abs <- function(x) { sum(abs(x)) } - panel$prop <- panel$count / ave(panel$count, panel$by, FUN = sum_abs) + panel$denominator <- ave(panel$count, panel$by, FUN = sum_abs) + panel$prop <- panel$count / panel$denominator + panel$height <- panel[[height]] + panel$labels <- labeller(panel[[labels]]) panel$width <- width panel$flipped_aes <- flipped_aes ggplot2::flip_data(panel, flipped_aes) } ) + +#' @rdname stat_prop +#' @param stat The statistical transformation to use on the data for this layer. +#' @export +geom_prop_bar <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_stack(), + ..., + complete = NULL, + default_by = "x", + height = "prop") { + + args <- list(...) + if (stat == "prop") { + args$complete <- complete + args$default_by <- default_by + args$height <- height + } + + args$mapping <- mapping + args$data <- data + args$stat <- stat + args$position <- position + do.call(ggplot2::geom_bar, args) +} + +#' @rdname stat_prop +#' @param vjust Vertical/Horizontal adjustment for the position. Set to 0 to +#' align with the bottom/left, 0.5 (the default) for the middle, and 1 for the +#' top/right. +#' @export +geom_prop_text <- function(mapping = NULL, + data = NULL, + stat = "prop", + position = position_stack(vjust), + ..., + complete = NULL, + default_by = "x", + height = "prop", + labels = "prop", + labeller = + scales::label_percent(accuracy = .1), + vjust = 0.5) { + + args <- list(...) + if (stat == "prop") { + args$complete <- complete + args$default_by <- default_by + args$height <- height + args$labels <- labels + args$labeller <- labeller + } + + args$mapping <- mapping + args$data <- data + args$stat <- stat + args$position <- position + do.call(ggplot2::geom_text, args) +} diff --git a/README.Rmd b/README.Rmd index 622814e..5588166 100644 --- a/README.Rmd +++ b/README.Rmd @@ -18,7 +18,7 @@ knitr::opts_chunk$set( [![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) [![R-CMD-check](https://github.com/larmarange/ggstats/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/larmarange/ggstats/actions/workflows/R-CMD-check.yaml) -[![Codecov test coverage](https://codecov.io/gh/larmarange/ggstats/branch/main/graph/badge.svg)](https://app.codecov.io/gh/larmarange/ggstats?branch=main) +[![Codecov test coverage](https://codecov.io/gh/larmarange/ggstats/graph/badge.svg)](https://app.codecov.io/gh/larmarange/ggstats) [![CRAN status](https://www.r-pkg.org/badges/version/ggstats)](https://CRAN.R-project.org/package=ggstats) [![DOI](https://zenodo.org/badge/547360047.svg)](https://zenodo.org/badge/latestdoi/547360047) diff --git a/README.md b/README.md index 607fe45..16406b0 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) [![R-CMD-check](https://github.com/larmarange/ggstats/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/larmarange/ggstats/actions/workflows/R-CMD-check.yaml) [![Codecov test -coverage](https://codecov.io/gh/larmarange/ggstats/branch/main/graph/badge.svg)](https://app.codecov.io/gh/larmarange/ggstats?branch=main) +coverage](https://codecov.io/gh/larmarange/ggstats/graph/badge.svg)](https://app.codecov.io/gh/larmarange/ggstats) [![CRAN status](https://www.r-pkg.org/badges/version/ggstats)](https://CRAN.R-project.org/package=ggstats) [![DOI](https://zenodo.org/badge/547360047.svg)](https://zenodo.org/badge/latestdoi/547360047) diff --git a/inst/WORDLIST b/inst/WORDLIST index 3247fc8..29e9f0d 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -4,6 +4,7 @@ Codecov Colour DOI GGally +Labeller Lifecycle Likert ORCID diff --git a/man/figures/README-unnamed-chunk-6-1.png b/man/figures/README-unnamed-chunk-6-1.png index b0365d5..6097410 100644 Binary files a/man/figures/README-unnamed-chunk-6-1.png and b/man/figures/README-unnamed-chunk-6-1.png differ diff --git a/man/geom_diverging.Rd b/man/geom_diverging.Rd new file mode 100644 index 0000000..69b3829 --- /dev/null +++ b/man/geom_diverging.Rd @@ -0,0 +1,206 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geom_diverging.R +\name{geom_diverging} +\alias{geom_diverging} +\alias{geom_likert} +\alias{geom_pyramid} +\alias{geom_diverging_text} +\alias{geom_likert_text} +\alias{geom_pyramid_text} +\title{Geometries for diverging bar plots} +\usage{ +geom_diverging( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging(reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = "fill", + default_by = "total", + height = "count", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL +) + +geom_likert( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_likert(reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = "fill", + default_by = "x", + height = "prop", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL +) + +geom_pyramid( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging(reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = NULL, + default_by = "total", + height = "prop", + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL +) + +geom_diverging_text( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging(vjust = vjust, reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = "fill", + default_by = "total", + height = "count", + labels = "count", + labeller = label_number_abs(hide_below = hide_below), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL +) + +geom_likert_text( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_likert(vjust = vjust, reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = "fill", + default_by = "x", + height = "prop", + labels = "prop", + labeller = label_percent_abs(accuracy = 1, hide_below = hide_below), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL +) + +geom_pyramid_text( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_diverging(vjust = vjust, reverse = reverse, exclude_fill_values = + exclude_fill_values, cutoff = cutoff), + ..., + complete = NULL, + default_by = "total", + height = "prop", + labels = "prop", + labeller = label_percent_abs(accuracy = 1, hide_below = hide_below), + reverse = FALSE, + exclude_fill_values = NULL, + cutoff = NULL, + vjust = 0.5, + hide_below = NULL +) +} +\arguments{ +\item{mapping}{Optional set of aesthetic mappings.} + +\item{data}{The data to be displayed in this layers.} + +\item{stat}{The statistical transformation to use on the data for this layer.} + +\item{position}{A position adjustment to use on the data for this layer.} + +\item{...}{Other arguments passed on to \code{\link[ggplot2:geom_bar]{ggplot2::geom_bar()}}} + +\item{complete}{An aesthetic for those unobserved values should be completed, +see \code{\link[=stat_prop]{stat_prop()}}. Passed only if \code{stat = "prop"}.} + +\item{default_by}{Name of an aesthetic determining denominators by default, +see \code{\link[=stat_prop]{stat_prop()}}. Passed only if \code{stat = "prop"}.} + +\item{height}{Statistic used, by default, to determine the height/width, +see \code{\link[=stat_prop]{stat_prop()}}. Passed only if \code{stat = "prop"}.} + +\item{reverse}{If \code{TRUE}, will reverse the default stacking order. +This is useful if you're rotating both the plot and legend.} + +\item{exclude_fill_values}{Vector of values from the variable associated with +the \code{fill} aesthetic that should not be displayed (but still taken into +account for computing proportions)} + +\item{cutoff}{number of categories to be displayed negatively (i.e. on the +left of the x axis or the bottom of the y axis), could be a decimal value: +\code{2} to display negatively the two first categories, \code{2.5} to display +negatively the two first categories and half of the third, \code{2.2} to display +negatively the two first categories and a fifth of the third (see examples). +By default (\code{NULL}), it will be equal to the number of categories divided +by 2, i.e. it will be centered.} + +\item{labels}{Statistic used, by default, to determine the labels, +see \code{\link[=stat_prop]{stat_prop()}}. Passed only if \code{stat = "prop"}.} + +\item{labeller}{Labeller function to format labels, +see \code{\link[=stat_prop]{stat_prop()}}. Passed only if \code{stat = "prop"}.} + +\item{vjust}{Vertical adjustment for geoms that have a position +(like points or lines), not a dimension (like bars or areas). Set to +\code{0} to align with the bottom, \code{0.5} for the middle, +and \code{1} (the default) for the top.} + +\item{hide_below}{If provided, values below \code{hide_below} will be masked. +Argument passed to \code{\link[=label_number_abs]{label_number_abs()}} or \code{\link[=label_percent_abs]{label_percent_abs()}}.} +} +\description{ +These geometries are similar to \code{\link[ggplot2:geom_bar]{ggplot2::geom_bar()}} but provides +different set of default values. +} +\details{ +\itemize{ +\item \code{geom_diverging()} is designed for stacked diverging bar plots, using +\code{\link[=position_diverging]{position_diverging()}}. +\item \code{geom_likert()} is designed for Likert-type items. Using +\code{position_likert()} (each bar sums to 100\%). +\item \code{geom_pyramid()} is similar to \code{geom_diverging()} but uses +proportions of the total instead of counts. +} + +To add labels on the bar plots, simply use \code{geom_diverging_text()}, +\code{geom_likert_text()}, or \code{geom_pyramid_text()}. +} +\examples{ +library(ggplot2) +ggplot(diamonds) + + aes(x = clarity, fill = cut) + + geom_diverging() + +ggplot(diamonds) + + aes(x = clarity, fill = cut) + + geom_diverging(cutoff = 4) + +ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_likert() + + geom_likert_text(aes(color = after_scale(hex_bw(.data$fill)))) + +d <- Titanic |> as.data.frame() + +ggplot(d) + + aes(y = Class, fill = Sex, weight = Freq) + + geom_diverging() + + geom_diverging_text() + +ggplot(d) + + aes(y = Class, fill = Sex, weight = Freq) + + geom_pyramid() + + geom_pyramid_text() +} diff --git a/man/ggcoef_model.Rd b/man/ggcoef_model.Rd index f9b1324..e85ff82 100644 --- a/man/ggcoef_model.Rd +++ b/man/ggcoef_model.Rd @@ -191,12 +191,14 @@ ggcoef_plot( \arguments{ \item{model}{a regression model object} -\item{tidy_fun}{option to specify a custom tidier function} +\item{tidy_fun}{(\code{function})\cr +Option to specify a custom tidier function.} \item{tidy_args}{Additional arguments passed to \code{\link[broom.helpers:tidy_plus_plus]{broom.helpers::tidy_plus_plus()}} and to \code{tidy_fun}} -\item{conf.int}{should confidence intervals be computed? (see \code{\link[broom:reexports]{broom::tidy()}})} +\item{conf.int}{(\code{logical})\cr +Should confidence intervals be computed? (see \code{\link[broom:reexports]{broom::tidy()}})} \item{conf.level}{the confidence level to use for the confidence interval if \code{conf.int = TRUE}; must be strictly greater than 0 @@ -206,42 +208,51 @@ percent confidence interval} \item{exponentiate}{if \code{TRUE} a logarithmic scale will be used for x-axis} -\item{variable_labels}{a named list or a named vector of custom variable labels} +\item{variable_labels}{(\code{\link[gtsummary:syntax]{formula-list-selector}})\cr +A named list or a named vector of custom variable labels.} -\item{term_labels}{a named list or a named vector of custom term labels} +\item{term_labels}{(\code{list} or \code{vector})\cr +A named list or a named vector of custom term labels.} -\item{interaction_sep}{separator for interaction terms} +\item{interaction_sep}{(\code{string})\cr +Separator for interaction terms.} -\item{categorical_terms_pattern}{a \link[glue:glue]{glue pattern} for -labels of categorical terms with treatment or sum contrasts -(see \code{\link[broom.helpers:model_list_terms_levels]{model_list_terms_levels()}})} +\item{categorical_terms_pattern}{(\code{\link[glue:glue]{glue pattern}})\cr +A \link[glue:glue]{glue pattern} for labels of categorical terms with treatment +or sum contrasts (see \code{\link[broom.helpers:model_list_terms_levels]{model_list_terms_levels()}}).} -\item{add_reference_rows}{should reference rows be added?} +\item{add_reference_rows}{(\code{logical})\cr +Should reference rows be added?} -\item{no_reference_row}{variables (accepts \link[dplyr:select]{tidyselect} notation) -for those no reference row should be added, when \code{add_reference_rows = TRUE}} +\item{no_reference_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables for those no reference row should be added, +when \code{add_reference_rows = TRUE}.} -\item{intercept}{should the intercept(s) be included?} +\item{intercept}{(\code{logical})\cr +Should the intercept(s) be included?} -\item{include}{variables to include. Accepts \link[dplyr:select]{tidyselect} -syntax. Use \code{-} to remove a variable. Default is \code{everything()}. +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include. Default is \code{everything()}. See also \code{\link[broom.helpers:all_continuous]{all_continuous()}}, \code{\link[broom.helpers:all_categorical]{all_categorical()}}, \code{\link[broom.helpers:all_dichotomous]{all_dichotomous()}} -and \code{\link[broom.helpers:all_interaction]{all_interaction()}}} +and \code{\link[broom.helpers:all_interaction]{all_interaction()}}.} -\item{add_pairwise_contrasts}{apply \code{\link[broom.helpers:tidy_add_pairwise_contrasts]{tidy_add_pairwise_contrasts()}}? -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}} +\item{add_pairwise_contrasts}{(\code{logical})\cr +Apply \code{\link[broom.helpers:tidy_add_pairwise_contrasts]{tidy_add_pairwise_contrasts()}}?} -\item{pairwise_variables}{variables to add pairwise contrasts -(accepts \link[dplyr:select]{tidyselect} notation)} +\item{pairwise_variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to add pairwise contrasts.} -\item{keep_model_terms}{keep original model terms for variables where +\item{keep_model_terms}{(\code{logical})\cr +Keep original model terms for variables where pairwise contrasts are added? (default is \code{FALSE})} -\item{pairwise_reverse}{determines whether to use \code{"pairwise"} (if \code{TRUE}) -or \code{"revpairwise"} (if \code{FALSE}), see \code{\link[emmeans:contrast]{emmeans::contrast()}}} +\item{pairwise_reverse}{(\code{logical})\cr +Determines whether to use \code{"pairwise"} (if \code{TRUE}) +or \code{"revpairwise"} (if \code{FALSE}), see \code{\link[emmeans:contrast]{emmeans::contrast()}}.} -\item{emmeans_args}{list of additional parameter to pass to -\code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts} +\item{emmeans_args}{(\code{list})\cr +List of additional parameter to pass to +\code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts.} \item{significance}{level (between 0 and 1) below which a coefficient is consider to be significantly different from 0 diff --git a/man/position_likert.Rd b/man/position_likert.Rd index f210517..1512c81 100644 --- a/man/position_likert.Rd +++ b/man/position_likert.Rd @@ -3,9 +3,9 @@ \docType{data} \name{position_likert} \alias{position_likert} -\alias{position_likert_count} +\alias{position_diverging} \alias{PositionLikert} -\alias{PositionLikertCount} +\alias{PositionDiverging} \title{Stack objects on top of each another and center them around 0} \usage{ position_likert( @@ -15,7 +15,7 @@ position_likert( cutoff = NULL ) -position_likert_count( +position_diverging( vjust = 1, reverse = FALSE, exclude_fill_values = NULL, @@ -44,11 +44,11 @@ By default (\code{NULL}), it will be equal to the number of categories divided by 2, i.e. it will be centered.} } \description{ -\code{position_likert()} stacks proportion bars on top of each other and +\code{position_diverging()} stacks bars on top of each other and center them around zero (the same number of categories are displayed on -each side). This type of presentation is commonly used to display -Likert-type scales. -\code{position_likert_count()} uses counts instead of proportions. +each side). +\code{position_likert()} uses proportions instead of counts. This type of +presentation is commonly used to display Likert-type scales. } \details{ It is recommended to use \code{position_likert()} with \code{stat_prop()} @@ -77,7 +77,7 @@ ggplot(diamonds) + ggplot(diamonds) + aes(y = clarity, fill = cut) + - geom_bar(position = "likert_count") + + geom_bar(position = "diverging") + scale_x_continuous(label = label_number_abs()) + scale_fill_likert() diff --git a/man/stat_prop.Rd b/man/stat_prop.Rd index 103d586..b65914b 100644 --- a/man/stat_prop.Rd +++ b/man/stat_prop.Rd @@ -4,6 +4,8 @@ \name{stat_prop} \alias{stat_prop} \alias{StatProp} +\alias{geom_prop_bar} +\alias{geom_prop_text} \title{Compute proportions according to custom denominator} \usage{ stat_prop( @@ -17,7 +19,36 @@ stat_prop( orientation = NA, show.legend = NA, inherit.aes = TRUE, - complete = NULL + complete = NULL, + default_by = "total", + height = c("count", "prop"), + labels = c("prop", "count"), + labeller = scales::label_percent(accuracy = 0.1) +) + +geom_prop_bar( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_stack(), + ..., + complete = NULL, + default_by = "x", + height = "prop" +) + +geom_prop_text( + mapping = NULL, + data = NULL, + stat = "prop", + position = position_stack(vjust), + ..., + complete = NULL, + default_by = "x", + height = "prop", + labels = "prop", + labeller = scales::label_percent(accuracy = 0.1), + vjust = 0.5 ) } \arguments{ @@ -107,7 +138,29 @@ that define both data and aesthetics and shouldn't inherit behaviour from the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.} \item{complete}{Name (character) of an aesthetic for those statistics should -be completed for unobserved values (see example)} +be completed for unobserved values (see example).} + +\item{default_by}{If the \strong{by} aesthetic is not available, name of another +aesthetic that will be used to determine the denominators (e.g. \code{"fill"}), +or \code{NULL} or \code{"total"} to compute proportions of the total. To be noted, +\code{default_by = "x"} works both for vertical and horizontal bars.} + +\item{height}{Which statistic (\code{"count"} or \code{"prop"}) should be used, by +default, for determining the height/width of the geometry (accessible +through \code{after_stat(height)})?} + +\item{labels}{Which statistic (\code{"prop"} or \code{"count"}) should be used, by +default, for generating formatted labels (accessible through +\code{after_stat(labels)})?} + +\item{labeller}{Labeller function to format labels and populate +\code{after_stat(labels)}.} + +\item{stat}{The statistical transformation to use on the data for this layer.} + +\item{vjust}{Vertical/Horizontal adjustment for the position. Set to 0 to +align with the bottom/left, 0.5 (the default) for the middle, and 1 for the +top/right.} } \value{ A \code{ggplot2} plot with the added statistic. @@ -116,8 +169,8 @@ A \code{ggplot2} plot with the added statistic. \code{stat_prop()} is a variation of \code{\link[ggplot2:geom_bar]{ggplot2::stat_count()}} allowing to compute custom proportions according to the \strong{by} aesthetic defining the denominator (i.e. all proportions for a same value of \strong{by} will -sum to 1). The \strong{by} aesthetic should be a factor. If \strong{by} is not -specified, proportions of the total will be computed. +sum to 1). If the \strong{by} aesthetic is not specified, denominators will be +determined according to the \code{default_by} argument. } \section{Aesthetics}{ @@ -125,8 +178,7 @@ specified, proportions of the total will be computed. (required aesthetics are in bold): \itemize{ \item \strong{x \emph{or} y} -\item by (this aesthetic should be a \strong{factor}) -\item group +\item by \item weight } } @@ -134,8 +186,13 @@ specified, proportions of the total will be computed. \section{Computed variables}{ \describe{ -\item{count}{number of points in bin} -\item{prop}{computed proportion} +\item{\code{after_stat(count)}}{number of points in bin} +\item{\code{after_stat(denominator)}}{denominator for the proportions} +\item{\code{after_stat(prop)}}{computed proportion, i.e. +\code{after_stat(count)}/\code{after_stat(denominator)}} +\item{\code{after_stat(height)}}{counts or proportions, according to \code{height}} +\item{\code{after_stat(labels)}}{formatted heights, according to \code{labels} and +\code{labeller}} } } @@ -170,6 +227,11 @@ if (requireNamespace("scales")) { ) } +ggplot(d) + +aes(y = Class, fill = Survived, weight = Freq) + + geom_prop_bar() + + geom_prop_text() + # displaying unobserved levels with complete d <- diamonds \%>\% dplyr::filter(!(cut == "Ideal" & clarity == "I1")) \%>\% diff --git a/tests/spelling.R b/tests/spelling.R index d60e024..1d74607 100644 --- a/tests/spelling.R +++ b/tests/spelling.R @@ -1,7 +1,6 @@ -if (requireNamespace("spelling", quietly = TRUE)) { +if (requireNamespace("spelling", quietly = TRUE)) spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) -} diff --git a/tests/testthat/_snaps/position_likert/geom-diverging-and-geom-diverging-text.svg b/tests/testthat/_snaps/position_likert/geom-diverging-and-geom-diverging-text.svg new file mode 100644 index 0000000..c345e3d --- /dev/null +++ b/tests/testthat/_snaps/position_likert/geom-diverging-and-geom-diverging-text.svg @@ -0,0 +1,156 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +210 +96 +84 +205 +146 +466 +1 081 +2 100 +2 949 +2 598 +408 +1 560 +3 240 +3 575 +4 282 +261 +978 +2 591 +3 357 +5 071 +170 +648 +1 775 +1 989 +3 589 +69 +286 +1 235 +870 +2 606 +17 +186 +789 +616 +2 047 +9 +71 +268 +230 +1 212 + + + +I1 +SI2 +SI1 +VS2 +VS1 +VVS2 +VVS1 +IF + + + + + + + + + + + +0 +5000 +10000 +height +clarity + +cut + + + + + + + + + + +Fair +Good +Very Good +Premium +Ideal +geom_diverging and geom_diverging_text + + diff --git a/tests/testthat/_snaps/position_likert/geom-likert-and-geom-likert-text.svg b/tests/testthat/_snaps/position_likert/geom-likert-and-geom-likert-text.svg new file mode 100644 index 0000000..732b362 --- /dev/null +++ b/tests/testthat/_snaps/position_likert/geom-likert-and-geom-likert-text.svg @@ -0,0 +1,156 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +28% +13% +11% +28% +20% +5% +12% +23% +32% +28% +3% +12% +25% +27% +33% +2% +8% +21% +27% +41% +2% +8% +22% +24% +44% +1% +6% +24% +17% +51% +0% +5% +22% +17% +56% +1% +4% +15% +13% +68% + + + +I1 +SI2 +SI1 +VS2 +VS1 +VVS2 +VVS1 +IF + + + + + + + + + + + +-0.5 +0.0 +0.5 +height +clarity + +cut + + + + + + + + + + +Fair +Good +Very Good +Premium +Ideal +geom_likert and geom_likert_text + + diff --git a/tests/testthat/_snaps/position_likert/geom-pyramid-and-geom-pyramid-text.svg b/tests/testthat/_snaps/position_likert/geom-pyramid-and-geom-pyramid-text.svg new file mode 100644 index 0000000..985035e --- /dev/null +++ b/tests/testthat/_snaps/position_likert/geom-pyramid-and-geom-pyramid-text.svg @@ -0,0 +1,81 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +8% +7% +8% +5% +23% +9% +39% +1% + + + +1st +2nd +3rd +Crew + + + + + + + + + + +-0.4 +-0.3 +-0.2 +-0.1 +0.0 +0.1 +height +Class + +Sex + + + + +Male +Female +geom_pyramid and geom_pyramid_text + + diff --git a/tests/testthat/_snaps/position_likert/position-likert-count-base.svg b/tests/testthat/_snaps/position_likert/position-diverging-base.svg similarity index 99% rename from tests/testthat/_snaps/position_likert/position-likert-count-base.svg rename to tests/testthat/_snaps/position_likert/position-diverging-base.svg index 35c1d6b..6678031 100644 --- a/tests/testthat/_snaps/position_likert/position-likert-count-base.svg +++ b/tests/testthat/_snaps/position_likert/position-diverging-base.svg @@ -111,6 +111,6 @@ Very Good Premium Ideal -position_likert_count() base +position_diverging() base diff --git a/tests/testthat/_snaps/position_likert/position-likert-count-facet.svg b/tests/testthat/_snaps/position_likert/position-diverging-facet.svg similarity index 99% rename from tests/testthat/_snaps/position_likert/position-likert-count-facet.svg rename to tests/testthat/_snaps/position_likert/position-diverging-facet.svg index 399bd76..18ac10b 100644 --- a/tests/testthat/_snaps/position_likert/position-likert-count-facet.svg +++ b/tests/testthat/_snaps/position_likert/position-diverging-facet.svg @@ -194,6 +194,6 @@ Very Good Premium Ideal -position_likert_count() facet +position_diverging() facet diff --git a/tests/testthat/_snaps/position_likert/position-likert-count-reverse.svg b/tests/testthat/_snaps/position_likert/position-diverging-reverse.svg similarity index 99% rename from tests/testthat/_snaps/position_likert/position-likert-count-reverse.svg rename to tests/testthat/_snaps/position_likert/position-diverging-reverse.svg index 041f7a5..f75e50c 100644 --- a/tests/testthat/_snaps/position_likert/position-likert-count-reverse.svg +++ b/tests/testthat/_snaps/position_likert/position-diverging-reverse.svg @@ -111,6 +111,6 @@ Very Good Premium Ideal -position_likert_count() reverse +position_diverging() reverse diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-by-character.svg b/tests/testthat/_snaps/stat_prop/stat-prop-by-character.svg new file mode 100644 index 0000000..2395c1d --- /dev/null +++ b/tests/testthat/_snaps/stat_prop/stat-prop-by-character.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +37.5% +62.5% +58.6% +41.4% +74.8% +25.2% +76.0% +24.0% + + + +1st +2nd +3rd +Crew + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +height +Class + +Survived + + + + +No +Yes +stat_prop() by-character + + diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-default-by-fill.svg b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-fill.svg new file mode 100644 index 0000000..70b0a16 --- /dev/null +++ b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-fill.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 + + + + + + + + +1st +2nd +3rd +Crew +Class +prop + +Survived + + + + +No +Yes +stat_prop() default_by fill + + diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-default-by-none.svg b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-none.svg new file mode 100644 index 0000000..c6bdd66 --- /dev/null +++ b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-none.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + +1st +2nd +3rd +Crew +Class +prop + +Survived + + + + +No +Yes +stat_prop() default_by none + + diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x-horizontal.svg b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x-horizontal.svg new file mode 100644 index 0000000..368596d --- /dev/null +++ b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x-horizontal.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1st +2nd +3rd +Crew + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +prop +Class + +Survived + + + + +No +Yes +stat_prop() default_by x horizontal + + diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x.svg b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x.svg new file mode 100644 index 0000000..ab959d6 --- /dev/null +++ b/tests/testthat/_snaps/stat_prop/stat-prop-default-by-x.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + +1st +2nd +3rd +Crew +Class +prop + +Survived + + + + +No +Yes +stat_prop() default_by x + + diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-direct-call.svg b/tests/testthat/_snaps/stat_prop/stat-prop-direct-call.svg index 8965435..d9df397 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-direct-call.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-direct-call.svg @@ -57,7 +57,7 @@ 3rd Crew Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge-not-specifying-by.svg b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge-not-specifying-by.svg index 63d9667..b92fe82 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge-not-specifying-by.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge-not-specifying-by.svg @@ -63,7 +63,7 @@ 3rd Crew Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge.svg b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge.svg index 5596903..633d0c0 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-dodge.svg @@ -63,7 +63,7 @@ 3rd Crew Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-facet.svg b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-facet.svg index 28d37b3..3652592 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-facet.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-facet.svg @@ -122,7 +122,7 @@ Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-stack.svg b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-stack.svg index ee51912..22ca486 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-titanic-stack.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-titanic-stack.svg @@ -63,7 +63,7 @@ 3rd Crew Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-titanic.svg b/tests/testthat/_snaps/stat_prop/stat-prop-titanic.svg index ace1bd4..89bbc8b 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-titanic.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-titanic.svg @@ -65,7 +65,7 @@ 3rd Crew Class -count +height Survived diff --git a/tests/testthat/_snaps/stat_prop/stat-prop-y-aes.svg b/tests/testthat/_snaps/stat_prop/stat-prop-y-aes.svg index cfb81a9..cd95aff 100644 --- a/tests/testthat/_snaps/stat_prop/stat-prop-y-aes.svg +++ b/tests/testthat/_snaps/stat_prop/stat-prop-y-aes.svg @@ -64,7 +64,7 @@ 0.50 0.75 1.00 -count +height Class Survived diff --git a/tests/testthat/test-position_likert.R b/tests/testthat/test-position_likert.R index 69ec031..48bb3fd 100644 --- a/tests/testthat/test-position_likert.R +++ b/tests/testthat/test-position_likert.R @@ -21,17 +21,17 @@ test_that("position_likert()", { p <- ggplot(diamonds) + aes(y = clarity, fill = cut) + - geom_bar(position = "likert_count") + + geom_bar(position = "diverging") + scale_x_continuous(label = label_number_abs()) + scale_fill_brewer(palette = "PiYG") vdiffr::expect_doppelganger( - "position_likert_count() base", + "position_diverging() base", p ) vdiffr::expect_doppelganger( - "position_likert_count() facet", + "position_diverging() facet", p + facet_grid(~ price > 2500) ) @@ -46,10 +46,10 @@ test_that("position_likert()", { p <- ggplot(diamonds) + aes(y = clarity, fill = cut) + - geom_bar(position = position_likert_count(reverse = TRUE)) + geom_bar(position = position_diverging(reverse = TRUE)) vdiffr::expect_doppelganger( - "position_likert_count() reverse", + "position_diverging() reverse", p ) @@ -88,3 +88,36 @@ test_that("position_likert()", { p ) }) + +test_that("geom_diverging() & associates", { + library(ggplot2) + p <- + ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_diverging() + + geom_diverging_text(aes(color = after_scale(hex_bw(.data$fill)))) + vdiffr::expect_doppelganger( + "geom_diverging and geom_diverging_text", + p + ) + + p <- + ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_likert() + + geom_likert_text(aes(color = after_scale(hex_bw(.data$fill)))) + vdiffr::expect_doppelganger( + "geom_likert and geom_likert_text", + p + ) + + d <- Titanic |> as.data.frame() + p <- ggplot(d) + + aes(y = Class, fill = Sex, weight = Freq) + + geom_pyramid() + + geom_pyramid_text() + vdiffr::expect_doppelganger( + "geom_pyramid and geom_pyramid_text", + p + ) +}) diff --git a/tests/testthat/test-stat_prop.R b/tests/testthat/test-stat_prop.R index d8db2ad..9398c14 100644 --- a/tests/testthat/test-stat_prop.R +++ b/tests/testthat/test-stat_prop.R @@ -73,3 +73,62 @@ test_that("stat_prop() works with an y aesthetic", { vdiffr::expect_doppelganger("stat_prop() y-aes", p) }) + +test_that("stat_prop() works with a character by", { + library(ggplot2) + skip_on_cran() + + d <- as.data.frame(Titanic) + p <- ggplot(d) + + aes(y = Class, fill = Survived, weight = Freq, by = as.character(Class)) + + geom_bar(position = "fill") + + geom_text(stat = "prop", position = position_fill(.5)) + + vdiffr::expect_doppelganger("stat_prop() by-character", p) +}) + +test_that("stat_prop() works with default_by", { + library(ggplot2) + skip_on_cran() + + d <- as.data.frame(Titanic) + + p <- ggplot(d) + + aes(x = Class, fill = Survived, weight = Freq, y = after_stat(prop)) + + geom_bar(stat = "prop") + vdiffr::expect_doppelganger("stat_prop() default_by none", p) + + p <- ggplot(d) + + aes(x = Class, fill = Survived, weight = Freq, y = after_stat(prop)) + + geom_bar(stat = "prop", default_by = "fill") + vdiffr::expect_doppelganger("stat_prop() default_by fill", p) + + p <- ggplot(d) + + aes(x = Class, fill = Survived, weight = Freq, y = after_stat(prop)) + + geom_bar(stat = "prop", default_by = "x") + vdiffr::expect_doppelganger("stat_prop() default_by x", p) + + p <- ggplot(d) + + aes(y = Class, fill = Survived, weight = Freq, x = after_stat(prop)) + + geom_bar(stat = "prop", default_by = "x") + vdiffr::expect_doppelganger("stat_prop() default_by x horizontal", p) +}) + +test_that("geom_prop_bar() & geom_prop_text()", { + d <- as.data.frame(Titanic) + p <- ggplot(d) + + aes(y = Class, fill = Survived, weight = Freq) + + geom_prop_bar() + + geom_prop_text() + vdiffr::expect_doppelganger("geom_prop_bar() & geom_prop_text()", p) + + p <- ggplot(d) + + aes(x = Class, fill = Survived, weight = Freq) + + geom_prop_bar(height = "count") + + geom_prop_text( + height = "count", + labels = "count", + labeller = scales::number + ) + vdiffr::expect_doppelganger("geom_prop_bar() & geom_prop_text() - count", p) +}) diff --git a/vignettes/geom_diverging.Rmd b/vignettes/geom_diverging.Rmd new file mode 100644 index 0000000..3a12ad9 --- /dev/null +++ b/vignettes/geom_diverging.Rmd @@ -0,0 +1,203 @@ +--- +title: "Geometries for diverging bar plots" +author: Joseph Larmarange +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Plot Likert-type items with `gglikert()`} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +```{r setup} +library(ggstats) +library(dplyr) +library(ggplot2) +library(patchwork) +``` + +*Note :* if you are looking for an all-in-one function to display Likert-type items, please refer to `gglikert()` and `vignette("gglikert")`. + +## New positions + +Diverging bar plots could be achieved using `position_diverging()` or `position_likert()`. + +`position_diverging()` stacks bars on top of each other and centers them around zero (the same number of categories are displayed on each side). + +```{r} +base <- + ggplot(diamonds) + + aes(y = clarity, fill = cut) + + theme(legend.position = "none") + +p_stack <- + base + + geom_bar(position = "stack") + + ggtitle("position_stack()") + +p_diverging <- + base + + geom_bar(position = "diverging") + + ggtitle("position_diverging()") + +p_stack + p_diverging +``` + +`position_likert()` is similar but uses proportions instead of counts. + +```{r} +p_fill <- + base + + geom_bar(position = "fill") + + ggtitle("position_fill()") + +p_likert <- + base + + geom_bar(position = "likert") + + ggtitle("position_likert()") + +p_fill + p_likert +``` + +By default, the same number of categories is displayed on each side, i.e. if you have 4 categories, 2 will be displayed negatively and 2 positively. If you have an odd number of categories, half of the central category will be displayed negatively and half positively. + +The center could be changed with the `cutoff` argument, representing the number of categories to be displayed negatively: `2` to display negatively the two first categories, `2.5` to display negatively the two first categories and half of the third, `2.2` to display negatively the two first categories and a fifth of the third. + +```{r} +p_1 <- + base + + geom_bar(position = position_diverging(cutoff = 1)) + + ggtitle("cutoff = 1") + +p_2 <- + base + + geom_bar(position = position_diverging(cutoff = 2)) + + ggtitle("cutoff = 2") + +p_null <- + base + + geom_bar(position = position_diverging(cutoff = NULL)) + + ggtitle("cutoff = NULL") + +p_3.75 <- + base + + geom_bar(position = position_diverging(cutoff = 3.75)) + + ggtitle("cutoff = 3.75") + +p_5 <- + base + + geom_bar(position = position_diverging(cutoff = 5)) + + ggtitle("cutoff = 5") + +wrap_plots(p_1, p_2, p_null, p_3.75, p_5) +``` + +## New scales + +For a diverging bar plot, it is recommended to use a diverging palette, as provided in the Brewer palettes. Sometimes, the number of available colors is insufficient in the palette. In that case, you could use `pal_extender()` or `scale_fill_extended()`. However, if you use a custom `cutoff`, it is also important to change the center of the palette as well. + +Therefore, for diverging bar plots, we recommend to use `scale_fill_likert()`. + +```{r} +wrap_plots( + p_1 + scale_fill_likert(cutoff = 1), + p_null + scale_fill_likert(), + p_3.75 + scale_fill_likert(cutoff = 3.75) +) +``` + +## Improving axes + +You may also want have centered axes. That could be easily achieved with `symmetric_limits()`. + +You could also use `label_number_abs()` or `label_percent_abs()` to display absolute numbers. + +```{r} +wrap_plots( + p_3.75, + p_3.75 + + scale_x_continuous( + limits = symmetric_limits, + labels = label_number_abs() + ) +) +``` + +## New geometries + +To facilitate the creation of diverging bar plots, you could use variants of `geom_bar()` and `geom_text()`. + +### geom_diverging() & geom_diverging_text() + +Let's consider the following plot: + +```{r} +ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_bar(position = "diverging") + + geom_text( + aes( + label = + label_number_abs(hide_below = 800) + (after_stat(count)) + ), + stat = "count", + position = position_diverging(.5) + ) + + scale_fill_likert() + + scale_x_continuous( + labels = label_number_abs(), + limits = symmetric_limits + ) +``` + +The same could be achieved quicker with `geom_diverging()` and `geom_diverging_text()`. + +```{r} +ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_diverging() + + geom_diverging_text(hide_below = 800) + + scale_fill_likert() + + scale_x_continuous( + labels = label_number_abs(), + limits = symmetric_limits + ) +``` + +### geom_likert() & geom_likert_text() + +`geom_likert()` and `geom_likert_text()` works similarly. `geom_likert_text()` takes advantages of `stat_prop()` for computing the proportions to be displayed (see `vignette("stat_prop")`). + +```{r} +ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_likert() + + geom_likert_text(hide_below = 0.10) + + scale_fill_likert() + + scale_x_continuous( + labels = label_percent_abs() + ) +``` + +### geom_pyramid() & geom_pyramid_text() + +Finally, `geom_pyramid()` and `geom_pyramid_text()` are variations adapted to display an age-sex pyramid. It uses proportions of the total. + +```{r} +d <- Titanic |> as.data.frame() +ggplot(d) + + aes(y = Class, fill = Sex, weight = Freq) + + geom_pyramid() + + geom_pyramid_text() + + scale_x_continuous( + labels = label_percent_abs(), + limits = symmetric_limits + ) +``` diff --git a/vignettes/stat_prop.Rmd b/vignettes/stat_prop.Rmd index b4dbf14..86058c7 100644 --- a/vignettes/stat_prop.Rmd +++ b/vignettes/stat_prop.Rmd @@ -127,3 +127,42 @@ p + ) ``` +## Using `geom_prop_bar()` and `geom_prop_text()` + +The dedicated geometries `geom_prop_bar()` and `geom_prop_text()` could be used for quick and easy proportional bar plots. They use by default `stat_prop()` with relevant default values. For example, proportions are computed by **x** or **y** if the `by` aesthetic is not specified. It allows to generate a quick proportional bar plot. + +```{r} +ggplot(diamonds) + + aes(y = clarity, fill = cut) + + geom_prop_bar() + + geom_prop_text() +``` + + +You can specify a `by` aesthetic. For example, to reproduce the comparison of the two distributions presented earlier. + +```{r} +d <- as.data.frame(Titanic) +ggplot(d) + + aes(x = Class, fill = Sex, weight = Freq, by = Sex) + + geom_prop_bar(position = "dodge") + + geom_prop_text( + position = position_dodge(width = .9), + vjust = - 0.5 + ) + + scale_y_continuous(labels = scales::percent) +``` + + +You can also display counts instead of proportions. + +```{r} +ggplot(diamonds) + + aes(x = clarity, fill = cut) + + geom_prop_bar(height = "count") + + geom_prop_text( + height = "count", + labels = "count", + labeller = scales::number + ) +```