data_summary() works with bayestestR::ci() (#483)

* Draft new `data_summary()` function

* check if we can avoid duplicated code

* pkgdown

* fix

* fixes

* lintr

* add tests

* code style

* desc, news

* fix

* add print method and snapshot test

* add test

* correct english form

* test

* include NA, sort output

* add test

* meaningful code comments

* add test

* Update data_summary.R

* fix

Author: strengejacke

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: datawizard
 Title: Easy Data Wrangling and Statistical Transformations
-Version: 0.13.0.14
+Version: 0.13.0.15
 Authors@R: c(
     person("Indrajeet", "Patil", , "[email protected]", role = "aut",
            comment = c(ORCID = "0000-0003-1995-6531")),

NEWS.md

@@ -25,6 +25,9 @@ CHANGES
 * The `replacement` argument in `data_rename()` now supports glue-styled
   tokens  (#563).
 
+* `data_summary()` also accepts the results of `bayestestR::ci()` as summary
+  function (#483).
+
 BUG FIXES
 
 * `describe_distribution()` no longer errors if the sample was too sparse to compute

R/data_summary.R

@@ -122,7 +122,7 @@ data_summary.data.frame <- function(x, ..., by = NULL, remove_na = FALSE) {
       # bind grouping-variables and values
       summarised_data <- cbind(s[1, by], summarised_data)
       # make sure we have proper column names
-      colnames(summarised_data) <- c(by, vapply(summarise, names, character(1)))
+      colnames(summarised_data) <- c(by, unlist(lapply(summarise, names)))
       summarised_data
     })
     out <- do.call(rbind, out)
@@ -187,18 +187,24 @@ data_summary.grouped_df <- function(x, ..., by = NULL, remove_na = FALSE) {
 
     out <- lapply(seq_along(dots), function(i) {
       new_variable <- .get_new_dots_variable(dots, i, data)
-      stats::setNames(new_variable, names(dots)[i])
+      if (inherits(new_variable, c("bayestestR_ci", "bayestestR_eti"))) {
+        stats::setNames(new_variable, c("CI", "CI_low", "CI_high"))
+      } else {
+        stats::setNames(new_variable, names(dots)[i])
+      }
     })
   }
 
   # check for correct length of output - must be a single value!
-  if (any(lengths(out) != 1)) {
+  # Exception: bayestestR::ci()
+  wrong_length <- !sapply(out, inherits, what = c("bayestestR_ci", "bayestestR_eti")) & lengths(out) != 1 # nolint
+  if (any(wrong_length)) {
     insight::format_error(
       paste0(
         "Each expression must return a single value. Following expression",
-        ifelse(sum(lengths(out) != 1) > 1, "s", " "),
+        ifelse(sum(wrong_length) > 1, "s", " "),
         " returned more than one value: ",
-        text_concatenate(vapply(dots[lengths(out) != 1], insight::safe_deparse, character(1)), enclose = "\"")
+        text_concatenate(vapply(dots[wrong_length], insight::safe_deparse, character(1)), enclose = "\"")
       )
     )
   }
@@ -214,6 +220,11 @@ print.dw_data_summary <- function(x, ...) {
   if (nrow(x) == 0) {
     cat("No matches found.\n")
   } else {
+    if (all(c("CI", "CI_low", "CI_high") %in% colnames(x))) {
+      ci <- insight::format_table(x[c("CI", "CI_low", "CI_high")], ...)
+      x$CI <- x$CI_low <- x$CI_high <- NULL
+      x <- cbind(x, ci)
+    }
     cat(insight::export_table(x, missing = "<NA>", ...))
   }
 }

tests/testthat/test-data_summary.R

@@ -228,3 +228,26 @@ test_that("data_summary, extra functions", {
   out <- data_summary(mtcars, n = n(), by = c("am", "gear"))
   expect_identical(out$n, c(15L, 4L, 8L, 5L))
 })
+
+
+test_that("data_summary, bayestestR::ci", {
+  skip_if_not_installed("bayestesR")
+  data(mtcars)
+  out <- data_summary(
+    mtcars,
+    mean_value = mean(mpg),
+    ci = bayestestR::ci(mpg),
+    by = c("am", "gear")
+  )
+  expect_snapshot(out)
+  expect_error(
+    data_summary(
+      mtcars,
+      mw = mean(mpg),
+      test = bayestestR::ci(mpg),
+      yolo = c(mean(mpg), sd(mpg)),
+      by = c("am", "gear")
+    ),
+    regex = "Each expression"
+  )
+})