Exploring new geoms for diverging plots

.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: |

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)

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
 

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)
+}

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
 )