diff --git a/R/data_tabulate.R b/R/data_tabulate.R index 615894a50..ae84d3080 100644 --- 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 = "", - 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 index 77c128c40..d943e4060 100644 --- 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 + | | 5 | 4.76 | | + ---------+-------+----+-------+---------+------------- + e16sex | 1 | 50 | 47.62 | 100.00 | 100.00 + | 2 | 55 | 52.38 | | + ------------------------------------------------------ + +--- + + 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 index e548017d8..3b70beac3 100644 --- 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))) })