add tests

easystats · Feb 7, 2024 · e47e776 · e47e776
1 parent 941dfc4
commit e47e776
Show file tree

Hide file tree

Showing 3 changed files with 65 additions and 3 deletions.
diff --git a/R/data_tabulate.R b/R/data_tabulate.R
@@ -141,6 +141,7 @@ data_tabulate.default <- function(x, drop_levels = FALSE, weights = NULL, name =
   attr(out, "object") <- obj_name
   attr(out, "group_variable") <- group_variable
   attr(out, "duplicate_varnames") <- duplicated(out$Variable)
+  attr(out, "weights") <- weights
 
   attr(out, "total_n") <- sum(out$N, na.rm = TRUE)
   attr(out, "valid_n") <- sum(out$N[-length(out$N)], na.rm = TRUE)
@@ -177,6 +178,7 @@ data_tabulate.data.frame <- function(x,
 
   class(out) <- c("dw_data_tabulates", "list")
   attr(out, "collapse") <- isTRUE(collapse)
+  attr(out, "is_weighted") <- !is.null(weights)
 
   out
 }
@@ -231,6 +233,7 @@ data_tabulate.grouped_df <- function(x,
   }
   class(out) <- c("dw_data_tabulates", "list")
   attr(out, "collapse") <- isTRUE(collapse)
+  attr(out, "is_weighted") <- !is.null(weights)
 
   out
 }
@@ -373,6 +376,9 @@ print_md.dw_data_tabulate <- function(x, big_mark = NULL, ...) {
 
 #' @export
 print.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
+  # check if we have weights
+  is_weighted <- isTRUE(attributes(x)$is_weighted)
+
   a <- attributes(x)
   if (!isTRUE(a$collapse) || length(x) == 1) {
     for (i in seq_along(x)) {
@@ -390,7 +396,11 @@ print.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
     })
 
     out <- do.call(rbind, x)
-    cat(insight::print_color("# Frequency Table\n\n", "blue"))
+    if (is_weighted) {
+      cat(insight::print_color("# Frequency Table (weighted)\n\n", "blue"))
+    } else {
+      cat(insight::print_color("# Frequency Table\n\n", "blue"))
+    }
 
     # print table
     cat(insight::export_table(
@@ -405,6 +415,9 @@ print.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
 
 #' @export
 print_html.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
+  # check if we have weights
+  is_weighted <- isTRUE(attributes(x)$is_weighted)
+
   if (length(x) == 1) {
     print_html(x[[1]], big_mark = big_mark, ...)
   } else {
@@ -421,7 +434,7 @@ print_html.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
     insight::export_table(
       out,
       missing = "<NA>",
-      caption = "Frequency Table",
+      caption = ifelse(is_weighted, "Frequency Table (weighted)", "Frequency Table"),
       format = "html",
       group_by = "Group"
     )
@@ -431,6 +444,9 @@ print_html.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
 
 #' @export
 print_md.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
+  # check if we have weights
+  is_weighted <- isTRUE(attributes(x)$is_weighted)
+
   if (length(x) == 1) {
     print_md(x[[1]], big_mark = big_mark, ...)
   } else {
@@ -451,7 +467,7 @@ print_md.dw_data_tabulates <- function(x, big_mark = NULL, ...) {
       missing = "(NA)",
       empty_line = "-",
       format = "markdown",
-      title = "Frequency Table"
+      title = ifelse(is_weighted, "Frequency Table (weighted)", "Frequency Table")
     )
   }
 }

diff --git a/tests/testthat/_snaps/data_tabulate.md b/tests/testthat/_snaps/data_tabulate.md
@@ -1,3 +1,46 @@
+# data_tabulate, weights
+
+    Code
+      print(data_tabulate(efc, c("e42dep", "e16sex"), collapse = TRUE, weights = efc$
+        weights))
+    Output
+      # Frequency Table (weighted)
+      
+      Variable | Value |  N | Raw % | Valid % | Cumulative %
+      ---------+-------+----+-------+---------+-------------
+      e42dep   |     1 |  3 |  2.86 |    3.00 |         3.00
+               |     2 |  4 |  3.81 |    4.00 |         7.00
+               |     3 | 26 | 24.76 |   26.00 |        33.00
+               |     4 | 67 | 63.81 |   67.00 |       100.00
+               |  <NA> |  5 |  4.76 |    <NA> |         <NA>
+      ---------+-------+----+-------+---------+-------------
+      e16sex   |     1 | 50 | 47.62 |  100.00 |       100.00
+               |     2 | 55 | 52.38 |    <NA> |         <NA>
+      ------------------------------------------------------
+
+---
+
+    Code
+      print_md(data_tabulate(efc, c("e42dep", "e16sex"), weights = efc$weights))
+    Output
+       [1] "Table: Frequency Table (weighted)"                   
+       [2] ""                                                    
+       [3] "|Variable | Value|  N| Raw %| Valid %| Cumulative %|"
+       [4] "|:--------|-----:|--:|-----:|-------:|------------:|"
+       [5] "|e42dep   |     1|  3|  2.86|    3.00|         3.00|"
+       [6] "|         |     2|  4|  3.81|    4.00|         7.00|"
+       [7] "|         |     3| 26| 24.76|   26.00|        33.00|"
+       [8] "|         |     4| 67| 63.81|   67.00|       100.00|"
+       [9] "|         |  (NA)|  5|  4.76|    (NA)|         (NA)|"
+      [10] "|         |      |   |      |        |             |"
+      [11] "|e16sex   |     1| 50| 47.62|  100.00|       100.00|"
+      [12] "|         |     2| 55| 52.38|    (NA)|         (NA)|"
+      [13] "|         |      |   |      |        |             |"
+      attr(,"format")
+      [1] "pipe"
+      attr(,"class")
+      [1] "knitr_kable" "character"  
+
 # data_tabulate print
 
     Code

diff --git a/tests/testthat/test-data_tabulate.R b/tests/testthat/test-data_tabulate.R
@@ -52,6 +52,9 @@ test_that("data_tabulate, weights", {
   # mismatch of lengths
   w <- c(efc$weights, 1)
   expect_error(data_tabulate(efc$e42dep, weights = w), regex = "Length of weights")
+  # correct table caption
+  expect_snapshot(print(data_tabulate(efc, c("e42dep", "e16sex"), collapse = TRUE, weights = efc$weights)))
+  expect_snapshot(print_md(data_tabulate(efc, c("e42dep", "e16sex"), weights = efc$weights)))
 })